SUBROUTINE CONREC (Z,L,M,N,FLO,HI,FINC,NSET,NHI,NDOT) C C C EXTERNAL CONBD C SAVE CHARACTER*1 IGAP ,ISOL ,RCHAR CHARACTER ENCSCR*22 ,IWORK*252 DIMENSION LNGTHS(5) ,HOLD(5) ,WNDW(4) ,VWPRT(4) DIMENSION Z(L,N) ,CL(80) ,RWORK(80) ,LASF(13) C COMMON /INTPR/ PAD1, FPART, PAD(8) COMMON/INTPR/IPAU,FPART,TENSN,NP1,SMALL,L1,ADDLR,ADDTB,MLLINE, 1 ICLOSE CIBM8 COMMON/INTPR/FPART,TENSN,SMALL,ADDLR,ADDTB,MLLINE, CIBM81 ICLOSE,IPAU,NP1,L1 COMMON /SMOLAB/ ISWIT,ILABS, IOFFMS COMMON /SMOSPV/ SPVAS,JSWIT, IOFFPS COMMON /CONRE1/ SPVAL ,IOFFP COMMON /CONRE3/ IXBITS ,IYBITS COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , 1 NCRT ,ILAB ,NULBLL ,IOFFD , 2 EXT ,IOFFM ,ISOLID ,NLA , 3 NLM ,XLT ,YBT ,SIDE COMMON /CONRE5/ SCLY COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX DATA LNGTHS(1),LNGTHS(2),LNGTHS(3),LNGTHS(4),LNGTHS(5) 1 / 12, 3, 20, 9, 17 / DATA ISOL, IGAP /'$', ''''/ C C ISOL AND IGAP (DOLLAR-SIGN AND APOSTROPHE) ARE USED TO CONSTRUCT PAT- C TERNS PASSED TO ROUTINE DASHDC IN THE SOFTWARE DASHED-LINE PACKAGE. C C C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','CONREC','VERSION 01') C C NONSMOOTHING VERSION C IF(ISWIT.EQ.1) THEN IOFFM=IOFFMS ILAB=ILABS ENDIF IF(JSWIT.EQ.1) THEN IOFFP=IOFFPS SPVAL=SPVAS ENDIF C C C CALL RESET FOR COMPATIBILITY WITH ALL DASH ROUTINES(EXCEPT DASHLINE) C CALL RESET C C GET NUMBER OF BITS IN INTEGER ARITHMETIC C IARTH = I1MACH(8) IXBITS = 0 DO 101 I=1,IARTH IF (M .LE. (2**I-1)) GO TO 102 IXBITS = I+1 101 CONTINUE 102 IYBITS = 0 DO 103 I=1,IARTH IF (N .LE. (2**I-1)) GO TO 104 IYBITS = I+1 103 CONTINUE 104 IF ((IXBITS*IYBITS).GT.0 .AND. (IXBITS+IYBITS).LE.24) GO TO 105 C C REPORT ERROR NUMBER ONE C IWORK = 'CONREC - DIMENSION ERROR - M*N .GT. (2**IARTH) M = + N = ' WRITE (IWORK(56:62),'(I6)') M WRITE (IWORK(73:79),'(I6)') N CERR CALL SETER( IWORK, 1, 1 ) RETURN 105 CONTINUE C C INQUIRE CURRENT TEXT AND LINE COLOR INDEX C CALL GQTXCI ( IERR, ITXCI ) CALL GQPLCI ( IERR, IPLCI ) C C Set requested text color. C CALL GSTXCI(IRECTX) C C SET LINE AND TEXT ASF TO INDIVIDUAL C CALL GQASF ( IERR, LASF ) LSV3 = LASF(3) LSV10 = LASF(10) LASF(3) = 1 LASF(10) = 1 CALL GSASF ( LASF ) C GL = FLO HA = HI GP = FINC MX = L NX = M NY = N IDASH = NDOT NEGPOS = ISIGN(1,IDASH) IDASH = IABS(IDASH) IF (IDASH.EQ.0 .OR. IDASH.EQ.1) IDASH = ISOLID C C SET CONTOUR LEVELS. C CALL CLGEN (Z,MX,NX,NY,GL,HA,GP,NLA,NLM,CL,NCL,ICNST) C C FIND MAJOR AND MINOR LINES C IF (ILAB .NE. 0) CALL REORD (CL,NCL,RWORK,NML,NULBLL+1) IF (ILAB .EQ. 0) NML = 0 C C SAVE CURRENT NORMALIZATION TRANS NUMBER NTORIG AND LOG SCALING FLAG C CALL GQCNTN ( IERR, NTORIG ) CALL GETUSV ('LS',IOLLS) C C SET UP SCALING C CALL GETUSV ( 'YF' , IYVAL ) SCLY = 1.0 / ISHIFT ( 1, 15 - IYVAL ) C IF (NSET) 106,107,111 106 CALL GQNT ( NTORIG,IERR,WNDW,VWPRT ) X1 = VWPRT(1) X2 = VWPRT(2) Y1 = VWPRT(3) Y2 = VWPRT(4) C C SAVE NORMALIZATION TRANS 1 C CALL GQNT (1,IERR,WNDW,VWPRT) C C DEFINE NORMALIZATION TRANS AND LOG SCALING C CALL SET(X1, X2, Y1, Y2, 1.0, FLOAT(NX), 1.0, FLOAT(NY), 1) GO TO 111 107 CONTINUE X1 = XLT X2 = XLT+SIDE Y1 = YBT Y2 = YBT+SIDE X3 = NX Y3 = NY IF (AMIN1(X3,Y3)/AMAX1(X3,Y3) .LT. EXT) GO TO 110 IF (NX-NY) 108,110,109 108 X2 = SIDE*X3/Y3+XLT GO TO 110 109 Y2 = SIDE*Y3/X3+YBT C C SAVE NORMALIZATION TRANS 1 C 110 CALL GQNT ( 1, IERR, WNDW, VWPRT ) C C DEFINE NORMALIZATION TRANS 1 AND LOG SCALING C CALL SET(X1,X2,Y1,Y2,1.0,X3,1.0,Y3,1) C C DRAW PERIMETER C CALL PERIM (NX-1,1,NY-1,1) 111 IF (ICNST .NE. 0) GO TO 124 C C SET UP LABEL SCALING C IOFFDT = IOFFD IF (GL.NE.0.0 .AND. (ABS(GL).LT.0.1 .OR. ABS(GL).GE.1.E5)) 1 IOFFDT = 1 IF (HA.NE.0.0 .AND. (ABS(HA).LT.0.1 .OR. ABS(HA).GE.1.E5)) 1 IOFFDT = 1 ASH = 10.**(3-IFIX(ALOG10(AMAX1(ABS(GL),ABS(HA),ABS(GP))) 1 -4999.999)-5000) IF (IOFFDT .EQ. 0) ASH = 1. IF (IOFFM .NE. 0) GO TO 115 IWORK ='CONTOUR FROM TO CONTOUR INTERVAL 1 OF PT(3,3)= LABELS SCALED BY' HOLD(1) = GL HOLD(2) = HA HOLD(3) = GP HOLD(4) = Z(3,3) HOLD(5) = ASH NCHAR = 0 DO 114 I=1,5 WRITE ( ENCSCR, '(G13.5)' ) HOLD(I) NCHAR = NCHAR+LNGTHS(I) DO 113 J=1,13 NCHAR = NCHAR+1 IWORK(NCHAR:NCHAR) = ENCSCR(J:J) 113 CONTINUE 114 CONTINUE IF (ASH .EQ. 1.) NCHAR = NCHAR-13-LNGTHS(5) C C WRITE TITLE USING NORMALIZATION TRANS NUMBER 0 C CALL GETUSV('LS',LSO) CALL SETUSV('LS',1) CALL GSELNT (0) CALL WTSTR ( 0.5, 0.015625, IWORK(1:NCHAR), 0, 0, 0 ) CALL SETUSV('LS',LSO) CALL GSELNT (1) C C C C * * * * * * * * * * C * * * * * * * * * * C C C PROCESS EACH LEVEL C 115 FPART = .5 C DO 123 I=1,NCL CALL PLOTIT(0,0,0) CALL GSPLCI ( IRECMJ ) CONTR = CL(I) NDASH = IDASH IF (NEGPOS.LT.0 .AND. CONTR.GE.0.) NDASH = ISOLID C C CHANGE 10 BIT PATTERN TO 10 CHARACTER PATTERN. C DO 116 J=1,10 IBIT = IAND(ISHIFT(NDASH,(J-10)),1) RCHAR = IGAP IF (IBIT .NE. 0) RCHAR = ISOL IWORK(J:J) = RCHAR 116 CONTINUE IF (I .GT. NML) GO TO 121 C C SET UP MAJOR LINE (LABELED) C C C NREP REPITITIONS OF PATTERN PER LABEL. C NCHAR = 10 IF (NREP .LT. 2) GO TO 119 DO 118 J=1,10 NCHAR = J RCHAR = IWORK(J:J) DO 117 K=2,NREP NCHAR = NCHAR+10 IWORK(NCHAR:NCHAR) = RCHAR 117 CONTINUE 118 CONTINUE 119 CONTINUE C C PUT IN LABEL. C CALL ENCD (CONTR,ASH,ENCSCR,NCUSED,IOFFDT) DO 120 J=1,NCUSED NCHAR = NCHAR+1 IWORK(NCHAR:NCHAR) = ENCSCR(J:J) 120 CONTINUE GO TO 122 C C SET UP MINOR LINE (UNLABELED). C 121 CONTINUE C C SET LINE INTENSITY TO LOW C CALL GSPLCI ( IRECMN ) NCHAR = 10 122 CALL DASHDC ( IWORK(1:NCHAR),NCRT, ISIZEL ) C C DRAW ALL LINES AT THIS LEVEL. C CALL STLINE (Z,MX,NX,NY,CONTR) C 123 CONTINUE CALL GSPLCI(IRECMJ) C C FIND RELATIVE MINIMUMS AND MAXIMUMS IF WANTED, AND MARK VALUES IF C WANTED. C IF (NHI .EQ. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEM,ASH,IOFFDT) IF (NHI .GT. 0) CALL MINMAX (Z,MX,NX,NY,ISIZEP,-ASH,IOFFDT) FPART = 1. GO TO 127 124 CONTINUE IWORK = 'CONSTANT FIELD' WRITE( ENCSCR, '(G22.14)' ) GL DO 126 I=1,22 IWORK(I+14:I+14) = ENCSCR(I:I) 126 CONTINUE C C WRITE TITLE USING NORMALIZATION TRNS 0 C CALL GETUSV('LS',LSO) CALL SETUSV('LS',1) CALL GSELNT (0) CALL WTSTR ( 0.09765, 0.48825, IWORK(1:36), 3, 0, -1 ) C C RESTORE NORMALIZATION TRANS 1, LINE AND TEXT INTENSITY TO ORIGINAL C 127 IF (NSET.LE.0) THEN CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4), - WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS) END IF CALL GSPLCI ( IPLCI ) CALL GSTXCI ( ITXCI ) C C SELECT ORIGINAL NORMALIZATION TRANS NUMBER NTORIG, AND RESTORE ASF C CALL GSELNT ( NTORIG ) LASF(3) = LSV3 LASF(10) = LSV10 CALL GSASF ( LASF ) C RETURN C C END SUBROUTINE CLGEN (Z,MX,NX,NNY,CCLO,CHI,CINC,NLA,NLM,CL,NCL,ICNST) SAVE DIMENSION CL(NLM) ,Z(MX,NNY) COMMON /CONRE1/ SPVAL ,IOFFP C C CLGEN PUTS THE VALUES OF THE CONTOUR LEVELS IN CL. C VARIABLE NAMES MATCH THOSE IN CONREC, WITH THE FOLLOWING ADDITIONS. C NCL -NUMBER OF CONTOUR LEVELS PUT IN CL. C ICNST -FLAG TO TELL CONREC IF A CONSTANT FIELD WAS DETECTED. C .ICNST=0 MEANS NON-CONSTANT FIELD. C .ICNST NON-ZERO MEANS CONSTANT FIELD. C C TO PRODUCE NON-UNIFORM CONTOUR LEVEL SPACING, REPLACE THE CODE IN THIS C SUBROUTINE WITH CODE TO PRODUCE WHATEVER SPACING IS DESIRED. C ICNST = 0 NY = NNY CLO = CCLO GLO = CLO HA = CHI FANC = CINC CRAT = NLA IF (HA-GLO) 101,102,111 101 GLO = HA HA = CLO GO TO 111 102 IF (GLO .NE. 0.) GO TO 120 GLO = Z(1,1) HA = Z(1,1) IF (IOFFP .EQ. 0) GO TO 107 DO 106 J=1,NY DO 105 I=1,NX IF (Z(I,J) .EQ. SPVAL) GO TO 105 GLO = Z(I,J) HA = Z(I,J) DO 104 JJ=J,NY DO 103 II=1,NX IF (Z(II,JJ) .EQ. SPVAL) GO TO 103 GLO = AMIN1(Z(II,JJ),GLO) HA = AMAX1(Z(II,JJ),HA) 103 CONTINUE 104 CONTINUE GO TO 110 105 CONTINUE 106 CONTINUE GO TO 110 107 DO 109 J=1,NY DO 108 I=1,NX GLO = AMIN1(Z(I,J),GLO) HA = AMAX1(Z(I,J),HA) 108 CONTINUE 109 CONTINUE 110 IF (GLO .GE. HA) GO TO 119 111 IF (FANC) 112,113,114 112 CRAT = AMAX1(1.,-FANC) 113 FANC = (HA-GLO)/CRAT P = 10.**(IFIX(ALOG10(FANC)+5000.)-5000) FANC = AINT(FANC/P)*P 114 IF (CHI-CLO) 116,115,116 115 GLO = AINT(GLO/FANC)*FANC HA = AINT(HA/FANC)*FANC*(1.+SIGN(1.E-6,HA)) 116 DO 117 K=1,NLM CC = GLO+FLOAT(K-1)*FANC IF (CC .GT. HA) GO TO 118 KK = K CL(K) = CC 117 CONTINUE 118 NCL = KK CCLO = CL(1) CHI = CL(NCL) CINC = FANC RETURN 119 ICNST = 1 NCL = 1 CCLO = GLO RETURN 120 CL(1) = GLO NCL = 1 RETURN END SUBROUTINE DRLINE (Z,L,MM,NN) SAVE DIMENSION Z(L,NN) C C THIS ROUTINE TRACES A CONTOUR LINE WHEN GIVEN THE BEGINNING BY STLINE. C TRANSFORMATIONS CAN BE ADDED BY DELETING THE STATEMENT FUNCTIONS FOR C FX AND FY IN DRLINE AND MINMAX AND ADDING EXTERNAL FUNCTIONS. C X=1. AT Z(1,J), X=FLOAT(M) AT Z(M,J). X TAKES ON NON-INTEGER VALUES. C Y=1. AT Z(I,1), Y=FLOAT(N) AT Z(I,N). Y TAKES ON NON-INTEGER VALUES. C COMMON /CONRE2/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE1/ SPVAL ,IOFFP COMMON /CONRE3/ IXBITS ,IYBITS LOGICAL IPEN ,IPENO C COMMON/TOPOG/ CTP(2000),HTP(2000),Z0,ITOP C FX(X,Y)=(DXMN+DXD*(X-1.)/(FLOAT(MM)-1.)) C * *COS(THMN+THD*(Y-1.)/(FLOAT(NN)-1.)) C FY(X,Y)=(DXMN+DXD*(X-1.)/(FLOAT(MM)-1.)) C * *SIN(THMN+THD*(Y-1.)/(FLOAT(NN)-1.)) FX(X,Y)=X C FY(X,Y)=Y COLD C FY(X,Y)=Y+ITOP*((CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))- C 1CTP(IFIX(X+1.))))*(Z0-Y)) FY(X,Y)=(1-ITOP)*Y + ITOP*(Y*( HTP(IFIX(X)) 1 +(IFIX(X)-X)*(HTP(IFIX(X))-HTP(IFIX(X+1.)))) 1+(CTP(IFIX(X))+(IFIX(X)-X)*(CTP(IFIX(X))-CTP(IFIX(X+1.))))*(Z0-Y)) IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY C(P1,P2) = (P1-CV)/(P1-P2) C DATA IPEN,IPENO/.TRUE.,.TRUE./ C M = MM N = NN IF (IOFFP .EQ. 0) GO TO 101 ASSIGN 110 TO JUMP1 ASSIGN 115 TO JUMP2 GO TO 102 101 ASSIGN 112 TO JUMP1 ASSIGN 117 TO JUMP2 102 IX0 = IX IY0 = IY IS0 = IS IF (IOFFP .EQ. 0) GO TO 103 IX2 = IX+INX(IS) IY2 = IY+INY(IS) IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL IPENO = IPEN 103 IF (IDX .EQ. 0) GO TO 104 Y = IY ISUB = IX+IDX X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) GO TO 105 104 X = IX ISUB = IY+IDY Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) 105 CALL FRSTD (FX(X,Y),FY(X,Y)) 106 IS = IS+1 IF (IS .GT. 8) IS = IS-8 IDX = INX(IS) IDY = INY(IS) IX2 = IX+IDX IY2 = IY+IDY IF (ISS .NE. 0) GO TO 107 IF (IX2.GT.M .OR. IY2.GT.N .OR. IX2.LT.1 .OR. IY2.LT.1) GO TO 120 107 IF (CV-Z(IX2,IY2)) 108,108,109 108 IS = IS+4 IX = IX2 IY = IY2 GO TO 106 109 IF (IS/2*2 .EQ. IS) GO TO 106 GO TO JUMP1,(110,112) 110 ISBIG = IS+(8-IS)/6*8 IX3 = IX+INX(ISBIG-1) IY3 = IY+INY(ISBIG-1) IX4 = IX+INX(ISBIG-2) IY4 = IY+INY(ISBIG-2) IPENO = IPEN IF (ISS .NE. 0) GO TO 111 IF (IX3.GT.M .OR. IY3.GT.N .OR. IX3.LT.1 .OR. IY3.LT.1) GO TO 120 IF (IX4.GT.M .OR. IY4.GT.N .OR. IX4.LT.1 .OR. IY4.LT.1) GO TO 120 111 IPEN = Z(IX,IY).NE.SPVAL .AND. Z(IX2,IY2).NE.SPVAL .AND. 1 Z(IX3,IY3).NE.SPVAL .AND. Z(IX4,IY4).NE.SPVAL 112 IF (IDX .EQ. 0) GO TO 113 Y = IY ISUB = IX+IDX X = C(Z(IX,IY),Z(ISUB,IY))*FLOAT(IDX)+FLOAT(IX) GO TO 114 113 X = IX ISUB = IY+IDY Y = C(Z(IX,IY),Z(IX,ISUB))*FLOAT(IDY)+FLOAT(IY) 114 GO TO JUMP2,(115,117) 115 IF (.NOT.IPEN) GO TO 118 IF (IPENO) GO TO 116 C C END OF LINE SEGMENT C CALL LASTD CALL FRSTD (FX(XOLD,YOLD),FY(XOLD,YOLD)) C C CONTINUE LINE SEGMENT C 116 CONTINUE 117 CALL VECTD (FX(X,Y),FY(X,Y)) 118 XOLD = X YOLD = Y IF (IS .NE. 1) GO TO 119 NP = NP+1 IF (NP .GT. NR) GO TO 120 IR(NP) = IXYPAK(IX,IY) 119 IF (ISS .EQ. 0) GO TO 106 IF (IX.NE.IX0 .OR. IY.NE.IY0 .OR. IS.NE.IS0) GO TO 106 C C END OF LINE C 120 CALL LASTD RETURN END SUBROUTINE MINMAX (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) C C THIS ROUTINE FINDS RELATIVE MINIMUMS AND MAXIMUMS. A RELATIVE MINIMUM C (OR MAXIMUM) IS DEFINED TO BE THE LOWEST (OR HIGHEST) POINT WITHIN C A CERTAIN NEIGHBORHOOD OF THE POINT. THE NEIGHBORHOOD USED HERE C IS + OR - MN IN THE X DIRECTION AND + OR - NM IN THE Y DIRECTION. C C ORIGINATOR DAVID KENNISON C SAVE CHARACTER*7 IA DIMENSION Z(L,NN) C C C COMMON /CONRE1/ SPVAL, IOFFP COMMON /CONRE5/ SCLY C FX(X,Y) = X FY(X,Y) = Y C M = MM N = NN C C SET UP SCALING FOR LABELS C SIZEM = (ISSIZM + 1)*256*SCLY ISIZEM = ISSIZM C ASH = ABS(AASH) IOFFDT = JOFFDT C IF (AASH .LT. 0.0) GO TO 128 C MN = MIN0(15,MAX0(2,IFIX(FLOAT(M)/8.))) NM = MIN0(15,MAX0(2,IFIX(FLOAT(N)/8.))) NM1 = N-1 MM1 = M-1 C C LINE LOOP FOLLOWS - THE COMPLETE TWO-DIMENSIONAL TEST FOR A MINIMUM OR C MAXIMUM OF THE FIELD IS ONLY PERFORMED FOR POINTS WHICH ARE MINIMA OR C MAXIMA ALONG SOME LINE - FINDING THESE CANDIDATES IS MADE EFFICIENT BY C USING A COUNT OF CONSECUTIVE INCREASES OR DECREASES OF THE FUNCTION C ALONG THE LINE C DO 127 JP=2,NM1 C IM = MN-1 IP = -1 GO TO 126 C C CONTROL RETURNS TO STATEMENT 10 AS LONG AS THE FUNCTION IS INCREASING C ALONG THE LINE - WE SEEK A POSSIBLE MAXIMUM C 101 IP = IP+1 AA = AN IF (IP .EQ. MM1) GO TO 104 AN = Z(IP+1,JP) IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 IF (AA-AN) 102,103,104 102 IM = IM+1 GO TO 101 103 IM = 0 GO TO 101 C C FUNCTION DECREASED - TEST FOR MAXIMUM ON LINE C 104 IF (IM .GE. MN) GO TO 106 IS = MAX0(1,IP-MN) IT = IP-IM-1 IF (IS .GT. IT) GO TO 106 DO 105 II=IS,IT IF (AA .LE. Z(II,JP)) GO TO 112 105 CONTINUE 106 IS = IP+2 IT = MIN0(M,IP+MN) IF (IS .GT. IT) GO TO 109 DO 108 II=IS,IT IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 107 IP = II-1 GO TO 125 107 IF (AA .LE. Z(II,JP)) GO TO 112 108 CONTINUE C C WE HAVE MAXIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MAXIMUM OF FIELD C 109 JS = MAX0(1,JP-NM) JT = MIN0(N,JP+NM) IS = MAX0(1,IP-MN) IT = MIN0(M,IP+MN) DO 111 JK=JS,JT IF (JK .EQ. JP) GO TO 111 DO 110 IK=IS,IT IF (Z(IK,JK).GE.AA .OR. 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 112 110 CONTINUE 111 CONTINUE C X = FLOAT(IP) Y = FLOAT(JP) CALL WTSTR ( FX(X,Y),FY(X,Y),'H',ISIZEM,0,0 ) CALL FL2INT ( FX(X,Y),FY(X,Y),IFX,IFY ) C C SCALE TO USER SET RESOLUTION C IFY = IFY*SCLY CALL ENCD (AA,ASH,IA,NC,IOFFDT) MY = IFY - SIZEM TMY = CPUY ( MY ) CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) 112 IM = 1 IF (IP-MM1) 113,127,127 C C CONTROL RETURNS TO STATEMENT 20 AS LONG AS THE FUNCTION IS DECREASING C ALONG THE LINE - WE SEEK A POSSIBLE MINIMUM C 113 IP = IP+1 AA = AN IF (IP .EQ. MM1) GO TO 116 AN = Z(IP+1,JP) IF (IOFFP.NE.0 .AND. AN.EQ.SPVAL) GO TO 125 IF (AA-AN) 116,115,114 114 IM = IM+1 GO TO 113 115 IM = 0 GO TO 113 C C FUNCTION INCREASED - TEST FOR MINIMUM ON LINE C 116 IF (IM .GE. MN) GO TO 118 IS = MAX0(1,IP-MN) IT = IP-IM-1 IF (IS .GT. IT) GO TO 118 DO 117 II=IS,IT IF (AA .GE. Z(II,JP)) GO TO 124 117 CONTINUE 118 IS = IP+2 IT = MIN0(M,IP+MN) IF (IS .GT. IT) GO TO 121 DO 120 II=IS,IT IF (IOFFP.EQ.0 .OR. Z(II,JP).NE.SPVAL) GO TO 119 IP = II-1 GO TO 125 119 IF (AA .GE. Z(II,JP)) GO TO 124 120 CONTINUE C C WE HAVE MINIMUM ON LINE - DO TWO-DIMENSIONAL TEST FOR MINIMUM OF FIELD C 121 JS = MAX0(1,JP-NM) JT = MIN0(N,JP+NM) IS = MAX0(1,IP-MN) IT = MIN0(M,IP+MN) DO 123 JK=JS,JT IF (JK .EQ. JP) GO TO 123 DO 122 IK=IS,IT IF (Z(IK,JK).LE.AA .OR. 1 (IOFFP.NE.0 .AND. Z(IK,JK).EQ.SPVAL)) GO TO 124 122 CONTINUE 123 CONTINUE C X = FLOAT(IP) Y = FLOAT(JP) CALL WTSTR ( FX(X,Y),FY(X,Y),'L',ISIZEM,0,0 ) CALL FL2INT( FX(X,Y),FY(X,Y),IFX,IFY ) IFY = SCLY*IFY CALL ENCD (AA,ASH,IA,NC,IOFFDT) MY = IFY - SIZEM TMY = CPUY ( MY ) CALL WTSTR ( FX(X,Y),TMY,IA(1:NC),ISIZEM,0,0 ) 124 IM = 1 IF (IP-MM1) 101,127,127 C C SKIP SPECIAL VALUES ON LINE C 125 IM = 0 126 IP = IP+1 IF (IP .GE. MM1) GO TO 127 IF (IOFFP.NE.0 .AND. Z(IP+1,JP).EQ.SPVAL) GO TO 125 IM = IM+1 IF (IM .LE. MN) GO TO 126 IM = 1 AN = Z(IP+1,JP) IF (Z(IP,JP)-AN) 101,103,113 C 127 CONTINUE C RETURN C C ****************************** ENTRY PNTVAL ************************** C ENTRY PNTVAL (Z,L,MM,NN,ISSIZM,AASH,JOFFDT) C 128 CONTINUE II = (M-1+24)/24 JJ = (N-1+48)/48 NIQ = 1 NJQ = 1 DO 130 J=NJQ,N,JJ Y = J DO 129 I=NIQ,M,II X = I ZZ = Z(I,J) IF (IOFFP.NE.0 .AND. ZZ.EQ.SPVAL) GO TO 129 CALL ENCD (ZZ,ASH,IA,NC,IOFFDT) CALL WTSTR (FX(X,Y),FY(X,Y),IA(1:NC),ISIZEM,0,0 ) 129 CONTINUE 130 CONTINUE RETURN END SUBROUTINE REORD (CL,NCL,C1,MARK,NMG) SAVE DIMENSION CL(NCL) ,C1(NCL) C C THIS ROUTINE PUTS THE MAJOR (LABELED) LEVELS IN THE BEGINNING OF CL C AND THE MINOR (UNLABELED) LEVELS IN END OF CL. THE NUMBER OF MAJOR C LEVELS IS RETURNED IN MARK. C1 IS USED AS A WORK SPACE. NMG IS THE C NUMBER OF MINOR GAPS (ONE MORE THAN THE NUMBER OF MINOR LEVELS BETWEEN C MAJOR LEVELS). C NL = NCL IF (NL.LE.4 .OR. NMG.LE.1) GO TO 113 NML = NMG-1 IF (NL .LE. 10) NML = 1 C C CHECK FOR ZERO OR OTHER NICE NUMBER FOR A MAJOR LINE C NMLP1 = NML+1 DO 101 I=1,NL ISAVE = I IF (CL(I) .EQ. 0.) GO TO 104 101 CONTINUE L = NL/2 L = ALOG10(ABS(CL(L)))+1. Q = 10.**L DO 103 J=1,3 Q = Q/10. DO 102 I=1,NL ISAVE = I IF (AMOD(ABS(CL(I)+1.E-9*CL(I))/Q,FLOAT(NMLP1)) .LE. .0001) 1 GO TO 104 102 CONTINUE 103 CONTINUE ISAVE = NL/2 C C PUT MAJOR LEVELS IN C1 C 104 ISTART = MOD(ISAVE,NMLP1) IF (ISTART .EQ. 0) ISTART = NMLP1 NMAJL = 0 DO 105 I=ISTART,NL,NMLP1 NMAJL = NMAJL+1 C1(NMAJL) = CL(I) 105 CONTINUE MARK = NMAJL L = NMAJL C C PUT MINOR LEVELS IN C1 C IF (ISTART .EQ. 1) GO TO 107 DO 106 I=2,ISTART ISUB = L+I-1 C1(ISUB) = CL(I-1) 106 CONTINUE 107 L = NMAJL+ISTART-1 DO 109 I=2,NMAJL DO 108 J=1,NML L = L+1 ISUB = ISTART+(I-2)*NMLP1+J C1(L) = CL(ISUB) 108 CONTINUE 109 CONTINUE NLML = NL-L IF (L .EQ. NL) GO TO 111 DO 110 I=1,NLML L = L+1 C1(L) = CL(L) 110 CONTINUE C C PUT REORDERED ARRAY BACK IN ORIGINAL PLACE C 111 DO 112 I=1,NL CL(I) = C1(I) 112 CONTINUE RETURN 113 MARK = NL RETURN END SUBROUTINE STLINE (Z,LL,MM,NN,CONV) SAVE DIMENSION Z(LL,NN) C C THIS ROUTINE FINDS THE BEGINNINGS OF ALL CONTOUR LINES AT LEVEL CONV. C FIRST THE EDGES ARE SEARCHED FOR LINES INTERSECTING THE EDGE (OPEN C LINES) THEN THE INTERIOR IS SEARCHED FOR LINES WHICH DO NOT INTERSECT C THE EDGE (CLOSED LINES). BEGINNINGS ARE STORED IN IR TO PREVENT RE- C TRACING OF LINES. IF IR IS FILLED, THE SEARCH IS STOPPED FOR THIS C CONV. C COMMON /CONRE2/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE3/ IXBITS ,IYBITS C C C C C C IXYPAK(IXX,IYY) = ISHIFT(IXX,IYBITS)+IYY C L = LL M = MM N = NN CV = CONV NP = 0 ISS = 0 DO 102 IP1=2,M I = IP1-1 IF (Z(I,1).GE.CV .OR. Z(IP1,1).LT.CV) GO TO 101 IX = IP1 IY = 1 IDX = -1 IDY = 0 IS = 1 CALL DRLINE (Z,L,M,N) 101 IF (Z(IP1,N).GE.CV .OR. Z(I,N).LT.CV) GO TO 102 IX = I IY = N IDX = 1 IDY = 0 IS = 5 CALL DRLINE (Z,L,M,N) 102 CONTINUE DO 104 JP1=2,N J = JP1-1 IF (Z(M,J).GE.CV .OR. Z(M,JP1).LT.CV) GO TO 103 IX = M IY = JP1 IDX = 0 IDY = -1 IS = 7 CALL DRLINE (Z,L,M,N) 103 IF (Z(1,JP1).GE.CV .OR. Z(1,J).LT.CV) GO TO 104 IX = 1 IY = J IDX = 0 IDY = 1 IS = 3 CALL DRLINE (Z,L,M,N) 104 CONTINUE ISS = 1 DO 108 JP1=3,N J = JP1-1 DO 107 IP1=2,M I = IP1-1 IF (Z(I,J).GE.CV .OR. Z(IP1,J).LT.CV) GO TO 107 IXY = IXYPAK(IP1,J) IF (NP .EQ. 0) GO TO 106 DO 105 K=1,NP IF (IR(K) .EQ. IXY) GO TO 107 105 CONTINUE 106 NP = NP+1 IF (NP .GT. NR) THEN C C THIS PRINTS AN ERROR MESSAGE IF THE LOCAL ARRAY IR IN SUBROUTINE C STLINE HAS AN OVERFLOW C THIS MESSAGE IS WRITTEN BOTH ON THE FRAME AND ON THE STANDARD ERROR C UNIT C IUNIT = I1MACH(4) WRITE(IUNIT,1000) 1000 FORMAT( 1' WARNING FROM ROUTINE STLINE IN CONREC--WORK ARRAY OVERFLOW') CALL GETSET(VXA,VXB,VYA,VYB,XA,XB,YA,YB,LTYPE) Y = (YB - YA) / 2. X = (XB - XA) / 2. CALL PWRIT(X,Y, 1'**WARNING--PICTURE INCOMPLETE**', 2 31,3,0,0) Y = Y * .7 CALL PWRIT(X,Y, 1'WORK ARRAY OVERFLOW IN STLINE', 2 29,3,0,0) RETURN ENDIF IR(NP) = IXY IX = IP1 IY = J IDX = -1 IDY = 0 IS = 1 CALL DRLINE (Z,L,M,N) 107 CONTINUE 108 CONTINUE RETURN END SUBROUTINE CALCNT (Z,M,N,A1,A2,A3,I1,I2,I3) C C THIS ENTRY POINT IS FOR USERS WHO ARE TOO LAZY TO SWITCH OLD DECKS C TO THE NEW CALLING SEQUENCE. C DIMENSION Z(M,N) SAVE C C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','CALCNT','VERSION 01') C CALL CONREC (Z,M,M,N,A1,A2,A3,I1,I2,-IABS(I3)) RETURN END SUBROUTINE EZCNTR (Z,M,N) C C CONTOURING VIA SHORTEST POSSIBLE ARGUMENT LIST C ASSUMPTIONS -- C ALL OF THE ARRAY IS TO BE CONTOURED, C CONTOUR LEVELS ARE PICKED INTERNALLY, C CONTOURING ROUTINE PICKS SCALE FACTORS, C HIGHS AND LOWS ARE MARKED, C NEGATIVE LINES ARE DRAWN WITH A DASHED LINE PATTERN, C EZCNTR CALLS FRAME AFTER DRAWING THE CONTOUR MAP. C IF THESE ASSUMPTIONS ARE NOT MET, USE CONREC. C C ARGUMENTS C Z ARRAY TO BE CONTOURED C M FIRST DIMENSION OF Z C N SECOND DIMENSION OF Z C SAVE DIMENSION Z(M,N) DATA NSET,NHI,NDASH/0,0,682/ C C 682=1252B C THE FOLLOWING CALL IS FOR GATHERING STATISTICS ON LIBRARY USE AT NCAR C CALL Q8QST4 ('GRAPHX','CONREC','EZCNTR','VERSION 01') C CALL CONREC (Z,M,M,N,0.,0.,0.,NSET,NHI,-NDASH) CALL FRAME RETURN END BLOCKDATA CONBD COMMON /CONRE1/ SPVAL ,IOFFP COMMON /CONRE2/ CV ,IX ,IY ,IDX , 1 IS ,ISS ,NP ,IDY , 2 INX(8) ,INY(8) ,IR(2000) ,NR COMMON /CONRE4/ ISIZEL ,ISIZEM ,ISIZEP ,NREP , 1 NCRT ,ILAB ,NULBLL ,IOFFD , 2 EXT ,IOFFM ,ISOLID ,NLA , 3 NLM ,XLT ,YBT ,SIDE COMMON /RECINT/ IRECMJ ,IRECMN ,IRECTX DATA IOFFP,SPVAL/0,0.0/ DATA ISIZEL,ISIZEM,ISIZEP,NLA,NLM,XLT,YBT,SIDE,ISOLID,NREP,NCRT/ 1 1, 2, 0, 16, 80,.05,.05, .9, 1023, 6, 4 / DATA EXT,IOFFD,NULBLL,IOFFM,ILAB/.25,0,3,0,0/ DATA INX(1),INX(2),INX(3),INX(4),INX(5),INX(6),INX(7),INX(8)/ 1 -1 , -1 , 0 , 1 , 1 , 1 , 0 , -1 / DATA INY(1),INY(2),INY(3),INY(4),INY(5),INY(6),INY(7),INY(8)/ 1 0 , 1 , 1 , 1 , 0 , -1 , -1 , -1 / DATA NR/2000/ DATA IRECMJ,IRECMN,IRECTX/ 1 , 1 , 1/ C C REVISION HISTORY--- C C JANUARY 1980 ADDED REVISION HISTORY AND CHANGED LIBRARY NAME C FROM CRAYLIB TO PORTLIB FOR MOVE TO PORTLIB C C MAY 1980 ARRAYS IWORK AND ENCSCR, PREVIOUSLY TOO SHORT FOR C SHORT-WORD-LENGTH MACHINES, LENGTHENED. SOME C DOCUMENTATION CLARIFIED AND CORRECTED. C C JUNE 1984 CONVERTED TO FORTRAN 77 AND TO GKS C C JUNE 1985 ERROR HANDLING LINES ADDED; IF OVERFLOW HAPPENS TO C WORK ARRAY IN STLINE, A WARNING MESSAGE IS WRITTEN C BOTH ON PLOT FRAME AND ON STANDARD ERROR MESSAGE. C------------------------------------------------------------------- C END