text:
C  REVISION HISTORY
C     5-95  VRU  ... CRI ... MSTP S/W CONVERSION (VICAR PORTING)
c  10-Jan-2013 -lwk- Continuation line on error msg fixed for new compiler flag on Solaris
      INCLUDE 'VICMAIN_FOR'

C**********************************************************************

      SUBROUTINE MAIN44

      COMMON /C1/ DUNIT,SL,SS,NL,NS,SLDS,SSDS,NLDS,NSDS,NLI,NSI,
     &            FACT,CMUL,IPHASE,IL,IS,
     &            MODE,NLREC,NSREC,RADIUS,INSIDE,MULT,ADD,
     &            IPOS,ITEST
      COMMON /C3/ C,PTS,LBUF
      COMMON /C4/ X,Y,NPTS,IPT,
     &            VERTEX,NEPTS
      COMMON/XDDEV/ NLUTS, NIMPS, MAXLINES, MAXSAMPS, IGRAPH,
     &              NCURS, GPLANE, gdn

      INTEGER*2 VERTEX(2,500),NEPTS(4097)
      INTEGER*4 X(10),Y(10), NPTS, IPT,GRAPHICSPLANE
      INTEGER  GPLANE, NLUTS, NIMPS, MAXSAMPS, MAXLINES
      INTEGER  IGRAPH, NCURS, gdn
      COMPLEX*8 C(4097)
      REAL*4 MULT, RPARM(100)
      INTEGER*4 DUNIT,SL,SS,SLDS,SSDS,RADIUS,OUT,OUT2,IPARM(100)
      INTEGER*2 PTS(2,3000),LUT(256)
      BYTE LBUF(4097)
      INTEGER ITEST(2)
      CHARACTER*42 MSG
      INTEGER XDIFILL, XDSGRAPH
      EXTERNAL XVIPARM, XVPARM

      CALL IFMESSAGE('IFFT version 2016-02-12')
      CALL XVEACTION('SA',' ')
      MSG = 'CIRCLE   10        INTERIOR   MULT   0.10'

C        INITIALIZE AND SET DEFAULTS
      IPHASE=0
      CMUL=50.
      FACT=1.0
      SLDS=1
      SSDS=1
      NLDS=512
      NSDS=512
      IEXIT=0
      IMODIF=0
      ICURS=0
      MODE=1
      RADIUS=10
      INSIDE=1
      NLREC=21
      NSREC=21
      MULT=0.10
      ADD=0.0
      DO I=1,256
         LUT(I)=I-1
      END DO
      CALL ITLA(0,PTS,12000)

C        OPEN INPUT AND GET SIZE INFO
      CALL XVUNIT(IN,'INP',1,STAT,' ')
      CALL XVOPEN(IN,STAT,' ')
      CALL XVSIZE(SL,SS,NL,NS,NLI,NSI)
      NSI2=NSI+1

C        PROCESS ORIGINAL PARAMETERS - (NOT FOR FORTRAN PARAMETER PROC.)
C      CALL KEYWRD(1,IPARM,IPARM,NPAR,IEXIT,IDISP,IMODIF,ICURS,MSG,IND)

C        OPEN AND INITIALIZE DISPLAY DEVICE
      DUNIT=1
      CALL OPEN_DEVICE(DUNIT)
      MAXLDS=0
      MAXSDS=0
      CALL CONFIGURE_DEVICE(MAXLDS,MAXSDS,DUNIT)
      IF(MAXLDS.EQ.1024 .AND. MAXSDS.EQ.1024) THEN
         NLDS=1024
         NSDS=1024
      END IF
      CALL BW_MODE(DUNIT)
      CALL AUTOTRACKING_MODE(.TRUE.,DUNIT)
C        ERASE IMAGE PLANE
      IERR = XDIFILL(DUNIT,1,0)
C        ERASE GRAPHICS PLANE
      GRAPHICSPLANE = XDSGRAPH(DUNIT)
      IERR = XDIFILL(DUNIT,GRAPHICSPLANE,0)

C        COPY INPUT TO IDS1, REFORMATTING SO THAT DC IS IN CENTER
      CALL XVUNIT(OUT,'OUT',1,STAT,' ')
      CALL XVOPEN(OUT,STAT,'OP','WRITE','U_NL',NLI+1,'U_NS',NSI+1,' ')
      CALL XVMESSAGE('REFORMATTING INPUT',' ')
      CALL FFT_FORMAT(C,1,IN,OUT,NLI,NSI)
      CALL XVCLOSE(IN,STAT,' ')
      CALL XVCLOSE(OUT,STAT,' ')

C        OPEN IDS1 FOR UPDATE
      CALL XVOPEN(OUT,STAT,'OP','UPDATE',' ')

C        WRITE DISPLAY
      CALL DISPLY(OUT)

C           *** INTERACTIVE LOOP ***

C        PARAMETER PROCESSOR

100   CALL XVMESSAGE('IFFT READY',' ')
      CALL XVINTRACT
     &     ('IPARAM','Enter parameters:') !wait for inter. params.

      CALL KEYWRD(xviparm,RPARM,IPARM,
     &            NPAR,IEXIT,IDISP,IMODIF,ICURS,MSG,IND,.true.)
      IF (NPAR .EQ. 0) GO TO 500
      IF (IND .NE. 0) GO TO 100

C        REWRITE DISPLAY
      IF(IDISP.EQ.0) GO TO 200
      IERR = XDIFILL(DUNIT,1,0)
      CALL DISPLY(OUT)

C        PRINT NEW MODIFY PARAMETERS
200   IF(IMODIF.EQ.0) GO TO 300
      CALL XVMESSAGE('TRANSFORM MODIFICATION OPTIONS IN EFFECT:',' ')
      CALL XVMESSAGE(MSG,' ')

C        READ/WRITE CURSOR POSITION
300   IF(ICURS.EQ.0) GO TO 400
      CALL CURSOR(ICURS)

C        CHECK FOR EXIT
400   IF(IEXIT.EQ.1) GO TO 900
      GO TO 100

C        MODIFY TRANSFORM
500   CALL MODIFY(OUT)
      GO TO 100

C        REFORMAT TRANSFORM PUTTING DC BACK IN UPPER LEFT
900   CALL XVCLOSE(OUT,STAT,' ')
      CALL XVOPEN(OUT,STAT,' ')
      CALL XVUNIT(OUT2,'OUT',2,STAT,' ')
      CALL XVOPEN(OUT2,STAT,'OP','WRITE','U_NL',NLI,'U_NS',NSI,' ')
      CALL XVMESSAGE('WRITING OUTPUT',' ')
      CALL FFT_FORMAT(C,-1,OUT,OUT2,NLI,NSI)
      CALL XVCLOSE(OUT,STAT,' ')
      CALL XVCLOSE(OUT2,STAT,' ')

C        CLOSE DISPLAY DEVICE
      CALL CLOSE_DEVICE(DUNIT)

      RETURN
      END

C**********************************************************************

      SUBROUTINE KEYWRD(XXPARM,RPARM,IPARM,NPAR,IEXIT,IDISP,
     &                  IMODIF,ICURS,MSG,IND,INTERACTIVE)

      COMMON /C1/ DUNIT,SL,SS,NL,NS,SLDS,SSDS,NLDS,NSDS,NLI,NSI,
     &            FACT,CMUL,IPHASE,IL,IS,
     &            MODE,NLREC,NSREC,RADIUS,INSIDE,MULT,ADD,
     &            IPOS,ITEST

      REAL*4 RPARM(100),MULT
      INTEGER*4 IPARM(100),SL,SS,SLDS,SSDS,
     &          RADIUS,DUNIT
      CHARACTER*42 MSG
      EXTERNAL XXPARM
      LOGICAL INTERACTIVE
      INTEGER ITEST(2)
      CHARACTER*8 CPARM

      NPAR   = 0
      IND    = 0
      IDISP  = 0
      IMODIF = 0
      ICURS  = 0
      IPOS   = 0

C  PARAMETER PROCESSOR

c        'EXIT'
      IF (INTERACTIVE) THEN
         CALL XXPARM( 'EXIT', CPARM, ICOUNT, IDEF , 0)
          IF (ICOUNT .EQ. 1)  THEN
              NPAR  = 1
              IEXIT = 1
              RETURN
          END IF
      END IF

C        'SLDS - STARTING LINE DISPLAY SCREEN'OM
      CALL XXPARM( 'SLDS', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SLDS  = IPARM(1)
          IDISP = 1
      END IF

C        'SSDS - STARTING SAMPLE DISPLAY SCREEN'

      CALL XXPARM( 'SSDS', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SSDS  = IPARM(1)
          IDISP = 1
      END IF

C        'UP'

      CALL XXPARM( 'U', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SL    = SL - IPARM(1)
          IF (SL .LT. 1) SL = 1
          IDISP = 1
      END IF

C        'DOWN'

      CALL XXPARM( 'D', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SL    = SL + IPARM(1)
          IF (SL .GT. NLI) SL = NLI - 512 + 1
          IF (SL .LT. 1) SL = 1
          IDISP = 1
      END IF

C        'LEFT'

      CALL XXPARM( 'L', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SS    = SS - IPARM(1)
          IF (SS .LT. 1) SS = 1
          IDISP = 1
      END IF

C        'RIGHT'

      CALL XXPARM( 'R', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          SS    = SS + IPARM(1)
          IF (SS .GT. NSI) SS = NSI - NSDS + 1
          IF (SS .LT. 1) SS = 1
          IDISP = 1
      END IF

C        'THRESH'

      CALL XXPARM( 'THRESH', RPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          THRESH = RPARM(1)
          FACT   = 1.0 / THRESH
          IDISP  = 1
      END IF

C        'CMUL'

      CALL XXPARM( 'CMUL', RPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR  = 1
          CMUL  = RPARM(1)
          IDISP = 1
      END IF

C        'AMPLITUDE PICTURE'

      CALL XXPARM( 'AMPLITUD', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          IPHASE = 0
          IDISP  = 1
      END IF

C        'PHASE - PHASE PICTURE

      CALL XXPARM( 'PHASE', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          IPHASE = 1
          IDISP  = 1
      END IF

C        'CIRC - CIRCLE'

      CALL XXPARM( 'CIRCLE', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          MODE   = 1
          RADIUS = IPARM(1)
          IMODIF = 1
C          MSG    = ' '
          MSG(1:6) = 'CIRCLE'
          WRITE (MSG(8:11),'(I4)') RADIUS
      END IF

C        'RECT - RECTANGLE'

      CALL XXPARM( 'RECTANGL', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 2)  THEN
          NPAR   = 1
          MODE   = 2
          NLREC  = IPARM(1)
          NSREC  = IPARM(2)
          IMODIF = 1
          MSG(1:7) = 'RECT   '
          WRITE (MSG(8:11),'(I4)') NLREC
          WRITE (MSG(13:16),'(I4)') NSREC
      END IF

C        'VERT - VERTEX MODE'

      CALL XXPARM( 'VERTEX', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          MODE   = 3
          IMODIF = 1
          MSG(1:7) = 'VERTEX '
          MSG(8:17) = '         '
          CALL XVMESSAGE
     &         ('FOR EACH POINT, POSITION THE CURSOR AND',' ')
          CALL XVMESSAGE
     &         ('PRESS <CR>. PRESS <CR> A SECOND TIME WITHOUT',' ')
          CALL XVMESSAGE
     &         ('MOVING CURSOR TO INDICATE THE LAST VERTEX.',' ')
          CALL XVMESSAGE
     &         ('DO NOT END WITH THE ORIGINAL VERTEX; THE',' ')
          CALL XVMESSAGE
     &         ('PROGRAM WILL COMPLETE THE POLYGON FOR YOU.',' ')
      END IF

C        'INTERIOR'

      CALL XXPARM( 'INTERIOR', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          INSIDE = 1
          IMODIF = 1
          MSG(20:27) = 'INTERIOR'
      END IF

C        'EXTERIOR'

      CALL XXPARM( 'EXTERIOR', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          INSIDE = 0
          IMODIF = 1
          MSG(20:27) = 'EXTERIOR'
      END IF

C        'MULT - MULTIPLY'

      CALL XXPARM( 'MULTIPLY', RPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          MULT = RPARM(1)
          IMODIF = 1
          WRITE (MSG(36:41),'(F6.2)') MULT+.0001
      END IF

C        'ADD'

      CALL XXPARM( 'ADD', RPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
          ADD    = RPARM(1)
          IMODIF = 1
      END IF

C        'RCUR - READ CURSOR POSITON'

      CALL XXPARM( 'RCUR', CPARM, ICOUNT, IDEF , 0)
      IF (IDEF .EQ. 0)  THEN
          NPAR  = 1
          ICURS = 1
      END IF

C        'WCUR - WRITE CURSOR TO SPECIFIED SCREEN COORDINATES'

      CALL XXPARM( 'WCUR', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 2)  THEN
          NPAR  = 1
          ICURS = 2
          IL    = IPARM(1)
          IS    = IPARM(2)
      END IF

C        'PCUR - POSITION CURSOR TO SPICIFIED IMAGE COORDINATES'

      CALL XXPARM( 'PCUR', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 2)  THEN
          NPAR  = 1
          ICURS = 3
          IL    = IPARM(1)
          IS    = IPARM(2)
      END IF

C        'NO'

      CALL XXPARM( 'NO', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
          NPAR   = 1
      END IF

C        'POSITION - POSITION CURSOR TO SPICIFIED IMAGE COORDINATES'

      CALL XXPARM( 'POSITION', IPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 2)  THEN
          IPOS = 1
          ITEST(1) = IPARM(1)
          ITEST(2) = IPARM(2)
      END IF

      RETURN
       END
C
C**********************************************************************
C
      SUBROUTINE FFT_FORMAT(C,IDIR,UNIT1,UNIT2,NLI,NSI)
C
      COMPLEX*8 C(4097)
      INTEGER*4 UNIT1,UNIT2,SSQ1,SSQ2,STAT
C
      IF(IDIR.EQ.-1) GO TO 101
C
C        *** CONVERT FROM DC IN UPPER LEFT TO DC IN CENTER ***
C            ONE LINE AND ONE SAMPLE ARE ADDED FOR SYMMETRY
C
      SSQ1=NSI/2+1
      NSQ1=NSI/2
      SSQ2=NSQ1+1
      NSQ2=NSQ1+1
      ILINE=NLI/2+1
      NLO=NLI+1
      NSO=NSI+1
C
      DO 100 LINE=1,NLO
      CALL XVREAD(UNIT1,C(1),STAT,'LINE',ILINE,
     &            'SAMP',SSQ1,'NSAMPS',NSQ1,' ')
      CALL XVREAD(UNIT1,C(SSQ2),STAT,'LINE',ILINE,'NSAMPS',NSQ2,' ')
      CALL XVWRIT(UNIT2,C,STAT,'LINE',LINE,'NSAMPS',NSO,' ')
      ILINE=ILINE-1
      IF(ILINE.EQ.0) ILINE=NLI
  100 CONTINUE
      RETURN
C
C        *** CONVERT FROM DC IN CENTER TO DC IN UPPER LEFT ***
C            EXTRA LINE AND SAMPLE ARE IGNORED
C
101   NSQ=NSI/2
      SSQ2=NSI/2+1
      ILINE=NLI/2+1
      NLO=NLI
      NSO=NSI
C
      DO 200 LINE=1,NLO
      CALL XVREAD(UNIT1,C(1),STAT,'LINE',ILINE,
     &            'SAMP',SSQ2,'NSAMPS',NSQ,' ')
      CALL XVREAD(UNIT1,C(SSQ2),STAT,'LINE',ILINE,'NSAMPS',NSQ,' ')
      CALL XVWRIT(UNIT2,C,STAT,'LINE',LINE,'NSAMPS',NSO,' ')
      ILINE=ILINE-1
      IF(ILINE.EQ.0) ILINE=NLI
  200 CONTINUE
      RETURN
C
C        ERROR RETURN
C991   CALL XVMESSAGE('*** READ ERROR ***',' ')
C      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE DISPLY(IUNIT)
C
C        DISPLAY IMAGE
C
      COMMON /C1/ DUNIT,SL,SS,NL,NS,SLDS,SSDS,NLDS,NSDS,NLI,NSI,
     &            FACT,CMUL,IPHASE,IL,IS,
     &            MODE,NLREC,NSREC,RADIUS,INSIDE,MULT,ADD,
     &            IPOS,ITEST
      COMMON /C3/ C,PTS,LBUF
C
      COMPLEX*8 C(4097)
      REAL*4 MULT
      INTEGER*4 DUNIT,SL,SS,SLDS,SSDS,ELDS,ELDS2,RADIUS
      INTEGER*4 STAT
      INTEGER*2 PTS(2,3000)
      BYTE LBUF(4097)
      INTEGER XDILINEWRITE
      INTEGER ITEST(2)
C
      IF(NS.GT.NSDS) NS=NSDS
      IF(NS.GT.NSI-SS+2) NS=NSI-SS+2
C        INSURE NS IS EVEN FOR XDILINEWRITE
      NS=((NS+1)/2)*2
      IF(NL.GT.NLDS) NL=NLDS
      IF(NL.GT.NLI-SL+2) NL=NLI-SL+2
      LINE=SL
      ELDS=SLDS+NL-1
      ELDS2=ELDS-1
      NSI2=NSI+1
C
      CALL XVREAD(IUNIT,C,STAT,'LINE',SL,'NSAMPS',NSI2,' ')
      DO 100 ILDS=SLDS,ELDS2
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      CALL XVREAD(IUNIT,C,STAT,'NSAMPS',NSI2,' ')
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILDS,NS,LBUF)
  100 CONTINUE
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILDS,NS,LBUF)
C
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
C
C        CONVERT COMPLEX DATA TO BYTE DATA
C
      INCLUDE 'fortport'
      COMPLEX*8 C(4097)
      INTEGER*4 SS,ES,IDN
      BYTE LBUF(4097)
C      INTEGER ISIGN
C      ISIGN = 0
C
      ES=SS+NS-1
      K=0
      IF(IPHASE.EQ.1) GO TO 200
C
C        AMPLITUDE   (LOG SCALING)
      DO 100 I=SS,ES
      K=K+1
      X=FACT*CABS(C(I))
      IF(X.LT.1.0) X=1.0
      IDN=ALOG10(X)*CMUL
      IF(IDN.GT.255) IDN=255
      LBUF(K) = INT2BYTE(IDN)
  100 CONTINUE
C
      RETURN
C
C        PHASE   (LINEAR SCALING)
200   DO 300 I=SS,ES
      K=K+1
      X=REAL(C(I))
      Y=AIMAG(C(I))
      IF(X.EQ.0.0) GO TO 210
      X=ATAN2(Y,X)
      GO TO 250
C
210   IF(Y.EQ.0.0) GO TO 220
      X=SIGN(1.570796,Y)
      GO TO 250
C
220   X=0.0
C
250   IDN=50*X
C      IF(ISIGN.EQ.0) IDN=IABS(IDN)
      IDN=IABS(IDN)
      IF(IDN.GT.255) IDN=255
      LBUF(K) = INT2BYTE(IDN)
  300 CONTINUE
C
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE MODIFY(OUT)
C
      COMMON /C1/ DUNIT,SL,SS,NL,NS,SLDS,SSDS,NLDS,NSDS,NLI,NSI,
     &            FACT,CMUL,IPHASE,IL,IS,
     &            MODE,NLREC,NSREC,RADIUS,INSIDE,MULT,ADD,
     &            IPOS,ITEST
      COMMON /C3/ C,PTS,LBUF
      COMMON /C4/ X,Y,NPTS,IPT,
     &            VERTEX,NEPTS
      COMMON/XDDEV/ NLUTS, NIMPS, MAXLINES, MAXSAMPS, IGRAPH,
     &              NCURS, GPLANE, gdn
C
      INCLUDE 'fortport'
      COMPLEX*8 C(4097)
      REAL*4 MULT
      INTEGER*4 DUNIT,SL,SS,SLDS,SSDS,RADIUS,IVERT
      INTEGER*4 SLREC,SSREC,ELREC,ESREC,SLIM,ELIM
      INTEGER*4 DCLINE,DCSAMP,SLINE,ELINE,CMINS,CMAXS,CPT1,CLINE
      INTEGER*4 STAT,OUT, gdn
      INTEGER*2 PTS(2,3000),VERTEX(2,500),NEPTS(4097)
      INTEGER*4 X(10),Y(10), NPTS, IPT
      INTEGER ITEST(2)
      BYTE LBUF(4097)
      INTEGER XDCLOCATION,XDIPOLYLINE,XDIMFILL,XDILINEWRITE
      CHARACTER*8 CPARM
      INTEGER  GPLANE, NLUTS, NIMPS, MAXSAMPS, MAXLINES
      INTEGER  IGRAPH, NCURS, IOS
      EXTERNAL XVIPARM
      DATA IVERT /0/
C
C        READ TRACKBALL POSITION
       IERR = XDCLOCATION(DUNIT,1,ISAM,ILIN)
C
      GO TO (100,200,300),MODE
C
C        *** CIRCLE MODE ***
C
100   MINL=ILIN-RADIUS
      MAXL=ILIN+RADIUS
      IF(MINL.LT.1) MINL=1
      IF(MAXL.GT.NLDS) MAXL=NLDS
      IPT=-1
      R2=RADIUS*RADIUS
      DO 120 LINE=MINL,MAXL
      IPT=IPT+2
      DELLIN=LINE-ILIN
      DELSAM=SQRT(R2-DELLIN*DELLIN)
      PTS(1,IPT)=LINE
      PTS(2,IPT)=ISAM-DELSAM+0.5
      IF(PTS(2,IPT).LT.1) PTS(2,IPT)=1
      PTS(1,IPT+1)=LINE
      PTS(2,IPT+1)=ISAM+DELSAM+0.5
      IF(PTS(2,IPT+1).GT.NSDS) PTS(2,IPT+1)=NSDS
  120 CONTINUE
      NPTS=IPT+1
C        DRAW CIRCLE
      Y(1)=PTS(1,1)
      X(1)=PTS(2,1)
      DO 150 IPT=2,NPTS,2
      Y(2)=PTS(1,IPT)
      X(2)=PTS(2,IPT)
       CALL TESTOS(IOS)
       IF (IOS .EQ. 0) THEN
        IERR = XDIPOLYLINE(DUNIT,GPLANE,127,2,X,Y)
       ENDIF
       IF (IOS .EQ. 1) THEN
      IERR = XDIPOLYLINE(DUNIT,GPLANE,INT2BYTE(gdn),2,X,Y)
       ENDIF
      Y(1)=Y(2)
      X(1)=X(2)
  150 CONTINUE
      Y(1)=PTS(1,1)
      X(1)=PTS(2,1)
      DO 155 IPT=3,NPTS,2
      Y(2)=PTS(1,IPT)
      X(2)=PTS(2,IPT)
      IF (IOS .EQ. 0) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,127,2,X,Y)
      ENDIF
      IF (IOS .EQ. 1) THEN
      IERR = XDIPOLYLINE(DUNIT,GPLANE,INT2BYTE(gdn),2,X,Y)
      ENDIF
      Y(1)=Y(2)
      X(1)=X(2)
  155 CONTINUE
      GO TO 500
C
C        *** RECTANGLE MODE ***
C
200   SLREC=ILIN-NLREC/2
      ELREC=SLREC+NLREC-1
      SSREC=ISAM-NSREC/2
      ESREC=SSREC+NSREC-1
      IF(SLREC.LT.1) SLREC=1
      IF(ELREC.GT.NLDS) ELREC=NLDS
      IF(SSREC.LT.1) SSREC=1
      IF(ESREC.GT.NSDS) ESREC=NSDS
      IPT=-1
      DO 210 LINE=SLREC,ELREC
      IPT=IPT+2
      PTS(1,IPT)=LINE
      PTS(2,IPT)=SSREC
      PTS(1,IPT+1)=LINE
      PTS(2,IPT+1)=ESREC
  210 CONTINUE
      NPTS=IPT+1
      X(1)=SSREC
      Y(1)=SLREC
      X(2)=ESREC
      Y(2)=SLREC
      X(3)=ESREC
      Y(3)=ELREC
      X(4)=SSREC
      Y(4)=ELREC
      X(5)=SSREC
      Y(5)=SLREC
      CALL TESTOS(IOS)
      IF (IOS .EQ. 0) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,127,5,X,Y)
      ENDIF
      IF (IOS .EQ. 1) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,INT2BYTE(gdn),5,X,Y)
      ENDIF
      GO TO 500
C
C        *** VERTEX MODE ***
C
300   CONTINUE
      IF (IPOS .EQ. 1)  THEN    ! GET CURSOR POSITION FROM PARAMETER
         ILIN = ITEST(1)        ! IF USING 'POSITION'.
         ISAM = ITEST(2)
      END IF
      IF(IVERT.GT.0) GO TO 310
C        FIRST VERTEX
      IVERT=1
      IPT=1
      VERTEX(1,IVERT)=ILIN
      VERTEX(2,IVERT)=ISAM
      PTS(1,IPT)=ILIN
      PTS(2,IPT)=ISAM
      X(1)=ISAM
      Y(1)=ILIN
      RETURN
C
C        CHECK IF POINT IS SAME AS LAST VERTEX
310   IF(ILIN.EQ.VERTEX(1,IVERT).AND.ISAM.EQ.VERTEX(2,IVERT)) GO TO 320
      IVERT=IVERT+1
      VERTEX(1,IVERT)=ILIN
      VERTEX(2,IVERT)=ISAM
      X(2)=ISAM
      Y(2)=ILIN
      CALL TESTOS(IOS)
      IF (IOS .EQ. 0) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,127,2,X,Y)
      ENDIF
      IF (IOS .EQ. 1) THEN
      IERR = XDIPOLYLINE(DUNIT,GPLANE,INT2BYTE(gdn),2,X,Y)
      ENDIF
      X(1)=X(2)
      Y(1)=Y(2)
      IF(IVERT.EQ.2) GO TO 312
C        IF PREVIOUS VERTEX IS A LOCAL MIN OR MAX DUPLICATE IT IN PTS
      L1=VERTEX(1,IVERT-2)
      L2=VERTEX(1,IVERT-1)
      L3=VERTEX(1,IVERT)
      IF(L2.GT.L1.AND.L2.GT.L3) GO TO 311
      IF(L2.LT.L1.AND.L2.LT.L3) GO TO 311
      IF(L2.EQ.L1.AND.L2.EQ.L3) GO TO 311
      GO TO 312
C        INSERT DUPLICATE POINT
311   IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,IVERT-1)
      PTS(2,IPT)=VERTEX(2,IVERT-1)
C        COMPUTE POINTS ALONG LINE  (INCLUDING LATEST VERTEX)
312   IDY=VERTEX(1,IVERT)-VERTEX(1,IVERT-1)
      IF(IDY.EQ.0) GO TO 315
      IDX=VERTEX(2,IVERT)-VERTEX(2,IVERT-1)
      SLOPE=FLOAT(IDX)/FLOAT(IDY)
      LINC=1
      IF(VERTEX(1,IVERT-1).GT.VERTEX(1,IVERT)) LINC=-1
      NLINE=IABS(IDY)
      DO 313 IL=1,NLINE
      IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,IVERT-1)+IL*LINC
      PTS(2,IPT)=VERTEX(2,IVERT-1)+IL*LINC*SLOPE+0.5
  313 CONTINUE
      RETURN
C
C        HORIZONTAL LINE
315   IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,IVERT)
      PTS(2,IPT)=VERTEX(2,IVERT)
      RETURN
C
C        CLOSE POLYGON  (CONNECT LAST VERTEX TO FIRST VERTEX)
320   NVERT=IVERT
      X(2)=VERTEX(2,1)
      Y(2)=VERTEX(1,1)
      IF (IOS .EQ. 0) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,127,2,X,Y)
      ENDIF
      IF (IOS .EQ. 1) THEN
       IERR = XDIPOLYLINE(DUNIT,GPLANE,INT2BYTE(gdn),2,X,Y)
      ENDIF
      X(1)=X(2)
      Y(1)=Y(2)
C        IF PREVIOUS VERTEX IS A LOCAL MIN OR MAX DUPLICATE IT IN PTS
      L1=VERTEX(1,IVERT-1)
      L2=VERTEX(1,IVERT)
      L3=VERTEX(1,1)
      IF(L2.GT.L1.AND.L2.GT.L3) GO TO 321
      IF(L2.LT.L1.AND.L2.LT.L3) GO TO 321
      IF(L2.EQ.L1.AND.L2.EQ.L3) GO TO 321
      GO TO 322
C        INSERT DUPLICATE POINT FOR VERTEX
321   IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,IVERT)
      PTS(2,IPT)=VERTEX(2,IVERT)
C        COMPUTE POINTS ALONG LINE  (EXCLUDING VERTICES)
322   IDY=VERTEX(1,1)-VERTEX(1,IVERT)
C        FOR HORIZONTAL LINE OR ONE LINE DIFFERENCE ONLY NEED ENDPOINTS
      IF(IABS(IDY).LE.1) GO TO 325
      IDX=VERTEX(2,1)-VERTEX(2,IVERT)
      SLOPE=FLOAT(IDX)/FLOAT(IDY)
      LINC=1
      IF(VERTEX(1,IVERT).GT.VERTEX(1,1)) LINC=-1
      NLINE=IABS(IDY)-1
      DO 323 IL=1,NLINE
      IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,IVERT)+IL*LINC
      PTS(2,IPT)=VERTEX(2,IVERT)+IL*LINC*SLOPE+0.5
  323 CONTINUE
C        CHECK IF FIRST VERTEX IS A LOCAL MIN OR MAX
325   L1=VERTEX(1,IVERT)
      L2=VERTEX(1,1)
      L3=VERTEX(1,2)
      IF(L2.GT.L1.AND.L2.GT.L3) GO TO 328
      IF(L2.LT.L1.AND.L2.LT.L3) GO TO 328
      IF(L2.EQ.L1.AND.L2.EQ.L3) GO TO 328
      NPTS=IPT
      GO TO 500
C        DUPLICATE FIRST VERTEX POINT
328   IPT=IPT+1
      PTS(1,IPT)=VERTEX(1,1)
      PTS(2,IPT)=VERTEX(2,1)
      NPTS=IPT
C
C        ***** PROCESS AREA *****
C
C        CHECK IF OK
500   CALL XVMESSAGE('OK?  HIT <CR> IF OK OR TYPE NO TO REDO',' ')
      CALL XVINTRACT ('OK','Enter Response:')

      IVERT=0
      CALL XVIPARM( 'NO', CPARM, ICOUNT, IDEF , 0)
      IF (ICOUNT .EQ. 1)  THEN
      CALL TESTOS(IOS)
         IF (IOS .EQ. 0) THEN
           IERR = XDIMFILL(DUNIT,GPLANE,127,0)
         ENDIF
         IF (IOS .EQ. 1) THEN
           IERR = XDIMFILL(DUNIT,GPLANE,INT2BYTE(255),0)
         ENDIF
         RETURN
      ENDIF
C
C        ORGANIZE IN ORDER OF LINE NUMBER
      CALL SORTX(PTS,NPTS)
C
C        GET SMALLEST AND LARGEST LINE
      MINL=PTS(1,1)
      MAXL=PTS(1,NPTS)
C
C        DETERMINE NUMBER OF ENDPOINTS FOR EACH LINE
      DO 520 I=MINL,MAXL
      NEPTS(I)=0
  520 CONTINUE
      DO 530 IPT=1,NPTS
      LINE=PTS(1,IPT)
      NEPTS(LINE)=NEPTS(LINE)+1
  530 CONTINUE
C        INSURE THAT THE NUMBER OF ENDPOINTS EQUALS TWO
      DO 550 I=MINL,MAXL
      IF(NEPTS(I).NE.2) GO TO 995
  550 CONTINUE
C
C        ***** MODIFY DATA VALUES *****
C
      NSI2=NSI+1
C        (DCLINE,DCSAMP) IS THE LOCATION OF DC IN SCREEN COORDINATES
      DCLINE=NLI/2+1-SL+SLDS
      DCSAMP=NSI/2+1-SS+SSDS
C        COMPUTE STARTING AND ENDING LINE SO THAT CONJUGATE LINES
C        ARE NOT MODIFIED TWICE
      SLINE=MINL
      ELINE=MAXL
      IF(MAXL.LT.DCLINE.OR.MINL.GT.DCLINE) GO TO 600
      NLTOP=DCLINE-MINL+1
      NLBOT=MAXL-DCLINE+1
      IF(NLBOT.GT.NLTOP) SLINE=DCLINE
      ELINE=DCLINE
      IF(NLBOT.GT.NLTOP) ELINE=MAXL
C
600   IF(INSIDE.EQ.1) GO TO 610
C
C        --- TAKE CARE OF EXTERIOR LINES ---
C
C        TOP LINES
      ELIM=MIN0(SLINE,DCLINE+DCLINE-ELINE)-1+SL-SLDS
      IF(ELIM.LT.1) GO TO 603
      IF(ELIM.GT.NLI+1) ELIM=NLI+1
      DO 602 IMLINE=1,ELIM
      IREC=IMLINE
C        INSURE PREVIOUS WRITE IS FINISHED BEFORE TRY TO READ
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      CALL DATMOD(C,MULT,ADD,NSI2,1,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      ILINE=IMLINE-SL+SLDS
      IF(ILINE.LT.SLDS.OR.ILINE.GT.SLDS+NL-1) GO TO 602
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILINE,NS,LBUF)
  602 CONTINUE
C
603   IF(MINL.LT.DCLINE.AND.MAXL.GT.DCLINE) GO TO 605
C        CENTER LINES
      SLIM=MIN0(ELINE,DCLINE+DCLINE-SLINE)+1+SL-SLDS
      ELIM=MAX0(SLINE,DCLINE+DCLINE-ELINE)-1+SL-SLDS
      IF(SLIM.LT.1) SLIM=1
      IF(ELIM.GT.NLI+1) ELIM=NLI+1
      DO 604 IMLINE=SLIM,ELIM
      IREC=IMLINE
C        INSURE PREVIOUS WRITE IS FINISHED BEFORE TRY TO READ
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      CALL DATMOD(C,MULT,ADD,NSI2,1,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      ILINE=IMLINE-SL+SLDS
      IF(ILINE.LT.SLDS.OR.ILINE.GT.SLDS+NL-1) GO TO 604
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILINE,NS,LBUF)
  604 CONTINUE
C
C        BOTTOM LINES
605   SLIM=MAX0(ELINE,DCLINE+DCLINE-SLINE)+1+SL-SLDS
      IF(SLIM.LT.1) SLIM=1
      IF(SLIM.GT.NLI+1) GO TO 610
      ELIM=NLI+1
      DO 606 IMLINE=SLIM,ELIM
      IREC=IMLINE
C        INSURE PREVIOUS WRITE IS FINISHED BEFORE TRY TO READ
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      CALL DATMOD(C,MULT,ADD,NSI2,1,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      ILINE=IMLINE-SL+SLDS
      IF(ILINE.LT.SLDS.OR.ILINE.GT.SLDS+NL-1) GO TO 606
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILINE,NS,LBUF)
  606 CONTINUE
C
610   DO 700 ILINE=SLINE,ELINE
      PT1=2*(ILINE-MINL)+1
      MINS1=PTS(2,PT1)
      MAXS1=PTS(2,PT1+1)
      MINS2=MINS1
      MAXS2=MAXS1
C        COMPUTE CONJUGATE LINE NUMBER
      CLINE=DCLINE+DCLINE-ILINE
      IF(CLINE.LT.MINL.OR.CLINE.GT.MAXL) GO TO 620
C        TRANSLATE SECTION OF CONJUGATE LINE TO BE MODIFIED
      CPT1=2*(CLINE-MINL)+1
      MINS2=DCSAMP+DCSAMP-PTS(2,CPT1+1)
      MAXS2=DCSAMP+DCSAMP-PTS(2,CPT1)
C        CHECK IF SAMPLES DO NOT OVERLAP
      IF(MINS1.GT.MAXS2.OR.MAXS1.LT.MINS2) GO TO 660
C
C        --- MODIFY SINGLE SECTION OF TWO LINES ---
C
620   MINS=MIN0(MINS1,MINS2)
      MAXS=MAX0(MAXS1,MAXS2)
      CMINS=DCSAMP+DCSAMP-MAXS
      CMAXS=DCSAMP+DCSAMP-MINS
C
      IMLINE=ILINE+SL-SLDS
      IF(IMLINE.LT.1.OR.IMLINE.GT.NLI+1) GO TO 640
      IREC=IMLINE
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      MINS=MINS+SS-SSDS
      MAXS=MAXS+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,1,MINS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILINE,NS,LBUF)
C
640   IF(CLINE.EQ.DCLINE) GO TO 700
      IMLINE=CLINE+SL-SLDS
      IF(IMLINE.LT.1.OR.IMLINE.GT.NLI) GO TO 700
      IREC=IMLINE
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      MINS=CMINS+SS-SSDS
      MAXS=CMAXS+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,1,MINS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,CLINE,NS,LBUF)
      GO TO 700
C
C        --- MODIFY TWO SECTIONS OF TWO LINES ---
C
660   IMLINE=ILINE+SL-SLDS
      IF(IMLINE.LT.1.OR.IMLINE.GT.NLI) GO TO 680
      IREC=IMLINE
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      MINS=MIN0(MINS1,MINS2)+SS-SSDS
      MAXS=MIN0(MAXS1,MAXS2)+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,1,MINS,IPHASE)
      MINS=MAX0(MINS1,MINS2)+SS-SSDS
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,MINS,IPHASE)
      MAXS=MAX0(MAXS1,MAXS2)+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,ILINE,NS,LBUF)
C
680   IF(CLINE.EQ.DCLINE) GO TO 700
      IMLINE=CLINE+SL-SLDS
      IF(IMLINE.LT.1.OR.IMLINE.GT.NLI) GO TO 700
      IREC=IMLINE
      CALL XVREAD(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
      MINS=DCSAMP+DCSAMP-MAX0(MAXS1,MAXS2)+SS-SSDS
      MAXS=DCSAMP+DCSAMP-MAX0(MINS1,MINS2)+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,1,MINS,IPHASE)
      MINS=DCSAMP+DCSAMP-MIN0(MAXS1,MAXS2)+SS-SSDS
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,MINS,IPHASE)
      MAXS=DCSAMP+DCSAMP-MIN0(MINS1,MINS2)+SS-SSDS
      IF(INSIDE.EQ.1) CALL DATMOD(C,MULT,ADD,NSI2,MINS,MAXS,IPHASE)
      IF(INSIDE.EQ.0) CALL DATMOD(C,MULT,ADD,NSI2,MAXS,NSI2,IPHASE)
      CALL XVWRIT(OUT,C,STAT,'LINE',IREC,'NSAMPS',NSI2,' ')
C        DISPLAY MODIFIED LINE
      CALL DATCON(C,LBUF,SS,NS,FACT,CMUL,IPHASE)
      IERR=XDILINEWRITE(DUNIT,1,SSDS,CLINE,NS,LBUF)
C
  700 CONTINUE
C
990   CONTINUE
      CALL TESTOS(IOS)
      IF (IOS .EQ. 0) THEN
        IERR = XDIMFILL(DUNIT,GPLANE,127,0)
      ENDIF
      IF (IOS .EQ. 1) THEN
        IERR = XDIMFILL(DUNIT,GPLANE,INT2BYTE(255),0)
      ENDIF
      CALL ITLA(0,PTS,4*NPTS)
      RETURN
C
C        ERROR RETURNS
995   CALL XVMESSAGE('ODD FIGURE, TRY AGAIN',' ')
C        ERASE GRAPHICS PLANE
      CALL TESTOS(IOS)
      IF (IOS .EQ. 0) THEN
        IERR = XDIMFILL(DUNIT,GPLANE,127,0)
      ENDIF
      IF (IOS .EQ. 1) THEN
        IERR = XDIMFILL(DUNIT,GPLANE,INT2BYTE(255),0)
      ENDIF
      IVERT=0
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE DATMOD(C,MULT,ADD,NSI,MINS,MAXS,IPHASE)
C
      COMPLEX*8 C(4097)
      REAL*4 MULT,IM,RE
C
      IF(MINS.GT.NSI+1.OR.MAXS.LT.1) RETURN
      IF(MINS.LT.1) MINS=1
      IF(MAXS.GT.NSI+1) MAXS=NSI+1
C
      IF(IPHASE.EQ.1) GO TO 200
C
C        MODIFY AMPLITUDE KEEPING PHASE CONSTANT
      DO 100 ISAMP=MINS,MAXS
      C(ISAMP)=MULT*C(ISAMP)+ADD
  100 CONTINUE
      RETURN
C
C        MODIFY PHASE KEEPING AMPLITUDE CONSTANT
200   DO 280 ISAMP=MINS,MAXS
C        COMPUTE PRESENT PHASE
      X=REAL(C(ISAMP))
      Y=AIMAG(C(ISAMP))
      IF(X.EQ.0.0) GO TO 210
      THETA=ATAN2(Y,X)
      GO TO 250
210   IF(Y.EQ.0.0) GO TO 220
      THETA=SIGN(1.570796,Y)
      GO TO 250
220   THETA=0.0
C        MODIFY
250   THETA=MULT*THETA+ADD
      A=CABS(C(ISAMP))
      T=TAN(THETA)
      T2=T*T
      D=SQRT(1.0+T2)
      RE=A/D
      IM=A*T/D
      C(ISAMP)=CMPLX(RE,IM)
  280 CONTINUE
      RETURN
C
C        REPLACE VALUES WITH MEAN ALONG BORDER
C300   DO 350 JJ=LOWS,LHS
C      X=CABS(C(JJ))
C      IF(RMEAN.GT.X) GO TO 350
C      C(JJ)=C(JJ)*(RMEAN/X)
C  350 CONTINUE
C
C      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE CURSOR(ICURS)
C
      COMMON /C1/ DUNIT,SL,SS,NL,NS,SLDS,SSDS,NLDS,NSDS,NLI,NSI,
     &            FACT,CMUL,IPHASE,IL,IS,
     &            MODE,NLREC,NSREC,RADIUS,INSIDE,MULT,ADD,
     &            IPOS,ITEST
C
      INTEGER*4 DUNIT,SL,SS,SLDS,SSDS,RADIUS
      CHARACTER*30 MSG1,MSG2
      INTEGER XDCLOCATION,XDCSET
      INTEGER ITEST(2)
C
      MSG1 = ' SCREEN   LN=XXXXX   SMP=XXXXX'
      MSG2 = ' PICTURE  LN=XXXXX   SMP=XXXXX'
      GO TO (100,200,300),ICURS
C
C        READ AND PRINT CURSOR POSITION
100   IERR = XDCLOCATION(DUNIT,1,IS,IL)
      ILX=SL+IL-SLDS
      ISX=SS+IS-SSDS
      WRITE (MSG1(14:18),'(I5)') IL
      WRITE (MSG1(26:30),'(I5)') IS
      WRITE (MSG2(14:18),'(I5)') ILX
      WRITE (MSG2(26:30),'(I5)') ISX
      CALL XVMESSAGE(MSG1,' ')
      CALL XVMESSAGE(MSG2,' ')
      RETURN
C
C        POSITION CURSOR AT SPECIFIED COORDINATES (SCREEN)
200   IERR = XDCSET(DUNIT,1,IS,IL)
      RETURN
C
C        POSITION CURSOR AT SPECIFIED COORDINATES (PICTURE)
300   IL=IL-SL+SLDS
      IS=IS-SS+SSDS
      IF(IL.LT.1 .OR. IL.GT.NLDS)  GO TO 398
      IF(IS.LT.1 .OR. IS.GT.NSDS)  GO TO 398
      IERR = XDCSET(DUNIT,1,IS,IL)
      RETURN
398   CALL XVMESSAGE('SPECIFIED COORDINATES NOT DISPLAYED',' ')
      RETURN
      END
C
C*******************************************************************
	SUBROUTINE SORTX(BUF,N)
C-----THIS ROUTINE WILL SWAP THE HALFWORDS OF THE FULLWORD BUFFER
C-----SO THAT VAX WILL SORT LIKE THE IBM.

        INTEGER*2 BUF(2,N)
        INTEGER*2 BUFVAL1(40000), BUFVAL2(40000)
        INTEGER*4 BUFVAL3(40000)
        INTEGER*4 BUFNDX1(40000)
C
        DO 100 I=1,N
          BUFVAL3(I) = ((BUF(1,I)*32768) + BUF(2,I))
          BUFVAL1(I) = BUF(1,I)
          BUFVAL2(I) = BUF(2,I)
          BUFNDX1(I) = I
100     CONTINUE

        CALL ISORTP(BUFVAL3,1,N,BUFNDX1)

        DO 200 I=1,N
          II = BUFNDX1(I)
          BUF(1,I) = BUFVAL1(II)
          BUF(2,I) = BUFVAL2(II)
200     CONTINUE
c
C	INTEGER*2 BUF(2,N),J
C
C	DO 100 I=1,N
C	   J = BUF(1,I)
C	   BUF(1,I) = BUF(2,I)
C	   BUF(2,I) = J
C100	CONTINUE
C
C	CALL ISORT(BUF, 1, N)
C
C	DO 200 I=1,N
C	   J = BUF(1,I)
C	   BUF(1,I) = BUF(2,I)
C	   BUF(2,I) = J
C200	CONTINUE
C
	RETURN
	END
C**********************************************************************
C
c        open_device
c
c         the devopen call is the first call that must be
c         made to the d routines. it will open the required
c         unit, configure them as required,
c         and activate them so that they can be read to and
c         from. the graphics plane is set to 4 and turned on.
c         a font is read in; character height is specified;
c         and text angle rotation is set to 0.
c
c         calling sequence ( iunit )
c         where :
c                iunit - device logical unit no.
c
          SUBROUTINE OPEN_DEVICE( IUNIT )

      COMMON/XDDEV/ NLUTS, NIMPS, MAXLINES, MAXSAMPS, IGRAPH,
     &              NCURS, GPLANE, gdn
          INTEGER  H, W, IUNIT
          INTEGER  CSETUP(4), C, U, IFORM, IBLINK, ICONOFF
          INTEGER  GPLANE, NLUTS, NIMPS, MAXSAMPS, XDSGRAPH
          INTEGER  IGRAPH, NCURS, NINTIO, SECTION, LMAX, SMAX
          INTEGER  XDSSECTION, MAXLINES
          INTEGER  gdn
          LOGICAL  FLAG, CAUTO
          INTEGER  XDEACTION, XDDUNIT, XDDOPEN, XDDACTIVATE
          INTEGER  XDDCONFIGURE, XDTFONT, XDTSIZE, XDDINFO
          INTEGER  XDTROTATE, XDGON, XDLRAMP, XDLCONNECT
          INTEGER  XDGCONNECT, XDGLINIT, xdgcolor
          REAL     S, ANGLE

          DATA C / 1 /, CSETUP / 3, 0, 0, 0/
          DATA H / 7 /, S / 1.0 /
          DATA IFORM / 0 /, CAUTO / .true. /
          DATA IBLINK / 0 /, ICONOFF / 0 /
          DATA SECTION /1/
          DATA W / 1 /

          U = IUNIT
c
c         open unit u
c
          IERR = XDEACTION( 2, 2, 3 )
          IERR = XDDUNIT( U )
          IERR = XDDOPEN( U )
c
c         activate the display unit so that we can write on it
c
          FLAG = .TRUE.
          IERR = XDDACTIVATE( U, FLAG )
c
c         now configure the display (csetup is all 0's - default)
c
          IERR = XDDCONFIGURE( U, CSETUP )
c
c         find out what type of device we have
c
          IERR = XDDINFO( U, 3, 1, NLUTS )
          IERR = XDDINFO( U, 4, 1, NIMPS )
          IERR = XDDINFO( U, 5, 1, MAXLINES )
          IERR = XDDINFO( U, 6, 1,  MAXSAMPS )
          IERR = XDDINFO( U, 30, 1, IGRAPH )
          IERR = XDDINFO( U, 48, 1, NCURS )
          IERR = XDDINFO( U, 60, 1, NINTIO )
          LMAX = MAXLINES
          SMAX = MAXSAMPS
c
c         read in a font file
c
          IFONT = 1
          IERR  = XDTFONT(IFONT)
c
c         set the initial size
c
          IF ( LMAX .LE. 512 ) THEN
            H = 7
          ELSE
            H = 14
          END IF
          IERR = XDTSIZE(H,S)
c
c         rotate at 0 degrees
c
          ANGLE = 0.0
          IERR = XDTROTATE( ANGLE )
c
c         turn on the cursor
c
          IF ( NCURS .GT. 0 ) THEN
           ICONOFF = 1
           IERR = XDCON( U, C, IFORM, IBLINK )
          END IF
c
c         and the ramps
c
          DO N1 = 1, NLUTS
           NSECTION = XDSSECTION( U, N1)
           IERR = XDLRAMP ( U, N1, NSECTION )
           IERR = XDGLINIT( U, NSECTION)
           GPLANE = XDSGRAPH(U)
           IERR = XDLCONNECT ( U, GPLANE, N1, NSECTION, .FALSE. )
c            IERR = XDLCONNECT ( U, N1, N1, NSECTION, .FALSE. )
          END DO
c
c         connect the graphics plane to image plane
c
          IF ( IGRAPH .GT. 0 ) THEN
           GPLANE = XDSGRAPH (U)
           IERR = XDDINFO ( U, 35, 1, SECTION)
           IERR = XDGCONNECT (U, GPLANE, SECTION, .FALSE. )
c
c          turn on the graphics overlay plane
c
           gdn=xdgcolor(u,'white')
           IERR = XDGON (U)
          END IF
c
          IUNIT = U
          RETURN
          END
C
C**********************************************************************
C
c	configure_device
c
c	configure the device given a number of
c	lines and samples.  If the lines and samples are 0,
c	the the default configuration for the device is used
c	and the number of lines and samples are set to the
c	appropriate values.  Otherwise the device will be
c	configured to one of the following if it is available:
c		512x512 when lines=512 and samples=512
c		640x480 when lines=480 and samples=640
c		1024x1024 when lines=1024 and samples=1024
c	If the given lines and samples do not match any of
c	the above, the device's default is used but the values
c	of lines and samples are not changed.
c
      SUBROUTINE CONFIGURE_DEVICE( LINES, SAMPLES, IUNIT )

      CHARACTER*100 MSG
      CHARACTER*30 CTBL0(3)/ ' Video Output = 512x512       ',
     -                       ' Video Output = 1024x1024     ',
     -                       ' Video Output = 640x480       '/
      CHARACTER*30 CTBL1,CTBL2,CTBL3,CTBL4,CTBL5,CTBL6
      CHARACTER*30 CTBL7A/' GRAPHICS PLANE AVAILABLE     '/
      CHARACTER*30 CTBL7B/' GRAPHICS PLANE NOT AVAILABLE '/
      CHARACTER*30 CTBL7C/' GRAPHICS WILL BE PLACED ON   '/
      CHARACTER*30 CTBL7D/'       IMAGE PLANE 1          '/
      INTEGER  H,CSETUP(4), OUTMODES, CURRD3, SECTION, U
      INTEGER  GPLANE, NLUTS, NIMPS, MAXSAMPS, MAXLINES
      INTEGER  IGRAPH, NCURS, NINTIO, gdn
      INTEGER  RED(256), GREEN(256), BLUE(256)
      REAL     S
      INTEGER XDDCONFIGURE, XDGCONNECT, XDTSIZE, XDDINFO
      LOGICAL BTEST
c
      COMMON/XDDEV/ NLUTS, NIMPS, MAXLINES, MAXSAMPS, IGRAPH,
     &              NCURS, GPLANE, gdn
      DATA CSETUP / 3, 0, 0, 0 /
      DATA RED   / 0,255*255 /
      DATA GREEN / 0,255*255 /
      DATA BLUE / 0,255*255 /
      DATA H / 7 /, S / 1.0 /

      U = IUNIT
      IERR = XDDINFO( U, 35, 1, SECTION)
      IERR = XDDINFO(U, 7, 1, OUTMODES )
      IF ((LINES.EQ.1024).AND.(SAMPLES.EQ.1024)) THEN
       IF ( BTEST(OUTMODES,9) ) THEN
         CSETUP(2) = 2
         CSETUP(3) = 2
       ELSE
         CALL XVMESSAGE('1024X1024 Output Not Available ',' ')
       END IF
      ELSE IF ((LINES.EQ.480).AND.(SAMPLES.EQ.640)) THEN
       IF ( BTEST(OUTMODES,10) ) THEN
         CSETUP(2) = 2
         CSETUP(3) = 3
       ELSE
         CALL XVMESSAGE('640x480 Output Mode Not Available ',' ')
       END IF
      ELSE IF ((LINES.EQ.512).AND.(SAMPLES.EQ.512)) THEN
       IF ( BTEST(OUTMODES,8) ) THEN
         CSETUP(2) = 1
         CSETUP(3) = 1
       ELSE
         CALL XVMESSAGE('512x512 Output Mode Not Available ',' ')
       END IF
      ELSE
       CSETUP(1) = 0
       CSETUP(2) = 0
       CSETUP(3) = 0
       CSETUP(4) = 0
       IF ( (LINES .NE. 0) .AND. (SAMPLES.NE.0) ) THEN

C	CALL XVMESSAGE('Unrecognized Output Size, Display Default
C     &                    Used ', ' ')
        CALL XVMESSAGE('Unrecognized Output Size, Display Default Used ', ' ')
       END IF
      END IF
c
c         now configure the display
c
          IERR = XDDCONFIGURE (U, CSETUP)
c
c         find out what type of device we have
c
          IERR = XDDINFO ( U, 3, 1, NLUTS )
          IERR = XDDINFO ( U, 4, 1, NIMPS )
          IERR = XDDINFO ( U, 5, 1, MAXLINES )
          IERR = XDDINFO ( U, 6, 1,  MAXSAMPS )
          IERR = XDDINFO ( U, 12, 1, CURRD3 )
          IERR = XDDINFO ( U, 30, 1, IGRAPH )
          IERR = XDDINFO ( U, 34, 1, GPLANE )
          IERR = XDDINFO ( U, 48, 1, NCURS )
          IERR = XDDINFO ( U, 60, 1, NINTIO )
c
c         print out what we have
c
          CALL XVMESSAGE(' ',' ')
          CALL XVMESSAGE('Display Device Characteristics',' ')
          WRITE(MSG,50) CTBL0(CURRD3)
 50       FORMAT(A30)
          WRITE (CTBL1, 100) NLUTS
100       FORMAT(' No. of LUTs =     ',I2)
          WRITE (CTBL2, 200) NIMPS
200       FORMAT(' No. of IMPs =     ',I2)
          WRITE (CTBL3, 300) MAXLINES
300       FORMAT(' No. of LINES =    ',I4)
          WRITE (CTBL4, 400) MAXSAMPS
400       FORMAT(' No. of SAMPS =    ',I4)
          WRITE (CTBL5, 500) NCURS
500       FORMAT(' No. of CURSORS =  ',I2)
          WRITE (CTBL6, 600) NINTIO
600       FORMAT(' No. of IO DEVS =  ',I2)
          CALL XVMESSAGE(MSG,' ')
          CALL XVMESSAGE(CTBL1,' ')
          CALL XVMESSAGE(CTBL2,' ')
          CALL XVMESSAGE(CTBL3,' ')
          CALL XVMESSAGE(CTBL4,' ')
          CALL XVMESSAGE(CTBL5,' ')
          CALL XVMESSAGE(CTBL6,' ')

          IF (IGRAPH .EQ. 1) THEN
           CALL XVMESSAGE(CTBL7A,' ')

          ELSE
           CALL XVMESSAGE(CTBL7B,' ')
           CALL XVMESSAGE(' ',' ')
           CALL XVMESSAGE(CTBL7C,' ')
           CALL XVMESSAGE(CTBL7D,' ')

           GPLANE = 1

          END IF
          CALL XVMESSAGE(' ',' ')

	IF ( (LINES.EQ.0).AND.(SAMPLES.EQ.0) ) THEN
         LINES = MAXLINES
         SAMPLES = MAXSAMPS
        END IF
c
c         connect the graphics plane to image plane
c
          IF ( IGRAPH .GT. 0 ) THEN
           IERR = XDGCONNECT(U, GPLANE, SECTION, .FALSE.)
          END IF
        LMAX = LINES
        SMAX = SAMPLES
        IF (LMAX.LE.512) THEN
           H = 7
        ELSE
           H = 14
        END IF
        IERR = XDTSIZE (H,S)
	RETURN
        END
C
C**********************************************************************
C
c        CLOSE_DEVICE
c
c         to deactivate the ability to modify the display unit u
c         and to deallocate it for the next user
c
c
	 SUBROUTINE CLOSE_DEVICE(IUNIT)
c
c        deactivate the device
c
         INTEGER U
         INTEGER XDDCLOSE, XDDACTIVATE
         LOGICAL FLAG

         U = IUNIT
         FLAG = .FALSE.
         IERR = XDDACTIVATE ( U, FLAG)
c
c        now close unit
c
         IERR = XDDCLOSE(U)
c
         RETURN
         END
C
C**********************************************************************
C
c        bw_mode
c
c         this is the routine that connects image 1 to lut 1
c         2, and 3 and turns on the linear ramps.
c
          SUBROUTINE BW_MODE(IUNIT)
c
          INTEGER U, N1, SECTION, NLUTS
          INTEGER XDSSECTION,XDSGRAPH,PLANE
          INTEGER XDLCONNECT, XDLRAMP, XDDINFO

          U = IUNIT
          PLANE = XDSGRAPH(U)
          IERR = XDDINFO ( U, 3, 1, NLUTS )

          DO N1 = 1, NLUTS
           SECTION = XDSSECTION(U,N1)
           ICOLOR = 0
           IERR = XDLCONNECT (U,1,N1,SECTION, .FALSE.)
c
c          and the ramp
c
           IERR = XDLRAMP (U,N1,SECTION)
          END DO
         RETURN
         END
C
C**********************************************************************
C
c        AUTOTRACKING_MODE
c
c         this is the routine that turns autotracking on
c
          SUBROUTINE AUTOTRACKING_MODE( ON, IUNIT )
          LOGICAL ON
          INTEGER XDCAUTOTRACK, XDDINFO
          INTEGER U, NINTIO, C
          DATA  C /1/

          U = IUNIT
          NINTIO=0
          IERR=0
          IERR = XDDINFO( U, 60, 1, NINTIO )
c
          IF ( NINTIO .GT. 0 ) THEN
           IF ( ON ) THEN
              AUTOFLAG = 1
           ELSE
              AUTOFLAG = 0
           END IF
           IERR = XDCAUTOTRACK ( U,C,0,AUTOFLAG)
          END IF
          RETURN
          END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
        PROGRAM CPEX02
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
        PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C Declare an array to hold the data to be contoured.
C
        DIMENSION ZDAT(33,33)
C
C Declare the required real and integer workspaces.
C
        DIMENSION RWRK(5000),IWRK(1000)
C
C Declare an array to hold an area map.
C
        DIMENSION IAMA(20000)
C
C Declare the arrays needed by ARSCAM for x/y coordinates.
C
        DIMENSION XCRA(1000),YCRA(1000)
C
C Declare the arrays needed by ARSCAM for area and group identifiers.
C
        DIMENSION IARA(10),IGRA(10)
C
C Declare an array to hold the GKS "aspect source flags".
C
        DIMENSION IASF(13)
C
C Declare the routine which will draw contour lines, avoiding labels.
C
        EXTERNAL DRAWCL
C
C Declare the routine which does the shading.
C
        EXTERNAL SHADER
C
C Dimension a character variable to hold plot labels.
C
        CHARACTER*11 LABL
C
C Initialize the values in the aspect-source-flag array.
C
        DATA IASF / 13*1 /
C
C Open GKS.
C
        CALL GOPKS (IERRF, ISZDM)
        CALL GOPWK (IWKID, LUNIT, IWTYPE)
        CALL GACWK (IWKID)
C
C Turn off the clipping indicator.
C
        CALL GSCLIP (0)
C
C Set all the GKS aspect source flags to "individual".
C
        CALL GSASF (IASF)
C
C Turn on the drawing of the grid edge ("contour line number -1") and
C thicken it somewhat.
C
        CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',-1)
        CALL CPSETI ('CLU - CONTOUR LEVEL USE FLAG',1)
        CALL CPSETR ('CLL - CONTOUR LEVEL LINE WIDTH',2.)
C
C Turn on the positioning of labels by the penalty scheme and provide a
C little more room for X and Y coordinates defining contour lines, so
C as not to have labels right next to each other on a contour line.
C
        CALL CPSETI ('LLP - LINE LABEL POSITIONING',3)
        CALL CPSETI ('RWC - REAL WORKSPACE FOR CONTOURS',200)
C
C Turn on the drawing of the high and low label boxes.
C
        CALL CPSETI ('HLB - HIGH/LOW LABEL BOX FLAG',1)
C
C Tell CONPACK to delete high/low labels which overlap the informational
C label or another high/low label, but to move those which overlap the
C edge inward a little.
C
        CALL CPSETI ('HLO - HIGH/LOW LABEL OVERLAP FLAG',11)
C
C Make all CONPACK-written characters a little bigger.
C
        CALL CPSETR ('CWM - CHARACTER WIDTH MULTIPLIER',1.25)
C
C Move the informational label into the lower left-hand corner and
C turn on the box around it, making the box thicker than normal.
C
        CALL CPSETR ('ILX - INFORMATIONAL LABEL X POSITION',.02)
        CALL CPSETR ('ILY - INFORMATIONAL LABEL Y POSITION',.02)
        CALL CPSETI ('ILP - INFORMATIONAL LABEL POSIIONING',-4)
        CALL CPSETI ('ILB - INFORMATIONAL LABEL BOX',1)
        CALL CPSETR ('ILL - INFORMATIONAL LABEL LINE WIDTH',2.)
C
C Change the text of the informational label.
C
        CALL CPSETC ('ILT - INFORMATIONAL LABEL TEXT',
     +               'CONTOUR FROM $CMN$ TO $CMX$ BY $CIU$ (X $SFU$)')
C
C Do four different plots, one in each quadrant.
C
        DO 102 IPLT=1,4
C
C Generate an array of test data.
C
          CALL GENDAT (ZDAT,33,33,33,20,20,.000025,.000075)
C
C Move the viewport to the proper quadrant.
C
          CALL CPSETR ('VPL - VIEWPORT LEFT EDGE',
     +                 .0250+.4875*REAL(MOD(IPLT-1,2)))
          CALL CPSETR ('VPR - VIEWPORT RIGHT EDGE',
     +                 .4875+.4875*REAL(MOD(IPLT-1,2)))
          CALL CPSETR ('VPB - VIEWPORT BOTTOM EDGE',
     +                 .0250+.4875*REAL((4-IPLT)/2))
          CALL CPSETR ('VPT - VIEWPORT TOP EDGE',
     +                 .4875+.4875*REAL((4-IPLT)/2))
C
C Specify how the scale factor is to be selected.
C
          CALL CPSETI ('SFS - SCALE FACTOR SELECTION',-IPLT)
C
C Initialize the drawing of the contour plot.
C
          CALL CPRECT (ZDAT,33,33,33,RWRK,5000,IWRK,1000)
C
C Force the selection of contour levels, so that associated quantities
C may be tweaked.
C
          CALL CPPKCL (ZDAT,RWRK,IWRK)
C
C Increase the line width for labelled levels and turn off the area
C identifiers for all levels.
C
          CALL CPGETI ('NCL - NUMBER OF CONTOUR LEVELS',NCLV)
C
          DO 101 ICLV=1,NCLV
            CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',ICLV)
            CALL CPGETI ('CLU - CONTOUR LEVEL USE FLAG',ICLU)
            IF (ICLU.EQ.3) THEN
              CALL CPSETI ('CLL - CONTOUR-LINE LINE WIDTH',2)
            END IF
            CALL CPSETI ('AIA - AREA IDENTIFIER ABOVE LEVEL',0)
            CALL CPSETI ('AIB - AREA IDENTIFIER BELOW LEVEL',0)
  101     CONTINUE
C
C Add two new levels for which no contour lines are to be drawn, but
C between which shading is to be done.
C
          NCLV=NCLV+2
          CALL CPSETI ('NCL - NUMBER OF CONTOUR LEVELS',NCLV)
C
          CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',NCLV-1)
          CALL CPSETR ('CLV - CONTOUR LEVEL VALUE',.000045)
          CALL CPSETI ('CLU - CONTOUR LEVEL USE FLAG',0)
          CALL CPSETI ('AIA - AREA IDENTIFIER ABOVE LEVEL',1)
          CALL CPSETI ('AIB - AREA IDENTIFIER BELOW LEVEL',2)
          CALL CPSETI ('PAI - PARAMETER ARRAY INDEX',NCLV)
          CALL CPSETR ('CLV - CONTOUR LEVEL VALUE',.000055)
          CALL CPSETI ('CLU - CONTOUR LEVEL USE FLAG',0)
          CALL CPSETI ('AIA - AREA IDENTIFIER ABOVE LEVEL',3)
          CALL CPSETI ('AIB - AREA IDENTIFIER BELOW LEVEL',1)
C
C Draw the contour plot.
C
          CALL ARINAM (IAMA,20000)
          CALL CPLBAM (ZDAT,RWRK,IWRK,IAMA)
          CALL CPCLDM (ZDAT,RWRK,IWRK,IAMA,DRAWCL)
          CALL CPLBDR (ZDAT,RWRK,IWRK)
          CALL CPCLAM (ZDAT,RWRK,IWRK,IAMA)
          CALL ARSCAM (IAMA,XCRA,YCRA,1000,IARA,IGRA,10,SHADER)
C
C Compute and print statistics for the plot and label it.
C
          LABL='EXAMPLE 2-'//CHAR(ICHAR('0')+IPLT)
          CALL CAPSAP (LABL,IAMA,20000)
          CALL LABTOP (LABL,.017)
C
  102   CONTINUE
C
C Put a boundary line at the edge of the plotter frame.
C
        CALL BNDARY
C
C Advance the frame.
C
        CALL FRAME
C
C Close GKS.
C
        CALL GDAWK (IWKID)
        CALL GCLWK (IWKID)
        CALL GCLKS
C
C Done.
C
        STOP
C
      END

      SUBROUTINE DRAWCL (XCS,YCS,NCS,IAI,IAG,NAI)
C
C This version of DRAWCL draws the polyline defined by the points
C ((XCS(I),YCS(I)),I=1,NCS) if and only if none of the area identifiers
C for the area containing the polyline are negative.  The dash package
C routine CURVED is called to do the drawing.
C
        DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C Turn on drawing.
C
        IDR=1
C
C If any area identifier is negative, turn off drawing.
C
        DO 101 I=1,NAI
          IF (IAI(I).LT.0) IDR=0
  101   CONTINUE
C
C If drawing is turned on, draw the polyline.
C
        IF (IDR.NE.0) CALL CURVED (XCS,YCS,NCS)
C
C Done.
C
        RETURN
C
      END

      SUBROUTINE SHADER (XCS,YCS,NCS,IAI,IAG,NAI)
C
C This version of SHADER shades the polygon whose edge is defined by
C the points ((XCS(I),YCS(I)),I=1,NCS) if and only, relative to edge
C group 3, its area identifier is a 1.  The package SOFTFILL is used
C to do the shading.
C
        DIMENSION XCS(*),YCS(*),IAI(*),IAG(*)
C
C Define workspaces for the shading routine.
C
        DIMENSION DST(1100),IND(1200)
C
C Turn off shading.
C
        ISH=0
C
C If the area identifier for group 3 is a 1, turn on shading.
C
        DO 101 I=1,NAI
          IF (IAG(I).EQ.3.AND.IAI(I).EQ.1) ISH=1
  101   CONTINUE
C
C If shading is turned on, shade the area.  The last point of the
C edge is redundant and may be omitted.
C
        IF (ISH.NE.0) THEN
          CALL SFSETI ('ANGLE',45)
          CALL SFSETR ('SPACING',.006)
          CALL SFWRLD (XCS,YCS,NCS-1,DST,1100,IND,1200)
          CALL SFSETI ('ANGLE',135)
          CALL SFNORM (XCS,YCS,NCS-1,DST,1100,IND,1200)
        END IF
C
C Done.
C
        RETURN
C
      END

ext: f

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
Subroutine iilist
  Implicit Double Precision (A-H, O-Z)
  Parameter (maxptn=400001)
  Common /para1/mul
  Common /ilist1/iscat, jscat, next(maxptn), last(maxptn), ictype, icsta(maxptn), nic(maxptn), icels(maxptn)
  Common /ilist2/icell, icel(10, 10, 10)
  Common /ilist4/ifmpt, ichkpt, indx(maxptn)
  Common /ilist5/ct(maxptn), ot(maxptn), tlarge
  Common /ilist6/t, iopern, icolln
  Save
  iscat = maxptn
  jscat = maxptn
  Do i = 1, mul
     next(i) = 0
     last(i) = 0
     icsta(i) = 0
     nic(i) = 0
     icels(i) = 0
  End Do
  icell = 0
  Do i1 = 1, 10
     Do i2 = 1, 10
        Do i3 = 1, 10
           icel(i1, i2, i3) = 0
        End Do
     End Do
  End Do
  ichkpt = 0
  ifmpt = 1
  Do i = 1, mul
     ct(i) = tlarge
     ot(i) = tlarge
  End Do
  iopern = 0
  icolln = 0
  t = 0.D0
  Return
End Subroutine iilist

max_stars_repo_name: xiaohaijin/AMPT

max_issues_repo_name: xiaohaijin/AMPT

max_forks_repo_name: xiaohaijin/AMPT


text:
Sycamore Lane is one of the main northsouth thoroughfares in Davis. From its origin at County Road 100a in North Davis, it passes the western terminus of Alvarado Avenue, crosses Covell Boulevard, terminates Villanova Drive, and continues on to its southern terminus at Russell Boulevard and UC Davis. Bus service along North Sycamore Lane is provided by Unitrans’ G Bus Line (or the J Bus Line J line if you’re headed to the Silo) and South Sycamore Lane is provided by Unitrans B Bus Line.  Sycamore Lane is one of the Davis Street Names Themes street names with themes. In addition, the intersection of Sycamore and Russell Boulevard is home to one of the citys Bike Signal bike signals.

Businesses and points of interest on Sycamore Lane include the following, from north to south:
  Davis Waldorf School 3100 Sycamore Lane
  Davis Well 27
  Covell Drainage Channel Trail (where the channel crosses under Sycamore)
  Temescal Apartments 2477 Sycamore Lane
  Chaparral Apartments 2689 Sycamore Lane
  Covell Drainage Channel Trail (southwest end)
  The Marketplace
  Sequoia Apartments 2255 Sycamore Lane
  Pepperwood Apartments 2222 Sycamore Lane
  Sycamore Park 1313 Sycamore Lane
  Robert E. Willett School 1207 Sycamore Lane
  University Commons Apartments 707 Sycamore Lane
  Sycamore Lane Garden Apartments 614 Sycamore Lane
  University Court Apartments 515 Sycamore Lane, 545 Sycamore Lane
  University Mall

To help orient yourself, please visit our page on navigating Davis.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Fluoride is a either a safe, naturally occurring element that helps prevent tooth decay or a malicious/foolish ploy by a conspiracy. Either way, water in Davis is not supplemented with fluoride, so those who can afford it can have it either way, choosing to add fluoride into their daily regimen or not.  The natural levels of fluoride in Davis tap water are about 0.2 ppm, which is 1/3 the optimal level for the health benefits.  Sacramento and Roseville supplement the Davis Water Wells municipal water supplies to optimal fluoride levels.  Recent (late 2010) government evaluations have changed the recommended optimal levels of fluoride in drinking water from 1ppm to 0.7ppm.  This change was based upon increasing levels of mild fluorosis in children and adolescents.  Mild fluorosis causes minor (but harmless) visual imperfections in the teeth.

The city council considered a fluoridation project in 2013, but rejected it in an October vote of the same year. http://www.sacbee.com/2013/10/02/5789826/davisrejectsfluorideincity.html Link More recent developments regarding the fluoridation of drinking water include a movie: http://aninconvenienttooth.org/ An Inconvenient Tooth  movie

Black tea and green tea are high in fluoride. Tea leaves of the tea plant (Camellia sinensis) contain a high concentration of fluoride and aluminum.

In fact, one woman suffered from high levels of fluoride because she made daily ice tea with a huge amount of tea bags over several years. She received an xray that showed dense areas in her skeleton. At first, doctors thought that she had bone cancer, however they soon discovered that it was due to excessive fluoride consumption. Over time, the body will eliminate the excess fluoride and the bones will return to normal due to the normal breakdown and renewal of bone material.

Fluoride is found in many everyday sources from tea, to orange juice from concentrate, to apple juice from concentrate, to soda, to bottled drinks, to milk, to cheese, to yogurt, etc. Soda is made with water from municipal water supplies that are fluoridated. Milk, cheese, ice cream, and yogurt come from cows that drink municipal water that is fluoridated. Many other foods are made with water that comes from fluoridated municipal water supplies. Animals raised for food consumption drink water from fluoridated water supplies. Crops are watered with fluoridated water. There is fluoride everywhere in our food supply.  Of course, the fact that it is ubiquitous says nothing about whether it is safe or not because there are too many confounding factors and no control group; you need a control group to compare outcomes for those who are consuming fluoride in some specified amount to those who are not consuming fluoride.

Some people say that there are other concerns about our water and food supply that are much more important such as lead and arsenic in bottled fruit juices from concentrate or chickens that are fed arsenic to fatten them up.

Due to budget cuts, Sacramento may stop fluoridating the municipal water. By doing this, the city can save about $1 million per year. However, some counter that in the long run this will likely increase the need for state/federal funded dental programs because the fraction of a second a fluoride ion contacts a tooth while passing through ones mouth considerably increases dental hygiene.

Many of the factual/biased pieces of information on this page are taken from the Sacramento District Dental Society http://www.sdds.org/Fluoridation.htm website
For a healthy counterbalance in your water fluoridation opinions/knowledge , http://www.fluoridealert.org/issues/water/ look here

 Facts About Fluoride

  Fluoridation is the single most effective public health measure to prevent tooth decay and to improve oral health over a lifetime.
  More than 60 years of scientific research has found that people living in communities with fluoridated water have healthier teeth and significantly fewer cavities than people living where the water is not fluoridated.
  Today, more than 162 million people in the United States drink fluoridated water – 66 percent of the U.S. population. In California, only 29 percent of the cities with public water supplies fluoridate.
  Studies comparing the decay experience of people living in fluoridated versus fluoridedeficient areas demonstrate that adult who consume fluoridated water have a lower prevalence of dental decay.
  The cost of fluoridation for a lifetime of protection is approximately $50  less than the cost to fill just one cavity.
  The California Dental Association has estimated that every dollar invested in fluoridation saves about $140 in dental bills.
  DentiCal costs California taxpayers approximately $700 million every year, a significant part of which paid for treatments that could easily have been prevented with fluoridation.
  More than 50 percent of today’s firstgraders are cavityfree due to fluoridation.
  In adults, fluoride can reduce cavities by up to 40 percent, while strengthening tooth enamel and preventing root and gum disease – helping adults keep their teeth for a lifetime.
  The American Medical Association, American Dental Association, the Centers for Disease Control, the National Institutes of Health, and the World Health Organization are among a myriad of major state, national and international health service organizations that strongly endorse the use of fluoridated water.
  All water contains some fluoride naturally, but community water fluoridation, which has been safely consumed by the public for over 60 years, is the process of adjusting the fluoride content of fluoridedeficient water to the recommended level for optimal dental health.
  Fluoride is a mineral naturally occurring in almost all food and water supplies and comes from the element fluorine, the 13th most abundant element in the earths crust.

 Myths about Fluoride

Myth: Fluoridation causes a decrease in bone health.
 Fact: Current research indicates that when used consistently in appropriate doses fluoride  stimulates the formation of bone, increases bone formation earlier, and increases spinal bone density.  Research studies also show that fluoride may help rebuild bone loss in postmenopausal women suffering from osteoporosis. However, in very large doses, fluoride can be detrimental to bone health and cause gastrointestinal problems.

Myth: In communities where fluoride is added to the drinking water there is an increase in cancer rates.
 Fact: More than fifty studies have evaluated the possibility of an association between fluoride and cancer and found no relationship between community water fluoridation and cancer.  Several independent expert panels of epidemiologists have reviewed the relevant scientific literature and agree that there is NO credible evidence for an association between either naturally occurring fluoride or adjusted fluoride in drinking water and risk of cancer in humans.

Myth: Fluoride is a poison.
 Fact: Fluoride is NOT a poison at the concentrations found in optimally fluoridated water.  Like minerals such as zinc and iron, fluoride is classified by the National Research Council as an important trace element in human nutrition. Many elements and minerals can be poisonous in the proper concentrations. With water fluoridated at 1ppm , an average adult would have to drink 660 gallons in 24 hours for it to be considered a poison.  Consuming very large quantities of anything over several years could have adverse health effects.

Myth: There are harmful levels of contaminants in the fluorides used for water fluoridation.
 Fact: Contaminants are pervasive in chemicals, but the contaminants found in the chemicals used for water fluoridation are controlled and regulated for volume and amount, so as not to be deemed harmful by the EPA.  The United States Environmental Protection Agency regulates the maximum permissible level of contaminants in drinking water.

 FAQ

What is fluoride and how does it reduce tooth decay?

 Fluoride is a naturally occurring element that prevents tooth decay when ingested systemically or applied to teeth topically.

 The fluoride ion comes from the element fluorine. Fluorine, the 13th most abundant element in the earths crust, is never encountered in its free state in nature. It exists only in combination with other elements as a fluoride compound. It is found in this form as a constituent of minerals in rocks and soil everywhere. Water passes over rock formations containing fluoride and dissolves these compounds, creating fluoride ions. The result is that small amounts of soluble fluoride ions are present in all water sources, including the oceans. Fluoride is present to some extent in all foods and beverages, in various concentrations.

 Studies comparing the decay experience of people living in fluoridated versus fluoridedeficient areas demonstrate that adults who consume fluoridated water have a lower prevalence of dental decay.

 Fluoride acts via 3 methods, all of these methods are achieved with topical fluoride:

 1. Fluoride replaces the hydroxide ion in the tooth enamel.  Tooth enamel is made of hydroxyapatite, replacing the hydroxide ion with fluoride ion results in a stronger bond between the ions.  The tooth structure is therefore, more resistant to acid demineralization.
 1. Fluoride helps to rebuild enamel by sequestering calcium and phosphate ions from saliva.  The fluoride ion binds to the enamel rods and facilitates the natural remineralization process (repairing of demineralized enamel from acid attack) that naturally occurs in saliva.
 1. Fluoride interferes with the bacterial enzyme Enolase.  Fluoride interferes with cavity causing bacterial pathways, therefore disrupting the bacterias ability to metabolize sugar.

What is water fluoridation?
 All water contains some fluoride naturally. Water fluoridation is the process of adjusting the fluoride content of fluoridedeficient water to the recommended level for optimal dental health. In the United States, the optimum concentration for fluoride in the water has been established in the range of 0.7 to 1.2 parts per million (ppm).

Why have some individuals and groups objected to water fluoridation?
 Some people claim people oppose fluoridation out of fear and ignorance, several small but highly vocal groups were formed for the sole purpose of fighting fluoridation.  Most of these organizations, however, lack sufficient resources or expertise to have much impact outside of the individual communities where they are based.  Many people consider fluoridation mass medication and are opposed to this idea.  Other people believe that there are negative health effects from fluoride that outweigh the dental benefits.

 An entirely different group of people support the idea that fluorine does have clear health benefits, but object to the manner in which it is given.  The fluorine is good; the method of nonchoice application is a common way for small groups of people to decide and enforce their vision of what is for the good of all other individuals.  Historically, many horrors have been committed in the name of helping the masses without their consent, and those people find that fluoridating the public water supply is a fundamentally objectionable and extreme method of delivery for a comparably minor benefit.

Aren’t there other effective alternatives to community water fluoridation?

 Some people believe that there are effective alternatives to community water fluoridation. However, the fact is that while other communitybased methods of systematic and topical fluoride delivery (e.g., schoolbased fluoride mouth rinse or table programs) have been developed, none is as effective as community water fluoridation and none is free from financial constraints or other drawbacks. Alternatives to community water fluoridation remain useful only for populations significantly isolated from public water systems (e.g., those on private wells).  Other programs include fluoridatedsalt in some European and South American countries (much as how common table salt in the USA is typically supplemented with iodine), as well as even milkfluoridation programs aimed to help children in countries ranging from the UK to Russia.  Fluoridated toothpaste is considered to be very effective, but as mentioned, none of these programs are as effective as communitybased waterfluoridation at reaching those at highest risk and need.

Is tooth decay still a serious problem?

 Yes. Dental caries (tooth decay) continues to be a significant oral health problem which is preventable through a combination of measures.

 Tooth decay is, by far, the most prevalent and costly of oral health problems among all age groups.

 It is also the principle cause of tooth loss from early childhood through middle age, when tooth loss from periodontal disease is a major concern. However, caries continues to be problematic for middleaged and older adults, particularly root caries. In addition to its effects in the mouth, dental caries may affect general wellbeing by interfering with an individuals ability to eat certain foods and by impacting an individuals emotional and social wellbeing by causing pain and discomfort. Tooth decay, particularly in the front teeth, also can effect an individuals selfesteem by detracting from their appearance.

Do adults benefit from fluoridation?

 Yes. Research has shown that the caries preventive effects of fluoride are not limited to children. Adults obtain substantial benefits as well.

 Fluoride has both a systemic and topical effect and is beneficial to adults in two ways. The first is through the remineralization process, in which beginning carious lesions in the enamel fail to enlarge or may even reverse because of frequent exposure to small amounts of fluoride. The other protective benefit is in the prevention of root caries, a progressive lesion of the root surface, affecting adults with gingival recession.

 In addition to the direct benefits of successfully fighting tooth decay, water fluoridation has several indirect advantages to adults as well. These include reductions in pain from dental infections, fewer missing teeth, fewer abscessed teeth, reduced need for dentures, fewer cases of misaligned teeth caused by early tooth loss, and fewer school and working days lost due to dental disorders or visits to the dentist.

Is bottled water fluoridated?

 Bottled water does not contain fluoride unless it says so on the label. Some supermarkets do indeed carry 1 gallon water bottles with fluoride and these bottles are clearly marked with the word fluoride. Fluoridated bottled water is sold mostly in cities where the municipal water supply does not fluoridate their water. Most convenience stores dont carry the water with fluoride. It is easier to get fluoridated bottled water (5 gallon) through water delivery companies like Arrowhead.

I have a Brita filter  is it removing the fluoride from my water?

 Brita does not remove fluoride from the water. The only systems that do filter out fluoride use reverse osmosis.

Does my child need a fluoride prescription?

 Because Davis municipal water does not contain optimal fluoride, fluoride supplements are recommended for optimal dental health. Check with your childs dentist for his/her recommendation regarding a fluoride prescription. There are fluoride toothpastes with higher levels of fluoride that are available by prescription. These toothpastes are used for people who have tooth decay and want to avoid potential cavities that require fillings.

20100225 09:55:34 nbsp http://www.youtube.com/watch?v9aeSAsrsew#t5m38s Topicallyapplied fluoride doesnt prevent tooth decay. It does render teeth detectable by spy satellites. Users/hankim

20100226 06:12:12 nbsp Fluoride is neither a nutrient nor required for healthy teeth.  Ingesting fluoride does not reduce tooth decay; but does expose entire populations to fluorides adverse health effects.

An expert panel convened by the National Research Council, at the behest of the Environmental Protection Agency, reviewed recent scientific evidence concerning fluorides toxicity and reveals that fluoride, even at the low levels added to water supplies, can cause damage to bones, thyroid, teeth and can be harmful to kidney patients, babies and high water drinkers.  The NRC panel said that the maximum contaminant level goal of fluoride in public water supplies is too high to be protective of health and must be lowered.

At least three NRC panel members recommend that the MCLG of fluoride be as close to zero as possible Users/nyscof
    Davis water is 0.2 ppm.  The EPA has the MCLG at 4.0.  The controversy over the EPAs decision was that many people think 2.0ppm (or 3.0ppm) should have been the maximum.  Either way, Davis is far, far below the MCLG (thats 20 fold below the MCLG the EPA set, and 10 fold below the expected maximum).  And clearly, lower than the recommended levels.  In fact, the WHO and others have recommended removal of fluoride in places where its above the optimum dental benefit (which is some .7 to 1.2ppm).  Nonetheless, theyve all said fluoridation is beneficial.  Regarding fluoridation, there seems to be a general notion that its a United States oddity thats dangerous and not necessary.
    Take a look at the salt in your pantry.  Or next time you go to the supermarket.  The bulk of the salt used in the United States is iodinated.  Salt supplemented with iodine, it helps prevent thyroid issues and goiters, plain old table salt, right?  Well, some countries use fluoridated salt  ranging from Germany and France in Europe out to Columbia and Jamaica.  Other countries take a different approach and have some fluoridation programs aimed at children  the UK, Russia, Peru, Chile have milkfluoridation.  Milk!  The worldwide scientific consensus is that fluoridation is very, very good.  In the US you hear more about what if theres too much arguments and simply more from people who are simply scared of it. I tend to think this is simply unintentional ignorance.  Pretty much every firstworld country, as well as the WHO, have agreed that fluoridation is critical in dental care and preventing carries and decay.
   Water fluoridation is simply the easiest way to reach the most people, especially those at higher risk.  The only real scientific dissenters (other than the aforementioned 2.0 vs 3.0 vs 4.0 MCLG debates)  is that a few studies conclude that water fluoridation is unnecessary in areas where people have regular access to fluoridated toothpaste.  Again though, putting it in the water reaches the people that need it most.  To say that its not required for healthy teeth is at this point just simply not true, as decades of research and empirical data have shown. users/edwins ES

20100226 09:47:49 nbsp It is correct that fluoride does not need to be ingested to get its benefits, also it is not required for healthy teeth (but it sure helps).  Fluoride is not considered a nutrient, but is considered an important (not essential) trace element.  Topical fluoride DOES reduce tooth decay (There is absolutely NO debate about this) and ingesting fluoride provides fluoride ions for secretion into saliva for it to work its topical effects.  To see how fluoride works, see the above FAQ.  The benefits of fluoridation are primarily a public health measure, it primarily helps children who might otherwise receive poor oral health care.  I support public fluoridation, but I can understand and respect peoples opposition to it. Users/DagonJones

20110720 20:05:47 nbsp Is there any way to get high on fluoride? Sometimes that other dental drug gets boring. Users/ScottMeehleib

20110720 22:54:44 nbsp I took some fluoride when I was younger, it was tasteh! Users/StevenDaubert

20130502 21:28:37 nbsp The ADA no longer recommends blanket use of fluoride supplements for most children in unfluoridated areas, as they had recommended for decades.  In the November 2010 JADA they published their new recommendation which is to prescribe fluoride supplements only to children who are at high risk of caries and only after doing an assessment of their other sources of fluoride intake.  See full article here:  http://jada.ada.org/content/141/12/1480.full.pdf+html
 Users/BarbaraKing

20130504 21:15:14 nbsp This article is terrible. A good place to start reviewing water fluoridation is the article Systematic review of water fluoridation  BMJ. 2000 October 7; 321(7265): 855–859. http://www.ncbi.nlm.nih.gov/pmc/articles/PMC27492/ . The paper finds nonsignificant benefits in the metaanalysis, but concludes that most of the studies are of poor quality. We dont really know if it is of benefit, and we dont know how it harms people. We do know however that fluoride is toxic, and there is no nutritional
requirement for it by the body.

 Users/JoelBremson

20130924 09:49:50 nbsp Heres a statement by Dr. J. William Hirzy, Vice President of the EPA Headquarters Union where he says that the EPA asked to be taken off the ADAs list of supporters for fluoridation. According to him the toxicity of fluoride (presumably he means either sodium fluoride or hexafluorosilic acid, which are the types of fluoride used for water fluoridation) is between that of lead and arsenic, but the EPA has set a far higher limit on its safety level than for the other two.

http://www.youtube.com/watch?vhRLz4a7lDVM Users/IssacTrotts

20131010 12:42:09 nbsp I think this page contains very, very biased information. Unfortunately it is so much, I dont know where to start. Users/ConstantiaOomen

20131010 12:56:57 nbsp Please not that the city of Davis has REJECTED water fluoride, and please note that the information on this page is not the truth, the whole truth, and nothing but the truth: http://www.sacbee.com/2013/10/02/5789826/davisrejectsfluorideincity.html

Want to add a voice of reason: http://www.sacbee.com/2013/10/02/5789826/davisrejectsfluorideincity.html#comment1069577609 Link
James Reeves: The solution for the fluoridation issue is very simple.
SIMPLE SOLUTION:
1. Take the toxic waste fluoride chemical out of the drinking water.
2. It is still legal and available, so those who wish to take it can then put fluoride in their own glass of water.
3. Leave the rest of us out of it, giving everyone the freedom of choice.
PROBLEM SOLVED FOR EVERYONE.

  Users/ConstantiaOomen

I think the Dentist who commented a few comments up was truthful and objective with his comment ~SD


text:
!***********************************************************************
!                                                                      *
      SUBROUTINE GENRWF
!                                                                      *
!   Controls the computation of the subshell radial wavefunctions.     *
!                                                                      *
!   Call(s) to: [LIB92]: ALLOC, GETRSL, GETYN.                         *
!               [ERWF]: FRMHYD, FRMRWF, FRMTFP, PRTREM, SUMMRY,        *
!                       TFPOT.                                         *
!                                                                      *
!   Written by Farid A. Parpia            Last revision: 18 Dec 1992   *
!   Updated by Xinghong He                Last revision: 11 Nov 1997   *
!    for menu-driven and less questions
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:06:21   1/ 2/07
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE memory_man
      USE COUN_C
      USE DEF_C, ONLY: Z, C, NNNP
      USE DEFAULT_C
      USE GRID_C
      USE LEFT_C, ONLY: SET
      USE NPAR_C
      USE ORB_C
      USE WAVE_C, ONLY: PF, QF
      USE WHFROM_C, ONLY: SOURCE
      USE IOUNIT_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE getyn_I
      USE tfpot_I
      USE prtrem_I
      USE getrsl_I
      USE frmrwf_I
      USE frmtfp_I
      USE frmhyd_I
      USE summry_I
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , DIMENSION(NNNW) :: INDEX
      INTEGER :: J, I, K, NRADIAL, NSUBS, LOC
      REAL(DOUBLE) :: CON, FKK
      LOGICAL :: ALL, YES, MODIFY=.FALSE., EXISTED
      CHARACTER :: INFILE*128
!-----------------------------------------------

!
!   Set the threshold for node counting
!
      THRESH = 0.05
!
!   Set up the Thomas-Fermi potential
!
      CALL TFPOT
!
!   Allocate storage to the arrays that store the subshell
!   radial wavefunction arrays; initialise these and all
!   associated arrays
!
      CALL ALLOC (PF,NNNP,NW,'PF', 'GENRWF')
      CALL ALLOC (QF,NNNP,NW,'QF', 'GENRWF')

      CON = Z/C
      CON = CON*CON

      DO J = 1, NW
         SET(J) = .FALSE.
         SOURCE(J) = ' '
         PF(:N,J) = 0.D0
         QF(:N,J) = 0.D0

         K = ABS(NAK(J))
         IF (NPARM > 0) THEN
            GAMA(J) = DBLE(K)
         ELSE IF (NPARM == 0) THEN
            FKK = DBLE(K*K)
            IF (FKK >= CON) THEN
               GAMA(J) = SQRT(FKK - CON)
            ELSE
               WRITE (ISTDE, *) 'LODRWF: Imaginary gamma parameter ', 'for ', &
                  NP(J), NH(J), ' orbital;'
               WRITE (ISTDE, *) 'the point model for the nucleus ', &
                  'is inappropriate for Z > ', C, '.'
               STOP
            ENDIF
         ENDIF
      END DO
!
!   Write out the complete list of subshell radial wave functions
!
      CALL PRTREM (ALL)
!
! Direct to read radial functions till finish
!
  123 CONTINUE
      IF (.NOT.ALL) THEN
  234    CONTINUE
         WRITE (ISTDE, *)
         WRITE (ISTDE, *) 'Read subshell radial wavefunctions. ', &
            'Choose one below'
         WRITE (ISTDE, *) '    1 -- GRASP92 File'
         WRITE (ISTDE, *) '    2 -- Thomas-Fermi'
         WRITE (ISTDE, *) '    3 -- Screened Hydrogenic'

         READ (ISTDI, *) NRADIAL
         IF (NRADIAL<1 .OR. NRADIAL>3) THEN
            WRITE (ISTDE, *) NRADIAL, 'is not a valid choice, redo'
            GO TO 234
         ENDIF

         IF (NRADIAL == 1) THEN
  345       CONTINUE
            WRITE (ISTDE, *) 'Enter the file name (Null then "rwfn.out")'
            READ (ISTDI, '(A)') INFILE
            IF (LEN_TRIM(INFILE) == 0) INFILE = 'rwfn.out'

            INQUIRE(FILE=INFILE, EXIST=EXISTED)
            IF (.NOT.EXISTED) THEN
               WRITE (ISTDE, *) ' File "', INFILE(1:LEN_TRIM(INFILE)), &
                  '" does not exist, redo'
               GO TO 345
            ENDIF
         ENDIF

         WRITE (ISTDE, *) 'Enter the list of relativistic subshells:'
         OPEN(UNIT=734, FILE='tmp_734', STATUS='NEW')
         CALL GETRSL (INDEX, NSUBS)
         CLOSE(734, STATUS='DELETE')

         IF (NRADIAL == 1) THEN
            CALL FRMRWF (INDEX, NSUBS, INFILE)
         ELSE IF (NRADIAL == 2) THEN
            CALL FRMTFP (INDEX, NSUBS)
         ELSE
            CALL FRMHYD (INDEX, NSUBS, MODIFY)
         ENDIF

         CALL PRTREM (ALL)
            !WRITE (istde,*) 'Radial functions incomplete, need more...'
            ! PRTREM has more informative prompt
         IF (.NOT.ALL) GO TO 234

      ENDIF
!
! All read. Let know, and allow modifying if non default
!
      WRITE (ISTDE, *) 'All required subshell radial wavefunctions ', &
         ' have been estimated:'
      CALL SUMMRY (ISTDE)

      IF (NDEF == 0) THEN
         MODIFY = .FALSE.
      ELSE
         WRITE (ISTDE, *) 'Revise any of these estimates?'
         MODIFY = GETYN()
      ENDIF

      IF (MODIFY) THEN
  456    CONTINUE
         WRITE (ISTDE, *) 'Enter the list of subshells whose radial ', &
            'wavefunctions are to be revised:'
         OPEN(UNIT=734, FILE='tmp_734', STATUS='NEW')
         CALL GETRSL (INDEX, NSUBS)
         CLOSE(734, STATUS='DELETE')
         IF (NSUBS == 0) GO TO 456
         DO J = 1, NSUBS
            LOC = INDEX(J)
            SET(LOC) = .FALSE.
            PF(:N,LOC) = 0.D0
            QF(:N,LOC) = 0.D0
            SOURCE(LOC) = ' '
         END DO
         ALL = .FALSE.
         GO TO 123
      ENDIF

      IF (NDEF /= 0) CALL SUMMRY (24)

      RETURN
      END SUBROUTINE GENRWF

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
program test_always_skip

use stdlib_experimental_error, only: check
implicit none

call check(.false., code=77)

end program

max_stars_repo_name: ashwinvis/stdlib

max_issues_repo_name: ashwinvis/stdlib

max_forks_repo_name: ashwinvis/stdlib


text:
      subroutine flgset(axlksd,iopt,jflag,jpflag,jsflag,kxmod,narn1a,
     $ narn2a,narxmx,nbaspd,nbtd,nbtmax,ncmpra,ncta,ndrsd,ndrsmx,
     $ ndrsrd,noptmx,noutpt,npta,nptmax,nrdxsp,nsta,nstmax,ntpr,
     $ ntprmx,nttyo,nxmdmx,nxmod,uphasa,uptypa,uspeca,uxmod)
c
c     This subroutine sets up the status arrays jpflag and jsflag.
c     These flags denote the statuses, respectively, of phases
c     and species. The relevant values and their meanings are
c     as follows:
c
c        jpflag:
c          = 0   The species is present or potentially present
c          = 1   The physical presence of the phase in the model
c                  is suppressed; associated variables, such as a
c                  reaction affinity, may be calculated
c          = 2   The phase is completely ignored by the code
c
c        jsflag:
c          = 0   The species is present or potentially present
c          = 1   The physical presence of the species in the model
c                  is suppressed; associated variables, such as a
c                  reaction affinity, may be calculated
c          = 2   The species is completely ignored by the code
c
c     This subroutine is called by:
c
c       EQ3NR/eq3nr.f
c       EQ6/eq6.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c       jpflag = phase status flag array
c       jsflag = species status flag array
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer narxmx,nbtmax,ndrsmx,noptmx,nptmax,nstmax,ntprmx,nxmdmx
c
      integer noutpt,nttyo
c
      integer iopt(noptmx),jflag(nstmax),jpflag(nptmax),
     $ jsflag(nstmax),kxmod(nxmdmx),nbaspd(nbtmax),ncmpra(2,nptmax),
     $ ndrsd(ndrsmx),ndrsrd(2,nstmax)
c
      integer narn1a,narn2a,nbtd,ncta,npta,nrdxsp,nsta,ntpr,nxmod
c
      character(len=48) uspeca(nstmax),uxmod(nxmdmx)
      character(len=24) uphasa(nptmax),uptypa(nptmax)
c
      real(8) axlksd(narxmx,ntprmx,nstmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer jlen,n,nb,ncount,nn,np,nr1,nr2,ns,nse,nss,nt
c
      integer nbasis
c
      logical qheadr
c
      character(len=56) uspn56
      character(len=24) uptsld,uptliq,ux24,uy24
c
c-----------------------------------------------------------------------
c
      data uptsld /'Solid                   '/
      data uptliq /'Liquid                  '/
c
c-----------------------------------------------------------------------
c
c     Note: the following statements don't really do anything except
c     cause the compiler not to complain that uptliq is not used.
c     are not used.
c
      ux24 = uptliq
      uy24 = ux24
      uptliq = uy24
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Zero the jsflag and jpflag arrays.
c
      do ns = 1,nsta
        jsflag(ns) = 0
      enddo
      do np = 1,npta
        jpflag(np) = 0
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Set jsflag to 2 if jflag = -1 for a species. If not, if the
c     species is an active dependent species, set jsflag to 2 if
c     jsflag = -1 for any other species appearing in its reaction.
c
      do ns = 1,nsta
        nr1 = ndrsrd(1,ns)
        nr2 = ndrsrd(2,ns)
        nt = nr2 - nr1 + 1
        if (jflag(ns) .eq. -1) then
          jsflag(ns) = 2
        elseif (ns.lt.narn1a .or. ns.gt.narn2a
     $    .or. jflag(ns) .eq. 30) then
          if (nt .ge. 2) then
            do n = nr1,nr2
              nss = ndrsd(n)
              if (jflag(nss) .eq. -1) then
                jsflag(ns) = 2
                go to 130
              endif
            enddo
          endif
        endif
  130   continue
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Now provide an exception to the above. Scan auxiliary basis
c     species with jflag .le. 1 and ensure that any basis species that
c     they are linked to do not have jsflag = 2. If so, reset jsflag
c     to 1. Do this recursively, to ensure that no species is skipped.
c     The idea here is to keep these strict basis species in the
c     compressed species set produced by EQLIB\cmpdat.f, so that the
c     one-to-one association with a chemical element is preserved.
c
      nn = max(ncta + 1,nrdxsp + 1)
      qheadr = .true.
  140 ncount = 0
      do nb = nn,nbtd
        ns = nbaspd(nb)
        if (jsflag(ns) .le. 1) then
          nr1 = ndrsrd(1,ns)
          nr2 = ndrsrd(2,ns)
          do n = nr1,nr2
            nse = ndrsd(n)
            if (jsflag(nse) .ge. 2) then
              jsflag(nse) = 1
              ncount = ncount + 1
              if (qheadr) then
                write (noutpt,1000)
                write (nttyo,1000)
 1000           format(/' Preserving the following basis species',
     $          ' in the model',/' to maintain linkage to strict',
     $          ' basis species associated',/' one-to-one with',
     $          ' active chemical elements:',/)
              endif
              qheadr = .false.
c
c             Calling sequence substitutions:
c               uspeca(nse) for unam48
c
              call fmspnx(jlen,uspeca(nse),uspn56)
c
              write (noutpt,1010) uspn56(1:jlen)
              write (nttyo,1010) uspn56(1:jlen)
 1010         format('   ',a)
            endif
          enddo
        endif
      enddo
      if (ncount .gt. 0) go to 140
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Set jsflag to 2 if there exist no log K data in the current
c     temperature range, unless the species happens to be in the
c     basis set.
c
      do ns = 1,nsta
        if (axlksd(1,ntpr,ns) .ge. 9999999.) then
c
c         Calling sequence substitutions:
c           nbaspd for nbasp
c           nbtd for nbt
c
          nb = nbasis(nbaspd,nbtd,nbtmax,ns)
          if (nb .eq. 0) jsflag(ns) = 2
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Execute the nxmod suppression options.
c
      call supprs(kxmod,jpflag,jsflag,ncmpra,noutpt,npta,nptmax,
     $ nsta,nstmax,nttyo,nxmdmx,nxmod,uphasa,uspeca,uxmod)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Suppress any phase with zero species.
c
      do np = 1,npta
        nt = ncmpra(2,np) - ncmpra(1,np) + 1
        if (nt .le. 0) jpflag(np) = 2
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Exercise the option to hard suppress all solid solutions.
c
      if (iopt(4) .le. 0) then
        do np = 1,npta
          if (uptypa(np)(1:24) .eq. uptsld(1:24)) then
            nr1 = ncmpra(1,np)
            nr2 = ncmpra(2,np)
            nt = nr2 - nr1 + 1
            if (nt .ge. 2) then
              jpflag(np) = 2
              do ns = nr1,nr2
                jsflag(ns) = 2
              enddo
            endif
          endif
        enddo
      endif
c
      end


text:
	PROGRAM SFMOD
C************************************************************************
C* PROGRAM SFMOD							*
C*									*
C* This program moves data from one surface data set to another.	*
C*									*
C* Log:									*
C* I. Graffman/RDS	10/85						*
C* M. desJardins/GSFC	10/86	Added GEMPAK parameter names		*
C* M. desJardins/GSFC	 6/88	Changed a lot				*
C* M. desJardins/GSFC	11/89	Changed station time			*
C* K. Brill/NMC          9/90   Declare STID as CHAR*8			*
C* M. desJardins/GSFC	 1/91	Set stn using ISTNM when STID is blank	*
C* J. Whistler/SSAI	 4/91	Changed ier to loop through stations	*
C*				correctly				*
C* K. Brill/NMC		 8/93	Added ISPRI to SF_ASTN call		*
C* L. Williams/EAI	 7/94	Removed call to SFCUPD			*
C* K. Tyle/GSC	 	 8/96	Added FL_MFIL to search for file type	*
C* S. Maxwell/GSC        7/97   Increased input character length        *
C* A. Hardy/GSC		 1/99	Added DATOUT option                     *
C* A. Hardy/GSC		 3/99	Added priority parameter to PC_SSTN     *
C* D. Kidwell/NCEP	 3/99	Added SFPARM option; moved SFCOPT call  *
C* A. Hardy/GSC          3/99   Added priority parameter SF_QSTN,SF_SNXT*
C*	                        SF_SSTN 				*
C* A. Hardy/GSC          3/99   Removed ispri = 0			*
C* T. Piper/SAIC	 4/02	Fixed UMR; initialized sffinp & sffout	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( NEXP = 100 )
	CHARACTER	sffile*(LLMXLN), sfoutf*(LLMXLN),
     +			dattim*(LLMXLN), area*(LLMXLN),
     +			datout*(LLMXLN), sfparm*(LLMXLN)
C*
	CHARACTER	sffout*72, sffinp*72, stn*8, stat*4, coun*4,
     +                  stid*8, filnam*72
	LOGICAL		respnd, done, proces, dotime, sfadd
	CHARACTER	timinp (LLMXTM)*20, timout (LLMXTM)*20
	CHARACTER	outtm (LLMXTM)*20
	CHARACTER	chdat (MMPARM)*8, tt*20
	CHARACTER	times (LLMXTM)*20
        CHARACTER       list (NEXP)*20
	REAL		data (MMPARM), cmpdat (MMPARM),
     +			outdata (MMPARM)
	INTEGER		itarr(5), ipos (MMPARM)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	sffinp = ' '
	sffout = ' '
C
C*	Initialize user interface.
C
	CALL IP_INIT  ( respnd, iperr )
	IF  ( iperr .ne. 0 )  THEN
	    CALL ER_WMSG  ( 'SFMOD', iperr, ' ', ier )
	    CALL SS_EXIT
	END IF
	CALL IP_IDNT  ( 'SFMOD', ier )
C
C*	Main loop.
C
	done   = .false.
	iflinp = 0
	iflout = 0
	DO WHILE  ( .not. done )
C
C*	    Get user input and exit if there is an error.
C
	    CALL SFCINP  ( sffile, sfoutf, dattim, area, datout,
     +			   sfparm, iperr )
	    IF  ( iperr .ne. 0 )  THEN
		CALL ER_WMSG  ( 'SFMOD', iperr, ' ', ier )
		CALL SS_EXIT
	    END IF
	    proces = .true.
C
C*	    Process input file name.
C
	    CALL FL_MFIL ( sffile, ' ', filnam, iret )
	    IF ( iret .ne. 0 ) CALL ER_WMSG ( 'FL', iret, ' ', ier )
	    CALL SFCOFL  ( filnam, sffinp, iflinp, ntdset, timinp,
     +			   iret )
	    IF  ( iret .ne. 0 )  proces = .false.
C
C*	    Process output file name.
C
	    IF  ( proces )  THEN
		CALL SFCNFL  ( sfoutf, sfparm, sffout, iflout, ntout,
     +			       outtm, ncols, ipos, iret )
		IF  ( iret .ne. 0 )  proces = .false.
	    END IF
C
C*	    Decode user input time.
C
	    IF  ( proces )  THEN
C
C*	        Process input date and times.
C
		CALL TI_FIND  ( dattim, ntdset, timinp, tt,
     +				ntmprc, times, iret )
		IF  ( iret .ne. 0 )  THEN
		    proces = .false.
		END IF
C
C*	        Process output date and times.
C
                IF ( proces .and. ( datout .ne. ' ' ) ) THEN
C
C*	            Check if times exist in output file.
C
		    IF ( ntout .ne. 0 ) THEN
			CALL TI_FIND  ( datout, ntout, outtm, tt,
     +                                  ntmout, timout, iret )
		      ELSE
	                CALL ST_CLST ( datout, ';',' ', NEXP, list,
     +                                 nlist, ier )
		        DO i = 1, nlist
 	   		    CALL TI_STAN  ( list (i), times (ntmprc),
     +		    		            timout (i), iret )
		        END DO
                        ntmout = nlist
		    END IF
		    IF  ( iret .ne. 0 )  THEN
		        proces = .false.
		    END IF
C
C*	            Check if the number of input times is less than
C*		    output times. If it is less, then quit.
C
                    IF ( ntmprc .lt. ntmout ) THEN
                        CALL ER_WMSG  ( 'SFMOD', -5, ' ', ier )
                        proces = .false.
C
C*	              Check if the number of input times is greater than
C*		      output times. If so, fill datout with last time.
C
		      ELSE IF ( ntmprc .gt. ntmout) THEN
		        DO i = ntmout + 1, ntmprc
			    timout (i) = timout (ntmout)
		        END DO
                    END IF
C
C*	          Accept input times as output times.
C
                  ELSE
                    datout = dattim
		    ntmout = ntmprc
		    DO i = 1, ntmprc
		        timout(i) = times(i)
		    END DO
                END IF
	    END IF
C
C*	    Set up area.
C
	    IF  ( proces )  THEN
		CALL LC_SARE  ( area, iflinp, stn, iret )
		IF  ( iret .ne. 0 )  proces = .false.
	    END IF
C
C*	    Write message displaying the user options.
C
	    IF  ( proces )  THEN
	        CALL SFCOPT   ( filnam, sfoutf, area, times,
     +			        timout, ntmprc, sfparm, ier )
	        IF  ( ier .ne. 0 )  THEN
		    proces = .false.
	        END IF
	    END IF
C
C*	    Loop through each of the times requested.
C
	    itime = 1
	    DO WHILE  ( proces .and. ( itime .le. ntmprc ) )
		dotime = .true.
C
C*		Set the time in the input file.
C
		CALL SF_STIM  ( iflinp, times (itime), iret )
C
C*		Check for time in output file.  If not found,
C*		add the time.
C
		CALL SF_STIM  ( iflout, timout (itime), iret )
		IF  ( iret .ne. 0 )  THEN
		    CALL SF_ATIM  ( iflout, timout (itime), iret )
		    CALL SF_STIM  ( iflout, timout (itime), iret )
		    IF  ( iret .ne. 0 )  THEN
			CALL ER_WMSG  ( 'SFMOD', -4, timout (itime), k )
			dotime = .false.
		    END IF
		END IF
C
C*		Process this time.
C
		IF  ( dotime )  THEN
		    ier = 0
C
C*		    Reset stations to beginning of file.
C
		    CALL SF_BEGS  ( iflinp, iret )
C
C*		    Loop through stations.  Read next station.
C
		    sfadd = .false.
		    DO WHILE  ( ier .eq. 0 )
			CALL SF_SNXT  ( iflinp, stid, istnm, rlt, rln,
     +					rel, ispri, ier )
			CALL ST_LSTR  ( stid, islen, ier2 )
			IF  ( islen .gt. 0 )  THEN
			    stn = stid
			  ELSE
			    CALL ST_INCH  ( istnm, stn, ier2 )
			END IF
C
C*			Read in the data.
C
			IF  ( ier .eq. 0 )  THEN
			    CALL SF_RDAT  ( iflinp, data, ihhmm, iret )
C
C*			    If there is data, set station in the output
C*			    file.
C
			    IF  ( iret .eq. 0 )  THEN
				CALL SF_SSTN  ( iflout, stn, stid, in,
     +						rl1, rl2, re, ispri,
     +						iret )
C
C*				If the station is not in output file,
C*				add it.
C
				IF  ( iret .ne. 0 )  THEN
				    CALL SF_QSTN  ( iflinp, stid, istnm,
     +						    rlt, rln, rel,
     +						    ispri, stat, coun,
     +						    ier )
				    CALL SF_ASTN  ( iflout, 1, stid,
     +						    istnm, rlt, rln,
     +						    rel, stat, coun,
     +						    ispri, n, iret )
				    IF  ( ( iret .ne. 0 )  .and.
     +					  ( .not. sfadd ) )  THEN
					CALL ER_WMSG ( 'SFMOD', +3, ' ',
     +							iii )
					sfadd = .true.
				      ELSE IF  ( iret .eq. 0 )  THEN
					CALL SF_SSTN  ( iflout, stn,
     +					  stid, in, rl1, rl2, re,
     +					  ispri, iret )
				    END IF
				END IF
			    END IF
C
C*			    Compute parameters for output file and
C*			    write data.
C
			    IF  ( iret .eq. 0 )  THEN
			      CALL PC_SSTN  ( stn, id, rlt, rln, rel,
     +					      ispri, ihhmm, 1, ier )
			      CALL PC_CMLV  ( 1, data, cmpdat, chdat,
     +					      iret )
C
C*			      Read in the outfile data.
C
                              CALL SF_RDAT ( iflout, outdata, jhhmm,
     +					     iret )
C
C*			      Replace missing data with computed values.
C
			      DO i = 1, ncols
 				  IF ( ERMISS ( outdata ( ipos (i) ) ) )
     +      			      outdata ( ipos (i) ) = cmpdat (i)
                              END DO
			      IF ( jhhmm .eq. IMISSD ) THEN
				  CALL TI_CTOI ( timout (itime),
     +					         itarr, ier )
			          jhhmm = itarr(4) * 100 + itarr(5)
			      END IF
C
C*			      Write out array.
C
      			      CALL SF_WDAT ( iflout, jhhmm, outdata,
     +					     iret )
			    END IF
			END IF
		    END DO
		END IF
C
C*		Increment the time.
C
		itime = itime + 1
	    END DO
C
C*	    Call the dynamic tutor.
C
	    CALL IP_DYNM  ( done, ier )
	END DO
C
C*	Close open files.
C
	CALL SF_CLOS  ( iflinp, ier )
	CALL SF_CLOS  ( iflout, ier )
C
C*	Exit.
C
  	CALL IP_EXIT  ( iret )
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text: Young Song I can be reached at youngsong99@hotmail.com