Initial commit

1 files changed, 454 insertions, 0 deletions

diff --git a/sys/gio/ncarutil/conlib/congen.f b/sys/gio/ncarutil/conlib/congen.f
new file mode 100644
index 00000000..c70cfe05
--- /dev/null
+++ b/sys/gio/ncarutil/conlib/congen.f
@@ -0,0 +1,454 @@
+      SUBROUTINE CONGEN (XI,YI,IPACK,SCRARR,ICA)
+C                                                                               
+C +-----------------------------------------------------------------+           
+C |                                                                 |           
+C |                Copyright (C) 1986 by UCAR                       |           
+C |        University Corporation for Atmospheric Research          |           
+C |                    All Rights Reserved                          |           
+C |                                                                 |           
+C |                 NCARGRAPHICS  Version 1.00                      |           
+C |                                                                 |           
+C +-----------------------------------------------------------------+           
+C                                                                               
+C                                                                               
+C
+C  DRAW A CONTOUR AT THE CURRENT LEVEL
+C
+C  INPUT
+C       XI YI LOWER RIGHT CORNER OF CELL
+C       IPACK-FLAG TO ALLOW REDUCTION OF COORDINATE PAIR STORAGE
+C             IF REQUIRED
+C       SCRARR-SCRATCH ARRAY OF CONTOUR VALUES
+C       ICA-ENTERING CASE CONDITIONS IF ANY REQUIRED
+C
+C
+C
+C
+      COMMON /CONRA1/ CL(30)     ,NCL        ,OLDZ       ,PV(210)    ,
+     1                FINC       ,HI         ,FLO
+      COMMON /CONRA2/ REPEAT     ,EXTRAP     ,PER        ,MESS       ,
+     1                ISCALE     ,LOOK       ,PLDVLS     ,GRD        ,
+     2                CINC       ,CHILO      ,CON        ,LABON      ,
+     3                PMIMX      ,SCALE      ,FRADV      ,EXTRI      ,
+     4                BPSIZ      ,LISTOP
+      COMMON /CONRA3/ IREC
+      COMMON /CONRA4/ NCP        ,NCPSZ
+      COMMON /CONRA5/ NIT        ,ITIPV
+      COMMON /CONRA6/ XST        ,YST        ,XED        ,YED        ,
+     1                STPSZ      ,IGRAD      ,IG         ,XRG        ,
+     2                YRG        ,BORD       ,PXST       ,PYST       ,
+     3                PXED       ,PYED       ,ITICK
+      COMMON /CONRA7/ TITLE      ,ICNT   ,ITLSIZ
+      COMMON /CONRA8/ IHIGH      ,INMAJ      ,INLAB      ,INDAT      ,
+     1              LEN      ,IFMT       ,LEND       ,
+     2                IFMTD      ,ISIZEP     ,INMIN
+      COMMON /CONRA9/ ICOORD(500),NP         ,MXXY       ,TR         ,
+     1                BR         ,TL         ,BL         ,CONV       ,
+     2                XN         ,YN         ,ITLL       ,IBLL       ,
+     3                ITRL       ,IBRL       ,XC         ,YC         ,
+     4                ITLOC(210) ,JX         ,JY         ,ILOC       ,
+     5                ISHFCT     ,XO         ,YO         ,IOC        ,NC
+      COMMON /CONR10/ NT         ,NL         ,NTNL       ,JWIPT      ,
+     1                JWIWL      ,JWIWP      ,JWIPL      ,IPR        ,
+     2                ITPV
+      COMMON /CONR11/ NREP       ,NCRT       ,ISIZEL     ,
+     1                MINGAP     ,ISIZEM         ,
+     2                TENS
+      COMMON /CONR12/ IXMAX      ,IYMAX      ,XMAX       ,YMAX
+      LOGICAL         REPEAT     ,EXTRAP     ,PER        ,MESS       ,
+     1                LOOK       ,PLDVLS     ,GRD        ,LABON      ,
+     2                PMIMX      ,FRADV      ,EXTRI      ,CINC       ,
+     3                TITLE      ,LISTOP     ,CHILO      ,CON
+      COMMON /CONR15/ ISTRNG
+        CHARACTER*64 ISTRNG
+        COMMON /CONR16/ FORM
+        CHARACTER*10 FORM
+        COMMON /CONR17/ NDASH, IDASH, EDASH
+        CHARACTER*10 NDASH, IDASH, EDASH
+C
+C
+C
+      DIMENSION       SCRARR(1)  ,IXMOV(2)   ,IYMOV(2)
+        CHARACTER*64    IHOLD
+        CHARACTER*23    IVOUT
+      INTEGER         GOOP
+C
+        SAVE
+        DATA NOOP,GOOP/1,0/
+C
+C  STATEMENT FUNCTIONS FOR MAPPING GRAPHICS OUTPUT
+C
+      FX(XXX,YYY) = XXX
+      FY(XXX,YYY) = YYY
+C
+C  STATEMENT FUNCTION TO MAKE ARRAY ACCESS SEEM LIKE MATRIX ACCESS
+C
+      SCRTCH(IXX,IYY) = SCRARR(IYY+(IXX-1)*IYMAX)
+C
+C  DRAW AN ENTIRE CONTOUR LINE WHEN A POTENTIAL START POINT IS
+C  PROVIDED
+C
+C  SAVE STARTING CELL
+C
+      XCS = XI
+      YCS = YI
+C
+C  TEST IF VALID START POINT
+C
+      ICASE = ICA
+      XC = XI
+      YC = YI
+      CALL CONCLD (ICASE,NOOP)
+C
+C  IF NO CONTOUR RETURN
+C
+      IF (ICASE.EQ.-1) RETURN
+      IF (ICASE.EQ.0) RETURN
+C
+C  IF CONTOUR ALREADY DRAWN RETURN
+C
+      ILOC = IOR(ISHIFT(JX,ISHFCT),JY)
+      IF (NP.EQ.0) GO TO    20
+C
+C TEST IF CONTOUR FOUND
+C
+          DO    10 I=1,NP
+          IF (ILOC.NE.ICOORD(I)) GO TO    10
+          RETURN
+   10     CONTINUE
+C
+C  GET CORRECT OLD CASE
+C
+   20 IC = IOC
+      IF (ICASE.EQ.IOC) IC = NC
+C
+C  SET UP STRUCTURE TO START IN OTHER DIRECTION FROM HERE IF CONTOUR
+C  UNEXPECTLY ENDS IN THIS DIRECTION
+C
+      IFCASE = IC
+      IFOCSE = ICASE
+      FXO = XO
+      FYO = YO
+      LOOP = 1
+C
+C  SET UP IC TO SIMULATE EXIT FROM A PREVIOUS CELL
+C
+      IC = MOD(IC+2,4)
+C
+C  IF EXTRAPOLATING PASS ON
+C
+      IF (EXTRAP) GO TO    60
+C
+C  TEST IF CONTOUR EXCEEDED BORDER LIMITS
+C  NOTE THAT ICASER CANNOT EQUAL 3 AT THIS POINT
+C
+      GO TO (   30,   40,   30,   50),ICASE
+C
+C  EXIT FROM BOTTOM
+C
+   30 IF (JX.GE.IXMAX) RETURN
+      GO TO    60
+C
+C  EXIT FROM LEFT
+C
+   40 IF (JY.LE.ITLOC(JX*2 - 1)) RETURN
+      GO TO    60
+C
+C  EXIT FROM RIGHT
+C
+   50 IF (JY.GE.ITLOC(JX*2 - 1)) RETURN
+C
+C  SAVE CELL INFO IF COMMING BACK
+C
+   60 TRT = TR
+      BRT = BR
+      TLT = TL
+      BLT = BL
+      IX = JX
+      IY = JY
+C
+C  VALID CONTOUR START FOUND
+C
+      XX = FX(XO,YO)
+      CALL FRSTD (XX,FY(XO,YO))
+C
+C  DRAW CONTOUR IN THIS CELL
+C
+   70 XX = FX(XN,YN)
+      CALL VECTD (XX,FY(XN,YN))
+      XCSTOR = XC
+      YCSTOR = YC
+      IXSTOR = IX
+      IYSTOR = IY
+      IOLDC = IC
+      IC = ICASE
+C
+C  ENTER COORDINATE PAIR OF CONTOUR IN LIST
+C
+      NP = NP+1
+      IF (NP.GT.MXXY) GO TO   180
+      ICOORD(NP) = ILOC
+C
+C  BRANCH TO APPROPIATE CODE DEPENDING ON CONTOUR EXIT FROM THE CELL
+C
+   80 GO TO (   90,  110,  130,  150),IC
+C
+C  EXIT FORM BOTTOM
+C  END CONTOUR IF ON CONVEX HULL
+C
+   90 IF (EXTRAP) GO TO   100
+      IF (IY.LT.ITLOC(IX*2 - 1) .OR. IY-1.GT.ITLOC(IX*2)) GO TO   360
+  100 TR = BR
+      TL = BL
+      XC = XC+STPSZ
+C
+C  IF ON BORDER END CONTOUR
+C
+      IX = IX+1
+      IF (IX.GT.IXMAX) GO TO   360
+      BR = SCRTCH(IX,IY)
+      BL = SCRTCH(IX,IY-1)
+      ILOC = IOR(ISHIFT(IX,ISHFCT),IY)
+C
+C  BRANCH IF CONTOUR CLOSED
+C
+      IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO   170
+      CALL CONCLD (ICASE,GOOP)
+      IF (ICASE.EQ.-1) GO TO 360
+      IF (ICASE.NE.0) GO TO    70
+      GO TO   230
+C
+C  EXIT FROM LEFT SIDE
+C  TEST IF IN CONVEX HULL
+C
+  110 IF (EXTRAP) GO TO   120
+      IF (IY-1.LT.ITLOC( (IX-1)*2 - 1 ) .AND. IY-1.LT.ITLOC(IX*2 - 1))
+     1    GO TO   360
+  120 TR = TL
+      BR = BL
+      YC = YC-STPSZ
+C
+C  IF ON BORDER END CONTOUR
+C
+      IY = IY-1
+      IF (IY.LT.2) GO TO   360
+      TL = SCRTCH(IX-1,IY-1)
+      BL = SCRTCH(IX,IY-1)
+C
+C  BRANCH IF CONTOUR CLOSED
+C
+      IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO   170
+      ILOC = IOR(ISHIFT(IX,ISHFCT),IY)
+      CALL CONCLD (ICASE,GOOP)
+      IF (ICASE.EQ.-1) GO TO 360
+      IF (ICASE.NE.0) GO TO    70
+      GO TO   230
+C
+C  EXIT FROM TOP
+C  END CONTOUR IF OUT OF CONVEX HULL
+C
+  130 IF (EXTRAP) GO TO   140
+      IF (IY.LT.ITLOC( (IX-1)*2 - 1 ) .OR. IY-1.GT.ITLOC( (IX-1)*2 ))
+     1    GO TO   360
+  140 BR = TR
+      BL = TL
+      XC = XC-STPSZ
+C
+C  END CONTOUR IF OUTSIDE OF BORDER
+C
+      IX = IX-1
+      IF (IX.LT.2) GO TO   360
+      TR = SCRTCH(IX-1,IY)
+      TL = SCRTCH(IX-1,IY-1)
+      ILOC = IOR(ISHIFT(IX,ISHFCT),IY)
+C
+C  BRANCH IF CONTOUR CLOSED
+C
+      IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO   170
+      CALL CONCLD (ICASE,GOOP)
+      IF (ICASE.EQ.-1) GO TO 360
+      IF (ICASE.NE.0) GO TO    70
+      GO TO   230
+C
+C  EXIT FROM RIGHT SIDE
+C  TEST IF ON CONVEX HULL
+C
+  150 IF (EXTRAP) GO TO   160
+      IF (IY.GT.ITLOC( (IX-1)*2 ) .AND. IY.GT.ITLOC(IX*2)) GO TO   360
+  160 TL = TR
+      BL = BR
+      YC = YC+STPSZ
+C
+C  IF ON BORDER END CONTOUR
+C
+      IY = IY+1
+      IF (IY.GT.IYMAX) GO TO   360
+      TR = SCRTCH(IX-1,IY)
+      BR = SCRTCH(IX,IY)
+      ILOC = IOR(ISHIFT(IX,ISHFCT),IY)
+C
+C  BRANCH IF CONTOUR CLOSED
+C
+      IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO   170
+      CALL CONCLD (ICASE,GOOP)
+      IF (ICASE.EQ.-1) GO TO 360
+      IF (ICASE.NE.0) GO TO    70
+      GO TO   230
+C
+C  END THE CONTOUR
+C
+  170 CALL LASTD
+      TR = TRT
+      BR = BRT
+      TL = TLT
+      BL = BLT
+      RETURN
+C
+C  CONTOUR STORAGE EXCEEDED TRY PACKING
+C
+  180 IF (IPACK.EQ.0) GO TO   200
+      NP = 0
+      ITEST = IOR(ISHIFT(JX,ISHFCT),JY)
+          DO   190 K=1,MXXY
+          IF (ICOORD(K).LE.ITEST) GO TO   190
+          NP = NP+1
+          ICOORD(NP) = ICOORD(K)
+  190     CONTINUE
+      IF (NP.LT.MXXY) GO TO    80
+C
+C  FAILURE NO MORE SPACE ABORT THIS CONTOUR LEVEL
+C
+  200 IHOLD(1:39) = ' CONDRW-CONTOUR STORAGE EXAUSTED LEVEL='
+C
+C  BLANK FILL THE ENCODE ARRAY
+C
+        IVOUT = '                       '
+C +NOAO - FTN internal write rewritten as encode for IRAF.
+C
+C     WRITE(IVOUT,'(G13.5)')CONV
+      call encode (13, '(g13.5)', ivout, conv)
+C
+C -NOAO
+        IHOLD(40:62) = IVOUT
+      CALL SETER (IHOLD,10,IREC)
+      RETURN
+C
+C  BAD TIME THE CONTOUR EXITED A CORNER OF THE CELL MUST SEARCH FOR
+C  NEW CELL
+C
+  230 IXSTP = IXSTOR
+      IYSTP = IYSTOR
+      GO TO (  240,  250,  260,  270),IOLDC
+C
+C PREVIOUS CELL BOTTOM EXIT
+C
+  240 IXSTP = IXSTP-1
+      GO TO   280
+C
+C  PREVIOUS CELL LEFT EXIT
+C
+  250 IYSTP = IYSTP+1
+      GO TO   280
+C
+C  PREVIOUS CELL TOP EXIT
+C
+  260 IXSTP = IXSTP+1
+      GO TO   280
+C
+C  PREVIOUS CELL RIGHT EXIT
+C
+  270 IYSTP = IYSTP-1
+C
+C  BRANCH TO CURRENT CELL CASE
+C
+  280 GO TO (  290,  300,  310,  320),IC
+C
+C  APPARENT BOTTOM EXIT
+C
+  290 IXMOV(1) = 0
+      IXMOV(2) = 1
+      IYMOV(1) = -1
+      IYMOV(2) = 1
+      GO TO   330
+C
+C  APPARENT LEFT EXIT
+C
+  300 IXMOV(1) = 1
+      IXMOV(2) = -1
+      IYMOV(1) = 0
+      IYMOV(2) = -1
+      GO TO   330
+C
+C  APPARENT TOP EXIT
+C
+  310 IXMOV(1) = 0
+      IXMOV(2) = -1
+      IYMOV(1) = -1
+      IYMOV(2) = 1
+      GO TO   330
+C
+C  APPARENT RIGHT EXIT
+C
+  320 IXMOV(1) = 1
+      IXMOV(2) = -1
+      IYMOV(1) = 0
+      IYMOV(2) = 1
+C
+C  SEARCH THE POSSIBLE CELLS
+C
+  330     DO   350 K=1,2
+              DO   340 L=1,2
+              XC = XCSTOR + STPSZ*FLOAT( IXMOV(K) )
+              YC = YCSTOR + STPSZ*FLOAT( IYMOV(L) )
+              IX = IXSTOR+IXMOV(K)
+              IY = IYSTOR+IYMOV(L)
+              ILOC = IOR(ISHIFT(IX,ISHFCT),IY)
+C
+C  IF BACK TO START END CONTOUR
+C
+              IF (IX.EQ.JX .AND. IY.EQ.JY) GO TO   170
+C
+C  IF AT PREVIOUS CELL SKIP PROCESSING
+C
+              IF (IX.EQ.IXSTP .AND. IY.EQ.IYSTP) GO TO   340
+C
+C  COMPUTE CELL VALUES
+C
+              TL = SCRTCH(IX-1,IY-1)
+              BL = SCRTCH(IX,IY-1)
+              TR = SCRTCH(IX-1,IY)
+              BL = SCRTCH(IX,IY)
+              ICASE = IC
+              CALL CONCLD (ICASE,NOOP)
+              IF (ICASE.EQ.-1) GO TO 360
+              IF (ICASE.NE.0) GO TO    70
+C
+C  FAILURE TRY AGAIN
+C
+  340         CONTINUE
+  350     CONTINUE
+C
+C  NO MORE CONTOUR TRY OTHER END OF LINE
+C
+  360 IF (LOOP.EQ.0) GO TO   170
+      LOOP = 0
+      IX = JX
+      IY = JY
+      TR = TRT
+      TL = TLT
+      BR = BRT
+      BL = BLT
+      IC = IFCASE
+      ICASE = IC
+      IOLDC = IFOCSE
+      XC = XI
+      YC = YI
+      IXSTOR = IX
+      IYSTOR = IY
+      YCSTOR = YI
+      XCSTOR = XI
+      XX = FX(FXO,FYO)
+      CALL LASTD
+      CALL FRSTD (XX,FY(FXO,FYO))
+      GO TO (   90,  110,  130,  150),IC
+      END