	SUBROUTINE GH_TCWW ( device, tnam, wtype, timstr, wname, origc,
     +                       wocen, wsped, wadnm, rlat, rlon, nc,
     +                       nstrm, nknt, fdate,wwnd, lext, idisp, mxwd,
     +                       wdir, itrack, szmrk, ltype, lwidth, lcolor,
     +                       idays, iscale, reset, iret )
C************************************************************************
C* GH_TCWW								*
C*									*
C* This subroutine plots the current tropical storm or hurricane        *
C* track and watches/warnings.						*
C*									*
C* GH_TCWW ( DEVICE, TNAM, WTYPE, TIMSTR, WNAME, ORIGC, WOCEN, WSPED,   *
C*	     WADNM, RLAT, RLON, NC, NSTRM, NKNT, FDATE, WWND,LEXT,      *
C*	     IDISP, MXWD, WDIR, ITRACK, SZMRK, LTYPE, LWIDTH, LCOLOR, 	*
C*	     ISCALE, RESET, IRET ) 				        *
C*									*
C* Input parameters:							*
C*	DEVICE		CHAR*		Current device                  *
C*	TNAM		CHAR*		Output filename			*
C* 	WTYPE    	CHAR*		Tropical storm type		*
C*	TIMSTR    	CHAR*		Advisory valid time string	*
C*	WNAME    	CHAR*		Tropical storm name		*
C*	ORIGC    	CHAR*		Issuing center                  *
C*     	WOCEN    	CHAR*		Tropical storm identifier       *
C*	WSPED    	CHAR*		Movement speed (kts)		*
C*	WADNM    	CHAR*		Storm advisory number		*
C*	RLAT (NC,*) 	REAL		Current/forecasted Latitudes	*
C*	RLON (NC,*) 	REAL		Current/forecasted Longitudes	*
C*	NC 		INTEGER		Maximum number of lat/lon pairs *
C*	NSTRM 		INTEGER		Number of decoded files		*
C*      NKNT		INTEGER         Number of forecast points	*
C*      FDATE (NC,*)	CHAR*		Forecast dates			*
C*	WWND		CHAR*		Current storm speed             *
C*	LEXT (NC,*)	CHAR*		Forecast Post-Trop indicators   *
C*	IDISP		INTEGER		Storm dissipating flag		*
C*      MXWD (NC,*)	INTEGER		Forecast max wind speeds        *
C*	WDIR		CHAR*		Direction of present movement   *
C*      ITRACK		INTEGER		Track plot flag			*
C*	SZMRK (2)	REAL		Marker size multiplier		*
C*	LTYPE (2)	INTEGER		Forecast track line type	*
C*	LWIDTH (2)	INTEGER		Forecast track line width	*
C*	LCOLOR (2)	INTEGER		Forecast track line color	*
C*      IDAYS	        INTEGER		3 or 5 day forecast display     *
C*      ISCALE	        INTEGER		Scale legend box plot flag	*
C*                                                                      *
C* Input/Output parameters:						*
C*	RESET		LOGICAL		Color reset flag		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* A. Hardy/GSC		 5/01   Modified from GG_HRCN			*
C* D. Kidwell/NCEP       6/01   Fixes for bkpt file write; added sounds	*
C* A. Hardy/GSC		 6/01   Diss. check; GQ/SLINE;cleaned up garea  *
C*				calculation and general clean up	*
C* A. Hardy/GSC		 6/01   Added color tag;GH_SAVE, GH_REST	*
C* A. Hardy/SAIC	 8/01   Added PS check,wadnm,upd trak line sz   *
C* D. Kidwell/NCEP       4/02   Formatted write for lunbh; color mods;  *
C*				changed GH_KGLB and GH_KGFL call seqs.  *
C* D. Kidwell/NCEP       4/02   Increased number of sounds from 3 to 5  *
C* D. Kidwell/NCEP       5/02   Changed name of land bounds file        *
C* D. Kidwell/NCEP       3/03   Allowed 3 or 5 day fcst (6 or 8 times)  *
C* D. Kidwell/NCEP       3/03   Used dashed fill, dashed line, smaller  *
C*				points for fcst days 4 and 5            *
C* D. Kidwell/NCEP       4/03   Changed breakpoint plotting calls       *
C* D. Kidwell/NCEP       4/03   Added error check for bad wocen value   *
C* J. Wu/SAIC       	 8/03   Added param. NKNT to GH_KGLB/GH_KGLP	*
C* D. Kidwell/NCEP	11/03	Added arg zone2; use mult. bkpt files   *
C* D. Kidwell/NCEP	 1/04	Incr. ibkel, istsnd; added mxwd & wdir; *
C*				CSC for GH_BKIN, GH_BKRC, GH_BKUS       *
C* D. Kidwell/NCEP       4/04   Added jflags, CSC for GH_BKLP, GH_BKLB  *
C* m.gamazaychikov/SAIC	03/04	From GH_KGPH				*
C* m.gamazaychikov/SAIC	05/04	Made VGF file all lower case		*
C* m.gamazaychikov/SAIC	08/04	Add numbkp and icnt, change breakpoint 	*
C*				plotting calls				*
C* B. Yin/SAIC		12/04	Added time zone in gh_bkrv		*
C* m.gamazaychikov/SAIC	01/05	Added itrack and szmrk to CS		*
C* m.gamazaychikov/SAIC	01/05	Changed the total number of breakpoints *
C*				for map area calculations		*
C* m.gamazaychikov/SAIC	03/05	Added ltype, lwidth, lcolor and ilegend	*
C*				to CS to plot with user specified parms	*
C* B. Yin/SAIC		04/05	Added issue status into gh_bkrv		*
C* S. Gilbert/NCEP	12/05	Added check to set hvbkpt to false when *
C*                              GH_BKRV returns icount == 0 (no bkpts)  *
C* S. Gilbert/NCEP	01/06	Handle intermediate advsry nos in filnam*
C* S. Gilbert/NCEP	07/06	added new argument origc, and added     *
C*                              central Pacific case                    *
C* S. Gilbert/NCEP	03/07	removed check for west of 180 deg lon   *
C* m.gamazaychikov/SAIC	04/08	Added lext and remn to CS, added two 	*
C*				tropical cyclone intensity category, 	*
C*				changed the plotting of the track	*
C* m.gamazaychikov/SAIC	06/08	Fixed the bug in setting flag to plot   *
C*                              string "Extratropical" in legend box	*
C* m.gamazaychikov/SAIC	09/08	Added breakpoints lat lon extraction,	*
C*				added them to GH_KGLP CS, increased the *
C*                              number of iterations to 15, improved	*
C*                              calculation of min max of the map,	*
C*                              set the GF, PS dims to 895;716		*
C* m.gamazaychikov/SAIC	10/08	Fixed AL basin positive longitude bug   *
C* S. Jacobs/NCEP	 8/09	Increase size of tdev to include dims	*
C* X. Guo/CWS		03/10   Change extratropical to post-tropical	*
C* X. Guo/CWS		03/10   Moved legend box underneath the graphic *
C*                              and removed unused parameters           *
C* X. Guo/CWS		04/10   Fixed POST-TROP point display problem   *
C* X. Guo/CWS		05/10   Changed "DISSIPATING" to "DISSIPATED"   *
C* X. Guo/CWS           05/10   Added idays to GH_TCLB                  *
C* S. Jacobs/NCEP	 6/10	Re-added flag for plotting the scale	*
C* S. Jacobs/NCEP	 4/13	Added smoothing for the track and cone	*
C* D. Zelinsky/NCEP/NHC 10/15   Added time zones (P/M/C) to EastPac     *
C* M. Sardi/NCEP/NHC    11/15   Above change required fix to ensure     *
C*                              GH_KGAR only called for AL systems.     *
C* S. Guan/NCEP         07/18   Change hipowo.cia to hipowo.nws         *
C* B. Hebbard/NCEP	05/20	Update for new 60hr forecast - SCN20-20	*
C*                              by increasing PARAMETER NUMHR 8 -> 9    *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ghcmn.cmn'
C*
	PARAMETER	( NUMHR = 9, MXPTS = 500 )
	PARAMETER	( NUMH2 = NUMHR - 2 )
C*
	CHARACTER*(*)	device, wname, timstr, wtype, wsped, tnam,
     +                  wocen, fdate(nc,*), wwnd, wadnm, wdir, origc,
     +                  lext (nc,*)
	INTEGER		mxwd (nc,*), ltype (*), lwidth (*), lcolor (*)
        REAL		rlat(nc,*), rlon(nc,*), szmrk (*)
	LOGICAL		reset
C*
	CHARACTER	table*128, tbtyp*128, bgsea*180, bgland*180,
     +                  mapstr*128, latlon*128, ddev*12, cblk*2,
     +                  ddate(NUMHR)*20, tzone, filnam*40,
     +                  tdev*40, noprob*180, disstr*30, bglake*180,
     +                  coltag*33, cmap*3, namstr*36,
     +			adnum*4, cyint (5), bpnam(100)*33, stnum*4,
     +			yyyy*4, stname*32, vtime*10, bpstr*3300,
     +			zone*4, status, cadvnm*5,  bklntp*4, dims*7
C*
	INTEGER	        numbkp(50),numb(4), ibkpts(4,100),
     +                  iarea(4,100),isev(50), iadvtp(50),
     +                  igeog(50), icnt (4, 50), kpos(MXPTS),
     +                  ibkcur(MAXBK), iarcur(MAXBK), nppart(20)
C*
        REAL            alat(NUMHR), alon(NUMHR),
     +			slnlat(MXPTS), slnlon(MXPTS),
     +			xkey (5), ykey (5),
     +			slnlt6(MXPTS), slnln6(MXPTS), dist(NUMHR),
     +			bplat(100), bplon(100),
     +                  lbklat(20,MAXBK), lbklon(20,MAXBK),
     +                  bkplat(MAXBK), bkplon (MAXBK),
     +			blat(MXPTS), blon(MXPTS), bdst(MXPTS),
     +			bx(MXPTS), by(MXPTS), dx(NUMHR), dy(NUMHR)
C*
	LOGICAL		hvbkpt, done, finish, plotit, extra
C*
	INCLUDE		'ERMISS.FNC'
C*
	DATA		cyint / 'M', 'H', 'S', 'D', 'L'/
	DATA		dims / '895;716'/
C-----------------------------------------------------------------------
	iret = 0
C
C*	Query current settings.
C
	CALL GH_SAVE ( ier )
C
	finish = .false.
	extra = .false.
        ddev = 'XW'
        filnam = ' '
        yyyy = ' '
        stname = ' '
        bklntp = ' '
        stnum = ' '
        vtime = ' '
        bpstr = ' '
        DO ibpnam = 1, 100
            bpnam(ibpnam) = ' '
        END DO
        DO ii = 1, MAXBK
            bkplat (ii) = RMISSD
            bkplon (ii) = RMISSD
        END DO
C
C*      Set the flag for post-tropical line in legend box
C
        ii = 1
        ipost = 0
        DO WHILE ( (.not. extra) .and. (ii .le. nknt) )
           IF ( lext(ii,nstrm) .eq. 'P' ) THEN
              ipost = 1
              extra = .true.
           END IF
           ii = ii + 1
        END DO
        CALL ST_LSTR ( tnam, lenm, ier )
        tdev= ddev // '| TRACK-W/W |' // dims
	CALL GG_SDEV ( tdev, ier )
        IF ( .not. reset ) THEN
            CALL GH_SVCL ( ier )
            reset = .true.
          ELSE
            CALL GH_RSCL ( ier )
        END IF
        CALL GSTANM ( ier )
	DO WHILE ( .not. finish )
C
C*          Reverse black and white if device is for postscript.
C
            CALL GQDEV  ( ddev, iunit, iatyp, ier )
            IF  ( ddev(:2) .eq. 'PS' )  THEN
                iwht = 32
                iblk = 1
              ELSE
                iwht = 31
                iblk = 32
            END IF
	    IF  ( ddev ( :2) .ne. 'XW' ) THEN
	        finish = .true.
	    END IF
C
C*	    Set symbol and text attributes.
C
	    CALL GSTEXT ( 21, 2, 1.0, 1, 111, 1, 1, ier )
	    isytyp = 17
            ssize  = 1.0
            iwidth = 2
C
C*          Read in average track error file.
C
	    iertb = 0
            IF ( wocen(1:2)  .eq. 'AL' ) THEN
                table = 'altker.tbl'
                IF ( rlon(1,nstrm) .le. -85.0 ) THEN
                    tzone = 'C'
                  ELSE
                    tzone = 'E'
                END IF
              ELSE IF ( wocen(1:2)  .eq. 'EP' ) THEN
                table = 'eptker.tbl'
                IF ( rlon(1,nstrm) .gt. -106.0 ) THEN
                    tzone = 'C'
                  ELSE IF ( rlon(1,nstrm) .gt. -115.0 ) THEN
                    tzone = 'M'
                  ELSE
                    tzone = 'P'
                END IF

C*               Used to be always Pacific
C                tzone = 'P'
              ELSE IF ( wocen(1:2)  .eq. 'CP' ) THEN
                table = 'cptker.tbl'
                tzone = 'H'
	      ELSE
		iertb = -10
            END IF
            IF ( origc(1:4)  .eq. 'CPHC' ) THEN
                table = 'cptker.tbl'
                tzone = 'H'
            END IF
C
	    IF ( iertb .eq. 0 ) THEN
                tbtyp = 'hcnadv'
C
C*              Read the average track error file.
C
                CALL GH_KGTB ( table, tbtyp, NUMHR, dist, iertb )
	    END IF
	    IF ( iertb .ne. 0 ) THEN
		CALL ER_WMSG ( 'GPTCWW', iertb, ' ', ierr )
	    END IF
C
            im    = nstrm
            nltln = 0
            jmax  = NUMHR
	    IF ( nknt .le. NUMH2 ) jmax = NUMH2
C
            IF ( ERMISS ( rlat(1,im) ) .or. ERMISS ( rlon(1,im) ) ) THEN
                im = im - 1
                jmax = 1
            END IF
C
C*          Find the average track error lat. lon. points.
C
            DO jj = 1, jmax
                IF ( ( .not. ERMISS ( rlat (jj,im) ) ) .and.
     +               ( .not. ERMISS ( rlon (jj,im) ) ) ) THEN
                    nltln = nltln + 1
                    alat (nltln) = rlat(jj,im)
                    alon (nltln) = rlon(jj,im)
		    IF ( jj .gt. 1 ) ddate (nltln) = fdate(jj-1,im)
                END IF
            END DO
C
C*	    Smooth the central track line and the track error distances.
C
	    CALL GTRANS ( 'M', 'D', nltln, alat, alon, dx, dy, iergt )
	    dens = 5.0
	    cscl = 30.0
	    is = 0
	    ie = nltln+1
	    CALL CV_PRM3 ( nltln, dx, dy, dist, dens, MXPTS, cscl,
     +			   is, ie, nout, bx, by, bdst, iercv )
	    CALL GTRANS ( 'D', 'M', nout, bx, by, blat, blon, iergt )
C
C*	    Find the original points in the smoothed line.
C
	    knumh2 = nout
	    DO  kk = 1, nout
	        kpos(kk) = 0
		DO  mm = 1, nltln
		    IF  ( ( ABS(blat(kk)-alat(mm)) .lt. 0.0005 ) .and.
     +			  ( ABS(blon(kk)-alon(mm)) .lt. 0.0005 ) )  THEN
			kpos(kk) = mm
			IF ( mm .eq. NUMH2 ) knumh2 = kk
		    END IF
		END DO
	    END DO
C
C*	    Calculate the area under the cone.
C
            IF ( iertb .ge. 0 ) THEN
		plotit = .true.
		inner  = MIN0 ( nout, knumh2 )
                CALL GH_KGAT ( blat, blon, inner, bdst, MXPTS, slnlt6,
     +                         slnln6, numln6, ier )
		IF ( nout .gt. knumh2 ) THEN
                    CALL GH_KGAT ( blat, blon, nout, bdst, MXPTS,
     +                             slnlat, slnlon, numln, ier )
		  ELSE
		    numln = numln6
		    DO jj = 1, numln
			slnlat ( jj ) = slnlt6 ( jj )
			slnlon ( jj ) = slnln6 ( jj )
		    END DO
		END IF
C
C*              Determine graphics area.
C
                DO jj = 1, numln
		    IF ( jj .eq. 1 ) THEN
                        xmxlat = slnlat(jj)
                        xmnlat = slnlat(jj)
                        IF ( slnlon(jj) .gt. 0 .and.
     +                       wocen(1:2)  .ne. 'AL' ) THEN
C
C*                         Subtruct 360 for non-Atlantic storms
C
                           xmxlon = slnlon(jj) - 360.
                           xmnlon = slnlon(jj) - 360.
                        ELSE
                           xmxlon = slnlon(jj)
                           xmnlon = slnlon(jj)
                        ENDIF
		      ELSE
                        IF ( .not. ERMISS ( slnlon(jj) ) ) THEN
                            xmxlat = AMAX1 ( xmxlat, slnlat(jj) )
                            xmnlat = AMIN1 ( xmnlat, slnlat(jj) )

                            IF ( slnlon(jj) .gt. 0 .and.
     +                           wocen(1:2)  .ne. 'AL' ) THEN
C
C*                             Subtruct 360 for non-Atlantic storms
C
                               xmxlon = AMAX1( xmxlon, slnlon(jj)-360.)
                               xmnlon = AMIN1( xmnlon, slnlon(jj)-360.)
                            ELSE
                               xmxlon = AMAX1 ( xmxlon, slnlon(jj) )
                               xmnlon = AMIN1 ( xmnlon, slnlon(jj) )
                            ENDIF
                        END IF
		    END IF
                END DO
C
C*		Save off the max/min lat/lon for the track error for
C*              use in determining the label box placement.
C
                tmxlat =  xmxlat + 2.0
                tmnlat =  xmnlat - 2.0
                tmxlon =  xmxlon + 5.0
                tmnlon =  xmnlon - 5.0
C
C*		Set up track error polygon.
C
                IF ( ( ABS( tmxlat - tmnlat) .lt. 10.0 )
     +                 .or.  ( ABS( tmxlon - tmnlon) .lt. 10.0 ) ) THEN
                    xmxlat =  tmxlat
                    xmnlat =  tmnlat
                    xmxlon =  tmxlon
                    xmnlon =  tmnlon
                  ELSE
                    xmxlat =  xmxlat + 3.0
                    xmnlat =  xmnlat - 3.0
                    xmxlon =  xmxlon + 6.0
                    xmnlon =  xmnlon - 6.0
                END IF
C
                IF ( tzone .eq. 'H')  THEN
C
C*                  Make Sure Hawaiian islands are plotted
C
                    rmxlat =  xmxlat
                    IF ( rmxlat .lt. 24.0 ) rmxlat = 24.0
                    rmnlat =  xmnlat
                    IF ( rmnlat .gt. 18.0 ) rmnlat = 18.0
                    rmnlon =  180.
                    rmnlon =  xmnlon
                    IF ( rmnlon .gt. -162. ) rmnlon = -162.0
                    rmxlon =  -140.
                    rmxlon =  xmxlon
                    IF ( rmxlon .lt. -152. ) rmxlon = -152.0
                ELSE IF ( wocen(1:2)  .eq. 'EP' )  THEN
                    rmxlat =  xmxlat
                    rmnlat =  xmnlat
                    rmxlon =  xmxlon
                    rmnlon =  xmnlon
                ELSE
                    CALL GH_KGAR (xmnlat, xmnlon, xmxlat, xmxlon,
     +                            rmnlat, rmnlon, rmxlat, rmxlon, ier )
		END IF
C
C*              Check for breakpoints.
C
                hvbkpt = .true.
C
C*              Get the name of VGF file containing breakpoints.
C
                CALL ST_LSTR ( wocen, lenocn, ier )
                CALL ST_NULL ( wadnm, wadnm, lena, ier )
                CALL GH_ADVN ( wadnm, numadv, iadflag, ier )
                CALL TI_C2I  (timstr, iyyyy, immdd, ihhmm, ier )
                IF ( numadv .gt. 0 ) THEN
                    numadv = numadv + 1000
                    CALL ST_INCH ( numadv, adnum, ier )
                    CALL ST_INCH ( iyyyy, yyyy, ier )
                    CALL ST_UCLC ( wocen (:4), stnum, ier)
                    IF ( iadflag .eq.0 ) THEN
                        filnam = 'tca_' // stnum // yyyy //'_'//
     +                            adnum ( 2:4 ) //'.vgf'
                    ELSE IF ( iadflag .eq.1 ) THEN
                        filnam = 'tca_' // stnum // yyyy //'_'//
     +                            adnum ( 2:4 ) //'a.vgf'
                    ELSE IF ( iadflag .eq.2 ) THEN
                        filnam = 'tca_' // stnum // yyyy //'_'//
     +                            adnum ( 2:4 ) //'b.vgf'
                    ELSE
                        filnam = ' '
                    END IF
                  ELSE
                    filnam = ' '
                END IF
                CALL ST_NULL (filnam, filnam, ilen, iret)
C
C*              Get the breakpoint information from the VGF file
C
                CALL GH_BKRV ( filnam, istnum, iyear, ibasin, cadvnm,
     +                         isstyp, stname, vtime, icount,
     +                         isev,  iadvtp, igeog,
     +                         bplat, bplon, bpstr, numbkp, zone,
     +                         status, iret)
                IF ( iret .eq. -1) THEN
		    CALL ER_WMSG ( 'GPTCWW', 4, ' ', ierr )
                    hvbkpt = .false.
                ELSEIF ( icount .EQ. 0 ) THEN
                    hvbkpt = .false.
                ELSE
C
C*                  Separate name string into an array of strings
C
                    CALL ST_CLSL ( bpstr, ';', ' ', 100,
     +                             bpnam, nbpn, iret)
C
C*                  Get the information to plot breakpoints
C
                    CALL GH_BKGB ( icount, isev, iadvtp, bpnam, numbkp,
     +                             ibkpts, numb, iarea, icnt, iret)
C
                    ntbkpt = 0
C
C*                  Get the lat lon of all the breakpoint segments
C
                    DO inumb = 1, 4
                      IF ( numb (inumb) .gt. 0 ) THEN
                         indbkc = 1
                         indbkp = 1
C
C*                       Start loop over the number of segments
C
                         DO ilines = 1, numb(inumb)
                          inpseg = icnt (inumb,indbkc)
C
C*                        Zero out the breakpoint and area arrays
C*                        for current segment
C
                          DO ipts = 1, inpseg
                             ibkcur(ipts) = 0
                             iarcur(ipts) = 0
                          END DO
                          indb2=1
C
C*                        Start loop over the segments number of points
C
                          DO ipts = 1, icnt (inumb,indbkc)
                             ibkcur(indb2) = ibkpts(inumb, indbkp)
                             iarcur(indb2) = iarea(inumb, indbkp)
                             IF ( iarcur(indb2) .eq. IUSGEC .or.
     +                            iarcur(indb2) .eq. IMXCSA .or.
     +                            iarcur(indb2) .eq. IPACIF .or.
     +                            iarcur(indb2) .eq. IKEYS ) THEN
                                 bklntp = "pair"
                              ELSE IF ( iarcur(indb2) .eq. ICUBA .or.
     +                                  iarcur(indb2) .eq. IHISP.or.
     +                                  iarcur(indb2) .eq. IPRICO ) THEN
                                 bklntp = "ordr"
                              ELSE IF ( iarcur(indb2) .eq. IOTHER .or.
     +                                  iarcur(indb2) .eq. IWATER ) THEN
                                 bklntp = "list"
                                 CALL GH_GBKL ( ibkcur(indb2),
     +                                          iarcur(indb2),
     +                                          1, bklntp,
     +                                          nparts, nppart,
     +                                          lbklat, lbklon,
     +                                          iret)
                                 DO inparts = 1, nparts
                                   npline = nppart(inparts)
                                   DO ibk= 1, npline
                                     bkplat(ntbkpt)=lbklat(inparts,ibk)
                                     bkplon(ntbkpt)=lbklon(inparts,ibk)
                                     ntbkpt = ntbkpt + 1
                                   END DO
                                END DO
                             END IF
                          indb2 = indb2+1
                          indbkp = indbkp + 1
C
C*                        End of POINTS loop
C
                          END DO

                          IF  ( bklntp .eq. "ordr" .or.
     +                          bklntp .eq. "pair" ) THEN
                                CALL GH_GBKL ( ibkcur, iarcur,
     +                                         inpseg, bklntp,
     +                                         nparts, nppart,
     +                                         lbklat, lbklon,
     +                                         iret)
                                npline = nppart(1)
                                DO ibk =1, npline
                                   bkplat(ntbkpt) = lbklat(1,ibk)
                                   bkplon(ntbkpt) = lbklon(1,ibk)
                                   ntbkpt = ntbkpt + 1
                                END DO
                          END IF

                          DO ipts = 1, inpseg
                              ibkcur(ipts) = 0
                              iarcur(ipts) = 0
                          END DO
                          indbkc = indbkc + 1
C
C*                       End of SEGMENTS loop
C
                         END DO
                      END IF
C
C*                  End of NUMB loop
C
                    END DO
                    ntbkpt = ntbkpt - 1
C
C*                  Get the updated max and min for the map.
C
                    amnlat = bplat(1)
                    amnlon = bplon(1)
                    amxlat = bplat(1)
                    amxlon = bplon(1)
                    DO ii = 2, ntbkpt
                        amnlat = AMIN1 ( amnlat, bkplat(ii) )
                        amnlon = AMIN1 ( amnlon, bkplon(ii) )
                        amxlat = AMAX1 ( amxlat, bkplat(ii) )
                        amxlon = AMAX1 ( amxlon, bkplon(ii) )
                    END DO
                    amxlat =  amxlat + 1.0
                    amnlat =  amnlat - 1.0
                    amxlon =  amxlon + 2.0
                    amnlon =  amnlon - 2.0
                    rmnlat = AMIN1 ( rmnlat, amnlat )
                    rmnlon = AMIN1 ( rmnlon, amnlon )
                    rmxlat = AMAX1 ( rmxlat, amxlat )
                    rmxlon = AMAX1 ( rmxlon, amxlon )
                END IF
C
C*              Set up map.  Make sure there is enough room for the
C*		label box (key).  Make 6 attempts before quitting.  In
C*		that case, the label box defaults to the lower left
C*		corner.
C
		done = .false.
		iter = 1
C
		DO WHILE ( .not. done )
C
		    CALL GH_KGMP ( rmnlat, rmnlon, rmxlat, rmxlon,
     +			           fmnlat, fmnlon, fmxlat, fmxlon,
     +			           dellon, ier )
		    CALL GH_KGLP ( wtype, wname, fmnlat, fmnlon,
     +                             fmxlat,fmxlon,
     +				   namstr, xkey, ykey, ier )
		    IF ( ier .eq. 0 .or. iter .gt. 15 ) THEN
			done = .true.
		      ELSE
			iter = iter + 1
			rmnlat = rmnlat - 1.
			rmnlon = rmnlon - 1.
			rmxlat = rmxlat + 1.
			rmxlon = rmxlon + 1.
                        if ( rmxlat .ge. 85. ) rmxlat = 85.
		    END IF
		END DO
C
C*              Do the map boundary fill.
C
		coltag = 'w_water_mask'
        	CALL ST_LSTR ( coltag, lens, ier )
        	CALL GH_COLR ( coltag(:lens), 27, ier )
        	CALL GQCOLR ( icolr, ier )
        	CALL ST_INCH ( icolr, cmap, ier )
        	CALL ST_LSTR ( cmap, lens, ier )
        	bgsea =  'bg/' // cmap(:lens) // '//1'
        	CALL GG_BND ( bgsea, ier )
C
        	coltag = 'w_land_mask'
        	CALL ST_LSTR ( coltag, lens, ier )
        	CALL GH_COLR ( coltag(:lens), 22, ier )
        	CALL GQCOLR ( jcolr, ier )
        	CALL ST_INCH ( jcolr, cmap, ier )
        	CALL ST_LSTR ( cmap, lens, ier )
        	bgland = 'hcn_bnds/' // cmap(:lens) // '//1'
        	CALL GG_BND ( bgland, ier )
C
        	coltag = 'w_water_mask'
        	CALL ST_LSTR ( coltag, lens, ier )
        	CALL GH_COLR ( coltag(:lens), 27, ier )
        	CALL GQCOLR ( icolr, ier )
        	CALL ST_INCH ( icolr, cmap, ier )
        	CALL ST_LSTR ( cmap, lens, ier )
        	bglake = 'lakes/' //cmap(:lens)
        	CALL GG_BND ( bglake, ier )
C
C*	        Plot the average track error line.
C
                IF ( idisp .ge. 0 ) THEN
                    iatclr = 1
                    dens = 1.5
	            CALL GSCOLR ( iblk, ier )
                    CALL GSLINE ( 1, 0, 3, 0, ier )
                    CALL GSSMTH ( 2, dens, ier )
		    IF ( nout .gt. knumh2 ) THEN
C
C*			Use slanted dashed line fill for 5 day forecast.
C
	                CALL GSCOLR ( iwht, ier )
                        CALL GSFILL ( 1.5, 2, ier )
     	                CALL GLINE ( 'M', numln, slnlat, slnlon, ier )
     	                CALL GFILL ( 'M', numln, slnlat, slnlon, ier )
	                CALL GSCOLR ( iblk, ier )
		    END IF
C
C*		    Use solid fill for 3 day forecast.
C
                    CALL GSFILL ( 1.5, 1, ier )
     	            CALL GLINE ( 'M', numln6, slnlt6, slnln6, ier )
	            CALL GSCOLR ( iwht, ier )
     	            CALL GFILL ( 'M', numln6, slnlt6, slnln6, ier )
                END IF
	      ELSE
		plotit = .false.
		hvbkpt = .false.
		finish = .true.
            END IF
C
            IF ( hvbkpt ) THEN
C
C*              Plot the breakpoints for the watches and warnings.
C
                CALL GH_BKPL ( ibkpts, numb, ddev, iarea, icnt, iret)
            END IF
C
	    IF ( plotit ) THEN
C
C*              Draw map.
C
                CALL ST_INCH ( iblk, cblk, ier )
                CALL ST_LSTR ( cblk, lens, ier )
                latlon = cblk(:lens) // '/1/1//5;5//2'
                mapstr = cblk(:lens) // '/1/1'
C
 	        CALL IP_SVAR ( '$MAPFIL=hipowo.nws', ier )
                CALL GG_MAP  ( mapstr, ier )
C
C*              Draw latitude/longitude lines.
C
     	        CALL GG_LTLN ( latlon, ier )
C
C*              Plot state ids and country names.
C
                CALL GH_KGST ( iblk, ier )
C
C*	        Plot the label box.
C
                CALL GH_TCLB ( timstr, wtype, wname, wsped, wadnm, wwnd,
     +                       alat, alon, fmnlat, fmnlon, fmxlat,fmxlon,
     +                       tzone, iwht, iblk, idisp, namstr,
     +                       xkey, ykey, nknt, wdir,idays, iscale,
     +			     disstr, ier)
	    END IF
C
C*          Plot text for dissipating storm.
C
            IF ( plotit .and. ( idisp .ne. 0 ) ) THEN
                CALL ST_LSTR ( disstr, lent, ier )
                CALL ST_LSTR ( wname, lennam, ier )
                noprob = 'TROPICAL DEPRESSION ' // wname(:lennam)
     +                   // ' DISSIPATED AT ' // disstr(:lent)
                CALL ST_LCUC ( noprob, noprob, ier )
                CALL ST_LSTR ( noprob, lens, ier )
                CALL GSCOLR ( iblk, ier )
                CALL GSTEXT ( 22, 2, 1.2, 1, 111, 1, 2, ier )
 	        CALL GTEXT ( 'N', .5, .5, noprob (:lens), 0.0,
     +                       0, 0, ier )
            END IF
C
C*	    Plot the forecasted track.
C*	    Set the color and symbol for the current location.
C
            IF ( plotit .and. ( idisp .ge. 0 ) ) THEN
		ip = nstrm
C
C*		Draw line to connect the points.
C
                IF ( itrack .eq. 1 ) THEN
                   CALL GSSMTH ( 0, dens, ier )
                   iline = lwidth (1)
                   ilcol = lcolor (1)
                   IF  ( ddev(1:2) .eq. 'PS' ) THEN
                      iline = 2 * lwidth (1) + lwidth (1) / 2
                      IF ( ilcol .eq. 32 ) ilcol = 1
                      IF ( ilcol .eq. 31 ) ilcol = 32
		   END IF
                   CALL GSLINE ( ltype (1), 0, iline, 0, ier )
		   n3 = MIN0 ( nout, knumh2 )
                   CALL GSCOLR ( ilcol, ier )
                   CALL GLINE ( 'M', n3, blat, blon, ier )
		   IF ( nout .gt. knumh2 ) THEN
                      iline = lwidth (2)
                      ilcol = lcolor (2)
                      IF  ( ddev(1:2) .eq. 'PS' ) THEN
                         iline = 2 * lwidth (2) + lwidth (2)/2
                         IF ( ilcol .eq. 32 ) ilcol = 1
                         IF ( ilcol .eq. 31 ) ilcol = 32
		      END IF
                      CALL GSLINE ( ltype (2) , 0, iline, 0, ier )
		      next = nout - knumh2 + 1
                      CALL GSCOLR ( ilcol, ier )
		      CALL GLINE ( 'M', next, blat(knumh2), blon(knumh2),
     +				 ier )
		   END IF
                   CALL GSCOLR ( iblk, ier )
		END IF
C
C*              Plot the forecast points first.
C
                szm = szmrk(1)
                DO kk = 2, nknt
                    IF ( kk .eq. ( NUMH2 + 1 ) ) isize = szmrk(2)
C
C*                  For post-tropical storms
C
                    IF ( lext(kk-1,nstrm) .eq. 'P' ) THEN
                       sz2= szm - 0.5
                       CALL GSCOLR ( iblk, ier )
                       CALL GSMRKR ( 17, 0, szm, 2, ier )
                       CALL GMARK ('M',1,rlat(kk,ip),rlon(kk,ip),ier)
                       CALL GSCOLR ( iwht, ier )
                       CALL GSMRKR ( 17, 0, sz2, 2, ier )
                       CALL GMARK ('M',1,rlat(kk,ip),rlon(kk,ip),ier)
C
C*                   For tropical storms
C
                     ELSE
                       CALL GSMRKR ( 17, 0, szm, 2, ier )
                       CALL GSCOLR ( iblk, ier )
                       CALL GMARK ('M',1,rlat(kk,ip),rlon(kk,ip),ier)
                    END IF
                END DO
C
C*              Plot the current location markers next.
C
                CALL GSCOLR ( iblk, ier )
                sym = 3.
                CALL GSSPCL ( 1.2, 1, ier )
                CALL GSPCL ( 'M', 1, sym, rlat(1,ip), rlon(1,ip), 0, 0,
     +                       ier )
		coltag = 'w_lbl_curr_pos_mkr'
        	CALL ST_LSTR ( coltag, lens, ier )
 		CALL GH_COLR ( coltag(:lens), 17, ier )
                CALL GSSPCL ( ssize, iwidth, ier )
                CALL GSPCL ( 'M', 1, sym, rlat(1,ip), rlon(1,ip), 0, 0,
     +                       ier )
C
                CALL GSCOLR ( iblk, ier )
                CALL GSMRKR ( 17, 0, .8, 2, ier )
                CALL GMARK ( 'M', 1, rlat(1,ip), rlon(1,ip), ier )
C
C*              Plot current location and forecast track labels.
C
                ddate(1) = timstr
                CALL GH_KGFL ( alat, alon, ddate, nltln, tzone, dellon,
     +			       xkey, ykey, ier )
C
C*              Plot the letter for the storm intensity at each forecast
C*		point.
C
                CALL GSTEXT ( 22, 2, .7, 1, 111, 1, 2, ier )
                DO kk = 2, nknt
C
C*                  Set the color of the letter to:
C*                  white - for tropical storms
C*                  black - for extratropical storms
C
                    CALL GSCOLR ( iwht, ier )
                    IF ( lext(kk-1, nstrm) .eq. 'P' ) THEN
                      CALL GSCOLR ( iblk, ier )
                    END IF
		    IF ( mxwd ( kk - 1, ip ) .gt. 96 ) THEN
		       ii = 1
		    ELSE IF ( mxwd ( kk - 1, ip ) .ge. 64 ) THEN
		        ii = 2
		    ELSE IF ( mxwd ( kk - 1, ip ) .ge. 34 ) THEN
			ii = 3
		    ELSE
			ii = 4
		    END IF
                    CALL GTEXT ( 'M', rlat(kk,ip), rlon(kk,ip),
     +				 cyint ( ii ), 0., 0, 0, ier )
                END DO
                CALL GSCOLR ( iblk, ier )
            END IF
C
C*	    Flush the graphics buffer.
C
	    CALL GEPLOT ( ier )
            CALL GENANM ( ier )
C
C*	    Check for an acceptable display.
C
	    IF ( .not. finish ) THEN
                IF ( device(:2) .eq. 'XW' ) THEN
                    finish = .true.
                ELSE
                    ddev = device
                    CALL ST_LSTR(tnam, lenm, ier )
                    CALL ST_LSTR(ddev, lend, ier )
                    device = ddev(:lend) // '|'
     +                    // tnam(:lenm)//'|'//dims
                    CALL GG_SDEV ( device, ier )
                    CALL GSTANM ( ier )
                END IF
	    END IF
	END DO
C
C*	Reset the saved attributes.
C
	CALL GH_REST ( ier )
C*
	RETURN
	END


!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
module salmon_pp

  implicit none

  type pp_info
    real(8) :: zion
    integer :: lmax,lmax0
    integer :: nrmax,nrmax0
    logical :: flag_nlcc
    character(2),allocatable :: atom_symbol(:)
    real(8),allocatable :: rmass(:)
    integer,allocatable :: mr(:)
    integer,allocatable :: lref(:)
    integer,allocatable :: nrps(:)
    integer,allocatable :: mlps(:)
    integer,allocatable :: zps(:)
    integer,allocatable :: nrloc(:)
    real(8),allocatable :: rloc(:)
    real(8),allocatable :: rps(:)
    real(8),allocatable :: anorm(:,:)
    integer,allocatable :: inorm(:,:)
    real(8),allocatable :: rad(:,:)
    real(8),allocatable :: radnl(:,:)
    real(8),allocatable :: vloctbl(:,:)
    real(8),allocatable :: dvloctbl(:,:)
    real(8),allocatable :: udvtbl(:,:,:)
    real(8),allocatable :: dudvtbl(:,:,:)
    real(8),allocatable :: rho_nlcc_tbl(:,:)
    real(8),allocatable :: tau_nlcc_tbl(:,:)
    real(8),allocatable :: upp_f(:,:,:)
    real(8),allocatable :: vpp_f(:,:,:)
    real(8),allocatable :: upp(:,:)
    real(8),allocatable :: dupp(:,:)
    real(8),allocatable :: vpp(:,:)
    real(8),allocatable :: dvpp(:,:)
  end type

  type pp_grid
    integer :: nps
    integer,allocatable :: mps(:)
    integer,allocatable :: jxyz(:,:,:)
    integer,allocatable :: jxx(:,:)
    integer,allocatable :: jyy(:,:)
    integer,allocatable :: jzz(:,:)
    real(8),allocatable :: uv(:,:)
    real(8),allocatable :: duv(:,:,:)
    integer :: nlma
    integer,allocatable :: lma_tbl(:,:)
    integer,allocatable :: ia_tbl(:)
    real(8),allocatable :: rinv_uvu(:)
  end type

  contains

  subroutine init_pp(pp,nrmax,lmax,flag_nlcc)
    use salmon_global,only : nelem,lloc_ps
    use salmon_global,only : pseudo_file
    use salmon_global,only : n_Yabana_Bertsch_psformat,n_ABINIT_psformat, &
                             n_ABINITFHI_psformat,n_FHI_psformat, &
                             ps_format,izatom,nelem
    use salmon_parallel, only: nproc_group_global, nproc_id_global
    use salmon_communication, only: comm_bcast, comm_is_root
    implicit none
    type(pp_info) :: pp
    integer, parameter :: nrmax0=50000, lmax0=4
    integer,intent(in) :: nrmax,lmax
    logical,intent(in) :: flag_nlcc
    integer :: ik
    character(256) :: ps_file
    integer :: ips_type,nlen_psf

    allocate(pp%atom_symbol(nelem))
    allocate(pp%rmass(nelem))
    allocate(pp%mr(nelem))

    if (comm_is_root(nproc_id_global)) then

      do ik=1,nelem

        ps_file = trim(pseudo_file(ik))
        nlen_psf = len_trim(ps_file)
        if(ps_file(nlen_psf+1-8:nlen_psf) == '_rps.dat')then
          ips_type = n_Yabana_Bertsch_psformat
          ps_format(ik) = 'KY'
          call read_mr_yb(pp,ik,ps_file)
        else if(ps_file(nlen_psf+1-6:nlen_psf) == '.pspnc')then
          ips_type = n_ABINIT_psformat
          ps_format(ik) = 'ABINIT'
          call read_mr_abinit(pp,ik,ps_file)
        else if(ps_file(nlen_psf+1-4:nlen_psf) == '.fhi')then
          ips_type = n_ABINITFHI_psformat
          ps_format(ik) = 'ABINITFHI'
          call read_mr_abinitfhi(pp,ik,ps_file)
        else if(ps_file(nlen_psf+1-4:nlen_psf) == '.cpi')then
          ips_type = n_FHI_psformat
          ps_format(ik) = 'FHI'
          call read_mr_fhi(pp,ik,ps_file)
        else
          stop 'Unprepared ps_format is required input_pseudopotential_YS'
        end if

!! --- Making prefix ---
!      select case (ipsfileform(ik))
!      case(n_Yabana_Bertsch_psformat)   ; ps_postfix = '_rps.dat'
!      case(n_ABINIT_psformat)           ; ps_postfix = '.pspnc'
!      case(n_ABINITFHI_psformat)        ; ps_postfix = '.fhi'
!      case(n_FHI_psformat)              ; ps_postfix = '.cpi'
!!    case('ATOM')      ; ps_postfix = '.psf' !Not implemented yet
!      case default ; stop 'Unprepared ps_format is required input_pseudopotential_YS'
!      end select

! --- input pseudopotential and wave function ---
        select case (izatom(ik))
        case (1) ; pp%atom_symbol(ik) = 'H ' ; pp%rmass(ik)=1.d0
        case (2) ; pp%atom_symbol(ik) = 'He' ; pp%rmass(ik)=4.d0
        case (3) ; pp%atom_symbol(ik) = 'Li' ; pp%rmass(ik)=7.d0
        case (4) ; pp%atom_symbol(ik) = 'Be' ; pp%rmass(ik)=9.d0
        case (5) ; pp%atom_symbol(ik) = 'B ' ; pp%rmass(ik)=11.d0
        case (6) ; pp%atom_symbol(ik) = 'C ' ; pp%rmass(ik)=12.d0
        case (7) ; pp%atom_symbol(ik) = 'N ' ; pp%rmass(ik)=14.d0
        case (8) ; pp%atom_symbol(ik) = 'O ' ; pp%rmass(ik)=16.d0
        case (9) ; pp%atom_symbol(ik) = 'F ' ; pp%rmass(ik)=19.d0
        case(10) ; pp%atom_symbol(ik) = 'Ne' ; pp%rmass(ik)=20.d0
        case(11) ; pp%atom_symbol(ik) = 'Na' ; pp%rmass(ik)=23.d0
        case(12) ; pp%atom_symbol(ik) = 'Mg' ; pp%rmass(ik)=24.d0
        case(13) ; pp%atom_symbol(ik) = 'Al' ; pp%rmass(ik)=27.d0
        case(14) ; pp%atom_symbol(ik) = 'Si' ; pp%rmass(ik)=28.d0
        case(15) ; pp%atom_symbol(ik) = 'P ' ; pp%rmass(ik)=31.d0
        case(16) ; pp%atom_symbol(ik) = 'S ' ; pp%rmass(ik)=32.d0
        case(17) ; pp%atom_symbol(ik) = 'Cl' ; pp%rmass(ik)=35.d0
        case(18) ; pp%atom_symbol(ik) = 'Ar' ; pp%rmass(ik)=40.d0
        case(19) ; pp%atom_symbol(ik) = 'K ' ; pp%rmass(ik)=39.d0
        case(20) ; pp%atom_symbol(ik) = 'Ca' ; pp%rmass(ik)=40.d0
        case(21) ; pp%atom_symbol(ik) = 'Sc' ; pp%rmass(ik)=45.d0
        case(22) ; pp%atom_symbol(ik) = 'Ti' ; pp%rmass(ik)=48.d0
        case(23) ; pp%atom_symbol(ik) = 'V ' ; pp%rmass(ik)=51.d0
        case(24) ; pp%atom_symbol(ik) = 'Cr' ; pp%rmass(ik)=52.d0
        case(25) ; pp%atom_symbol(ik) = 'Mn' ; pp%rmass(ik)=55.d0
        case(26) ; pp%atom_symbol(ik) = 'Fe' ; pp%rmass(ik)=56.d0
        case(27) ; pp%atom_symbol(ik) = 'Co' ; pp%rmass(ik)=59.d0
        case(28) ; pp%atom_symbol(ik) = 'Ni' ; pp%rmass(ik)=59.d0
        case(29) ; pp%atom_symbol(ik) = 'Cu' ; pp%rmass(ik)=63.d0
        case(30) ; pp%atom_symbol(ik) = 'Zn' ; pp%rmass(ik)=65.d0
        case(31) ; pp%atom_symbol(ik) = 'Ga' ; pp%rmass(ik)=69.d0
        case(32) ; pp%atom_symbol(ik) = 'Ge' ; pp%rmass(ik)=73.d0
        case(33) ; pp%atom_symbol(ik) = 'As' ; pp%rmass(ik)=75.d0
        case(34) ; pp%atom_symbol(ik) = 'Se' ; pp%rmass(ik)=79.d0
        case(35) ; pp%atom_symbol(ik) = 'Br' ; pp%rmass(ik)=80.d0
        case(36) ; pp%atom_symbol(ik) = 'Kr' ; pp%rmass(ik)=84.d0
        case(37) ; pp%atom_symbol(ik) = 'Rb' ; pp%rmass(ik)=85.d0
        case(38) ; pp%atom_symbol(ik) = 'Sr' ; pp%rmass(ik)=88.d0
        case(39) ; pp%atom_symbol(ik) = 'Y ' ; pp%rmass(ik)=89.d0
        case(40) ; pp%atom_symbol(ik) = 'Zr' ; pp%rmass(ik)=91.d0
        case(41) ; pp%atom_symbol(ik) = 'Nb' ; pp%rmass(ik)=93.d0
        case(42) ; pp%atom_symbol(ik) = 'Mo' ; pp%rmass(ik)=96.d0
        case(43) ; pp%atom_symbol(ik) = 'Tc' ; pp%rmass(ik)=98.d0
        case(44) ; pp%atom_symbol(ik) = 'Ru' ; pp%rmass(ik)=101.d0
        case(45) ; pp%atom_symbol(ik) = 'Rh' ; pp%rmass(ik)=103.d0
        case(46) ; pp%atom_symbol(ik) = 'Pd' ; pp%rmass(ik)=106.d0
        case(47) ; pp%atom_symbol(ik) = 'Ag' ; pp%rmass(ik)=108.d0
        case(48) ; pp%atom_symbol(ik) = 'Cd' ; pp%rmass(ik)=112.d0
        case(49) ; pp%atom_symbol(ik) = 'In' ; pp%rmass(ik)=115.d0
        case(50) ; pp%atom_symbol(ik) = 'Sn' ; pp%rmass(ik)=119.d0
        case(51) ; pp%atom_symbol(ik) = 'Sb' ; pp%rmass(ik)=122.d0
        case(52) ; pp%atom_symbol(ik) = 'Te' ; pp%rmass(ik)=128.d0
        case(53) ; pp%atom_symbol(ik) = 'I ' ; pp%rmass(ik)=127.d0
        case(54) ; pp%atom_symbol(ik) = 'Xe' ; pp%rmass(ik)=131.d0
        case(55) ; pp%atom_symbol(ik) = 'Cs' ; pp%rmass(ik)=133.d0
        case(56) ; pp%atom_symbol(ik) = 'Ba' ; pp%rmass(ik)=137.d0
        case(57) ; pp%atom_symbol(ik) = 'La' ; pp%rmass(ik)=139.d0
        case(58) ; pp%atom_symbol(ik) = 'Ce' ; pp%rmass(ik)=140.d0
        case(59) ; pp%atom_symbol(ik) = 'Pr' ; pp%rmass(ik)=141.d0
        case(60) ; pp%atom_symbol(ik) = 'Nd' ; pp%rmass(ik)=144.d0
        case(61) ; pp%atom_symbol(ik) = 'Pm' ; pp%rmass(ik)=145.d0
        case(62) ; pp%atom_symbol(ik) = 'Sm' ; pp%rmass(ik)=150.d0
        case(63) ; pp%atom_symbol(ik) = 'Eu' ; pp%rmass(ik)=152.d0
        case(64) ; pp%atom_symbol(ik) = 'Gd' ; pp%rmass(ik)=157.d0
        case(65) ; pp%atom_symbol(ik) = 'Tb' ; pp%rmass(ik)=159.d0
        case(66) ; pp%atom_symbol(ik) = 'Dy' ; pp%rmass(ik)=164.d0
        case(67) ; pp%atom_symbol(ik) = 'Ho' ; pp%rmass(ik)=165.d0
        case(68) ; pp%atom_symbol(ik) = 'Er' ; pp%rmass(ik)=167.d0
        case(69) ; pp%atom_symbol(ik) = 'Tm' ; pp%rmass(ik)=169.d0
        case(70) ; pp%atom_symbol(ik) = 'Yb' ; pp%rmass(ik)=173.d0
        case(71) ; pp%atom_symbol(ik) = 'Lu' ; pp%rmass(ik)=175.d0
        case(72) ; pp%atom_symbol(ik) = 'Hf' ; pp%rmass(ik)=178.d0
        case(73) ; pp%atom_symbol(ik) = 'Ta' ; pp%rmass(ik)=181.d0
        case(74) ; pp%atom_symbol(ik) = 'W ' ; pp%rmass(ik)=184.d0
        case(75) ; pp%atom_symbol(ik) = 'Re' ; pp%rmass(ik)=186.d0
        case(76) ; pp%atom_symbol(ik) = 'Os' ; pp%rmass(ik)=190.d0
        case(77) ; pp%atom_symbol(ik) = 'Ir' ; pp%rmass(ik)=192.d0
        case(78) ; pp%atom_symbol(ik) = 'Pt' ; pp%rmass(ik)=195.d0
        case(79) ; pp%atom_symbol(ik) = 'Au' ; pp%rmass(ik)=197.d0
        case(80) ; pp%atom_symbol(ik) = 'Hg' ; pp%rmass(ik)=201.d0
        case(81) ; pp%atom_symbol(ik) = 'Tl' ; pp%rmass(ik)=204.d0
        case(82) ; pp%atom_symbol(ik) = 'Pb' ; pp%rmass(ik)=207.d0
        case(83) ; pp%atom_symbol(ik) = 'Bi' ; pp%rmass(ik)=209.d0
        case default ; stop 'Unprepared atomic data is called input_pseudopotential_YS'
        end select

      end do

    end if

    call comm_bcast(pp%atom_symbol,nproc_group_global)
    call comm_bcast(pp%rmass,nproc_group_global)
    call comm_bcast(ps_format,nproc_group_global)

    pp%lmax0=lmax0

    pp%nrmax0=nrmax0

    pp%nrmax=nrmax
    pp%lmax=lmax

    allocate(pp%lref(1:nelem))
    pp%lref(1:nelem)=lloc_ps(1:nelem)

    allocate(pp%nrps(1:nelem))
    allocate(pp%rps(1:nelem))
    allocate(pp%mlps(1:nelem))
    allocate(pp%zps(1:nelem))
    allocate(pp%nrloc(1:nelem))
    allocate(pp%rloc(1:nelem))

    allocate(pp%anorm(0:lmax,nelem))
    allocate(pp%inorm(0:lmax,nelem))

    allocate(pp%rad(nrmax,nelem))
    allocate(pp%radnl(nrmax,nelem))

    allocate(pp%vloctbl(nrmax,nelem))
    allocate(pp%dvloctbl(nrmax,nelem))
    allocate(pp%udvtbl(nrmax,0:lmax,nelem))
    allocate(pp%dudvtbl(nrmax,0:lmax,nelem))

    allocate(pp%rho_nlcc_tbl(nrmax,nelem))
    allocate(pp%tau_nlcc_tbl(nrmax,nelem))

    allocate(pp%vpp(0:nrmax0,0:lmax0),pp%upp(0:nrmax0,0:lmax0))
    allocate(pp%dvpp(0:nrmax0,0:lmax0),pp%dupp(0:nrmax0,0:lmax0))
    allocate(pp%vpp_f(0:nrmax0,0:lmax0,nelem),pp%upp_f(0:nrmax0,0:lmax0,nelem))

    pp%flag_nlcc=flag_nlcc

  end subroutine init_pp
!======================================================================
  subroutine read_mr_yb(pp,ik,ps_file)
    implicit none
    type(pp_info) :: pp
    integer :: ik
    character(256) :: ps_file

    open(4,file=ps_file,status='old')
    read(4,*) pp%mr(ik)
    close(4)
    return

  end subroutine read_mr_YB
!======================================================================
  subroutine read_mr_abinit(pp,ik,ps_file)
    implicit none
    type(pp_info) :: pp
    integer :: ik
    character(256) :: ps_file
    real(8) :: zatom, zion, pspdat,pspcod,pspxc,lmaxabinit,lloc,mmax,r2well
    character(1) :: dummy_text

    open(4,file=ps_file,status='old')
    read(4,*) dummy_text
    read(4,*) zatom, zion, pspdat
    read(4,*) pspcod,pspxc,lmaxabinit,lloc,mmax,r2well
    close(4)

    pp%mr(ik)=mmax

  end subroutine read_mr_ABINIT
!======================================================================
  subroutine read_mr_abinitfhi(pp,ik,ps_file)
    implicit none
    type(pp_info) :: pp
    integer :: ik
    integer :: i
    character(256) :: ps_file
    character(1) :: dummy_text

    open(4,file=ps_file,status='old')
    do i=1,18
      read(4,*) dummy_text
    end do
    read(4,*) pp%mr(ik)
    close(4)

  end subroutine read_mr_abinitfhi

!======================================================================
  subroutine read_mr_fhi(pp,ik,ps_file)
    implicit none
    type(pp_info) :: pp
    integer :: ik
    integer :: i
    character(256) :: ps_file
    character(1) :: dummy_text

    open(4,file=ps_file,status='old')
    do i=1,11
      read(4,*) dummy_text
    end do
    read(4,*) pp%mr(ik)
    close(4)

  end subroutine read_mr_fhi

end module salmon_pp


      SUBROUTINE OFP
C
C     THE OUTPUT FILE PROCESSOR
C
C     THIS SUBROUTINE IS THE MAIN AND ONLY DRIVER.
C     OFP1 OUTPUTS HEADINGS ONLY.
C
      IMPLICIT INTEGER (A-Z)
      LOGICAL          AXIC,FLUID,TEMPER,ONEFIL,HEADNG,SOLSET,ELEMEN,
     1                 PNCHED,HEAT,GPFB,ESE,DUMMY,GPST,EOR,PACK,STRAIN
      INTEGER          REAL(10),IMAG(5),ISAVE(20),GSE(4),I15BLK(2),
     1                 FILEX(6),B(23,4),FMT(300),IOUT(100),TSAVE(96),
     2                 SCAN(2),ID(50),BUFF(1),OF(56)
      REAL             FREAL(10),FIMAG(2),OUT(100)
      DOUBLE PRECISION DOUT(50)
CWKBI
      CHARACTER*1      CFMT(300)
      CHARACTER        UFM*23,UWM*25,UIM*29,SFM*25,SWM*27
      COMMON /XMSSG /  UFM,UWM,UIM,SFM,SWM
      COMMON /BLANK /  ICARD,OPTION(2)
      COMMON /SYSTEM/  KSYSTM(65)
      COMMON /OFPCOM/  TEMPER,MPUNCH
      COMMON /OFPBD1/  D(1)
      COMMON /OFPBD5/  ESINGL(64),E(1)
CZZ   COMMON /ZZOFPX/  CORE(1)
      COMMON /ZZZZZZ/  CORE(20000)
      COMMON /OFP1ID/  IDM(2)
      COMMON /OUTPUT/  HEAD(96)
      EQUIVALENCE      (KSYSTM( 1),SYSBUF), (KSYSTM( 2),L     ),
     1                 (KSYSTM( 9),MAXLNS), (KSYSTM(12),LINE  ),
     2                 (KSYSTM(38),AXIF  ), (KSYSTM(56),ITHERM),
     3                 (FREAL (1),REAL(1)), (FIMAG (1),IMAG(1)),
     4                 (ID    (3),IELTYP ), (IOUT(1),OUT(1),DOUT(1)),
     5                 (L1, OF(1),CORE(1)), (L2,OF(2)), (L3,OF(3)),
     6                 (L4, OF(4)), (L5,OF(5)), (ID(1),OF(6)),
     7                 (BUFF(1),OF(56))
CWKBI
      EQUIVALENCE      ( CFMT, FMT )
      DATA    PE    /  4H1P,E /,   PF   / 4H0P,F /
      DATA    E236  /  4H23.6 /,   F236 / 4H14.1 /
      DATA    E156  /  4H15.6 /,   F156 / 4H6.1  /
      DATA    I8    /  4H,I8, /,   I12  / 4H,I11 /
      DATA    I2X   /  4H2X   /,   I2XX / 4H,2X  /
      DATA    I1X   /  4H(1X  /,   I1XX / 4H,1X  /
      DATA    ISTAR /  4H,1H* /,   I15X / 4H/14X /
      DATA    IH0   /  4H/1H0 /,   I1H0 / 4H(1H0 /
      DATA    I9X   /  4H,9X  /,   I6X  / 4H,6X  /
      DATA    F174  /  4H17.4 /
      DATA    STATIC,  REIGEN  ,   FREQ ,  TRANS  , BK1  , CEIGEN  /
     1        1     ,  2       ,   5    ,  6      , 8    , 9       /
      DATA    A4    ,  COMMA   ,   CPAREN, OPAREN  /
     1        4HA4  ,  4H,     ,   4H)   , 4H(     /
      DATA    EEND  /  195    /,   I15BLK/ 4HA4,  , 4H11X /,
     1        GSE   /  4HG     ,   4HS   , 4HE    , 4HM   /
      DATA    FILEX /  101, 102,  103,104, 105    , 106   /
      DATA    IBLANK,  E9PT1  /    4H    , 195    /
      DATA    IHEAT /  4HHEAT /,   CENTER/ 4HTER  /
      DATA    PHASE /  4H1P9E /,   SCAN  / 4HSCAN , 4HNED /
      DATA    HEX1  ,  HEX2, HEX3 /4HHEX1, 4HHEX2 , 4HHEX3/
C
C
C     THE FOLLOWING ARE ZERO POINTERS TO THE DATA-BLOCK AND LINE-SET
C     SELECTION LISTS.  TO THIS THE SUBSET SELECTION POINTER IS ADDED.
C     THE SUBSET SELECTION POINTER IS BASED ON INFORMATION IN THE ID
C     RECORD.
C
C     A MINUS ONE IN THE FOLLOWING ARRAY INDICATES AN UNDEFINED OUTPUT.
C
C            S O R T - I    S O R T - I I
C          *************** ****************        ZERO-BASE
C          REAL    COMPLEX REAL    COMPLEX    POINTERS INTO C-ARY
C     *************************************   *******************
C     DISPLACEMENT VECTOR
      DATA B( 1,1),B( 1,2),B( 1,3),B( 1,4) /    0,   4,   2,   6 /
C
C     LOAD VECTOR
      DATA B( 2,1),B( 2,2),B( 2,3),B( 2,4) /    8,  12,  10,  14 /
C
C     SPCF VECTOR
      DATA B( 3,1),B( 3,2),B( 3,3),B( 3,4) /   16,  20,  18,  22 /
C
C     ELEMENT FORCE   (ZERO POINTERS INTO OVERLAY BLOCK DATA)
      DATA B( 4,1),B( 4,2),B( 4,3),B( 4,4) /    0,   0,   0,   0 /
C
C     ELEMENT STRESS  (ZERO POINTERS FOR OVERLAY BLOCK DATA)
      DATA B( 5,1),B( 5,2),B( 5,3),B( 5,4) /    0,   0,   0,   0 /
C
C     EIGENVALUE SUMMARY
      DATA B( 6,1),B( 6,2),B( 6,3),B( 6,4) /   38,  39,  -1,  -1 /
C
C     EIGENVECTOR
      DATA B( 7,1),B( 7,2),B( 7,3),B( 7,4) /   72,  40,  -1,  -1 /
C
C     GPST
      DATA B( 8,1),B( 8,2),B( 8,3),B( 8,4) /   73,  -1,  -1,  -1 /
C
C     EIGENVALUE ANALYSIS SUMMARY
      DATA B( 9,1),B( 9,2),B( 9,3),B( 9,4) /   64,  68,  -1,  -1 /
C
C     VELOCITY VECTOR
      DATA B(10,1),B(10,2),B(10,3),B(10,4) /   24,  30,  26,  32 /
C
C     ACCELERATION VECTOR
      DATA B(11,1),B(11,2),B(11,3),B(11,4) /   25,  34,  27,  36 /
C
C     NON-LINEAR-FORCE VECTOR
      DATA B(12,1),B(12,2),B(12,3),B(12,4) /   28,  -1,  29,  -1 /
C
C     GRID-POINT-WEIGHT-OUTPUT
      DATA B(13,1),B(13,2),B(13,3),B(13,4) /   -1,  -1,  -1,  -1 /
C
C     EIGENVECTOR (SOLUTION SET FROM VDR)
      DATA B(14,1),B(14,2),B(14,3),B(14,4) /   -1,  60,  -1,  62 /
C
C     DISP-VECTOR (SOLUTION SET FROM VDR)
      DATA B(15,1),B(15,2),B(15,3),B(15,4) /   42,  44,  43,  46 /
C
C     VELO-VECTOR (SOLUTION SET FROM VDR)
      DATA B(16,1),B(16,2),B(16,3),B(16,4) /   48,  50,  49,  52 /
C
C     ACCE-VECTOR (SOLUTION SET FROM VDR)
      DATA B(17,1),B(17,2),B(17,3),B(17,4) /   54,  56,  55,  58 /
C
C     ELEMENT STRAIN ENERGY (FROM GPFDR)
      DATA B(18,1),B(18,2),B(18,3),B(18,4) /   74,  -1,  -1,  -1 /
C
C     GRID POINT FORCE BALANCE (FROM GPFDR)
      DATA B(19,1),B(19,2),B(19,3),B(19,4) /   76,  -1,  -1,  -1 /
C
C     MPCFORCE VECTOR
      DATA B(20,1),B(20,2),B(20,3),B(20,4) /   78,  -1,  -1,  -1 /
C
C     ELEMENT STRAIN/CURVATURE (ZERO POINTER FOR OVERLAY BLOCK DATA)
      DATA B(21,1),B(21,2),B(21,3),B(21,4) /    0,  -1,  -1,  -1 /
C
C     STRESSES IN LAYERED COMPOSITE ELEMENTS (ZERO POINTER)
      DATA B(22,1),B(22,2),B(22,3),B(22,4) /    0,   0,   0,   0 /
C
C     FORCES IN LAYERED COMPOSITE ELEMENTS   (ZERO POINTER)
      DATA B(23,1),B(23,2),B(23,3),B(23,4) /    0,   0,   0,   0 /
C     ************************************   *******************
C
C     SAVE OLD TITLES WHATEVER THEY BE AND RESTORE BEFORE RETURNING
C
      CALL TOTAPE (3,BUFF(1))
      HEAT = .FALSE.
      IF (ITHERM .NE. 0) HEAT = .TRUE.
      OPTION(1) = 0
      IF (HEAT) OPTION(1) = IHEAT
      ONEFIL = .FALSE.
      GO TO 10
C
C
      ENTRY OFPDMP (IFILE1)
C     =====================
C
      ONEFIL = .TRUE.
   10 DO 20 I = 1,96
   20 TSAVE(I) = HEAD(I)
C
      ICORE = KORSZ(BUFF)
      IF (ICORE .GE. SYSBUF) GO TO 40
      WRITE  (6,30) UWM,ICORE,SYSBUF
   30 FORMAT (A25,' 2043, OFP HAS INSUFFICIENT CORE FOR ONE GINO ',
     1       'BUFFER ****    OFP NOT EXECUTED.')
      RETURN
C
   40 LINE  = 0
      IFILE = 0
C
C     LOOP FOR 6 FILES
C
   50 IFILE = IFILE + 1
      IF (ONEFIL .AND. IFILE.GT.1) GO TO 2060
      FILE = FILEX(IFILE)
      IF (ONEFIL) FILE = IFILE1
      CALL OPEN (*2050,FILE,BUFF(1),0)
      FROM = 55
      CALL FWDREC (*2020,FILE)
   60 CALL READ (*2040,*2040,FILE,  ID(1),50,0,FLAG)
      CALL READ (*2040,*2040,FILE,HEAD(1),96,1,FLAG)
      AXIC   = .FALSE.
      TEMPER = .FALSE.
      DUMMY  = .FALSE.
      GPST   = .FALSE.
      SORT   =  1
      PNCHED = .FALSE.
      HEADNG = .FALSE.
      GPFB   = .FALSE.
      ESE    = .FALSE.
      STRAIN = .FALSE.
C
C     COMPUTE I AND J, THE B ARRAY SUBSCRIPTS
C
      J = ID(2)/1000
      I = ID(2) - J*1000
      J = J + 1
      IF (I.NE.4 .AND. I.NE.5 .AND. I.NE.21) GO TO 70
      ICURV = ID(3)/1000
      ID(3) = ID(3) - 1000*ICURV
C
   70 PACK   = .FALSE.
      SOLSET = .FALSE.
      FLUID  = .FALSE.
      IF (AXIF .NE. 0) FLUID = .TRUE.
      ELEMEN = .FALSE.
      IAPP = ID(1)/10
      NADD = 1
      FROM = 75
      IF (J .GT. 4) GO TO 2020
      FROM = 77
      IF (J) 2020,80,80
   80 FROM = 80
      IF (I.LT.1 .OR. I.GT.23) GO TO 2020
      IF (J .GT. 2) SORT = 2
      IF (J.NE.3 .OR. IAPP.NE.STATIC) GO TO 120
      IF (HEAD(74).EQ.SCAN(1) .AND. HEAD(75).EQ.SCAN(2)) GO TO 100
      DO 90 IHD = 65,96
   90 HEAD(IHD) = IBLANK
      GO TO 120
  100 DO 110 IHD = 65,72
      IF (IHD .GE. 68) HEAD(IHD+22) = IBLANK
  110 HEAD(IHD) = IBLANK
  120 GO TO (150,150,150,230,240,270,150,290,300,150,
     1       150,150,340,380,380,380,380,390,400,220,
     2       410,420,420), I
  150 PACK = .TRUE.
      IF (ID(3) .EQ. 1000) AXIC = .TRUE.
      GO TO (200,210,220,160,160,160,280,160,160,310,320,330), I
  160 CALL MESAGE (-61,0,0)
C
C     DISPLACEMENT VECTOR
C
  200 IF (J.EQ.3 .AND. IAPP.EQ.TRANS) NADD = 7
      IF (OPTION(1) .NE. IHEAT) GO TO 500
      IF (I.EQ.1 .AND. (J.EQ.1 .OR. J.EQ.3)) TEMPER =.TRUE.
      GO TO 500
C
C     LOAD VECTOR
C
  210 IF (J.EQ.3 .AND. IAPP.EQ.TRANS) NADD = 7
      GO TO 500
C
C     SPCF VECTOR, MPCF VECTOR
C
  220 IF (J.EQ.3 .AND. IAPP.EQ.TRANS) NADD = 7
CWKBI 11/93 SPR93007
      PACK = .TRUE.
      GO TO 500
C
C     ELEMENT FORCE, ELEMENT STRESS
C
  230 CONTINUE
  240 FROM = 240
      IF (ID(3).LT. 1 .OR.  ID(3).GT.100) GO TO 2020
      IF (ID(3).GT.52 .AND. ID(3).LT. 62) DUMMY = .TRUE.
      ELEMEN = .TRUE.
      IOPT   = 2
      IF (ICURV.GT.0 .AND. J.EQ.1) GO TO 260
      IF (ICURV.GT.0 .AND. (J.EQ.2 .OR. J.EQ.4)) GO TO 250
      NADD = 6*(ID(3)-1) + 1
      IF (J.EQ.2 .OR. J.EQ.4) NADD = NADD*2 - 1
      GO TO 500
  250 FROM = 250
      IF (ICURV .GT. 1) GO TO 2020
      NADD = 0
      IF (ID(3) .EQ.  6) NADD =  1
      IF (ID(3) .EQ. 17) NADD = 13
      IF (ID(3) .EQ. 18) NADD = 25
      IF (ID(3) .EQ. 19) NADD = 37
      GO TO 500
C
C     ELEMENT STRESS IN MATERIAL COORDINATE SYSTEM
C
  260 FROM = 260
      IF (ICURV .GT. 2) GO TO 2020
      NADD = 0
      IF (ID(3) .EQ.  6) NADD =  1
      IF (ID(3) .EQ. 17) NADD =  7
      IF (ID(3) .EQ. 18) NADD = 13
      IF (ID(3) .EQ. 19) NADD = 19
      IF (ICURV .EQ.  2) NADD = 25
      GO TO 500
C
C     EIGENVALUE SUMMARY
C
  270 CONTINUE
      GO TO 500
C
C     EIGENVECTOR
C
  280 CONTINUE
      GO TO 500
C
C     GPST
C
  290 GPST = .TRUE.
      GO TO 500
C
C     EIGENVALUE ANALYSIS SUMMARY
C       ID(3) = 1  DETERMINANT METHOD TABLE
C       ID(3) = 2  INVERSE POWER TABLE
C       ID(3) = 3  DETERMINANT METHOD SWEPT FUNCTION DATA VECTORS
C       ID(3) = 4  UPPER HESSENBERG METHOD TABLE
C
  300 NADD = 6*(ID(3)-1) + 1
      FROM = 300
      IF (ID(3) .GT. 4) GO TO 2020
      GO TO 500
C
C     VELOCITY VECTOR
C
  310 CONTINUE
      GO TO 500
C
C     ACCELERATION VECTOR
C
  320 CONTINUE
      GO TO 500
C
C     NON-LINERAR FORCE VECTOR
C
  330 SOLSET = .TRUE.
      GO TO 500
C
C     GRID-POINT-WEIGHT-OUTPUT
C     (FROM = 345 AND 355 ARE SETUP IN OFPGPW)
C
  340 FROM = 340
      IF (J .GT. 1) GO TO 2020
      CALL OFPGPW (*2020,FILE,DOUT,FROM)
      GO TO 60
C
C     EIGENVECTOR, DISPLACEMENT, VELOCITY, ACCELERATION
C     (VDR OUTPUT ONLY)
C
  380 PACK   = .TRUE.
      SOLSET = .TRUE.
      GO TO 500
C
C     ELEMENT STRAIN ENERGY.
C
  390 ESE  = .TRUE.
      IOPT =  3
      GO TO 500
C
C     GRID POINT FORCE BALANCE.
C
  400 GPFB = .TRUE.
      IOPT =  4
      LASTID = 0
      GO TO 500
C
C     ELEMENT STRAIN/CURVATURE
C
  410 FROM = 410
      IF (ID(3).NE.6 .AND. ID(3).NE.17 .AND. ID(3).NE.18 .AND.
CWKBR NCL93012 3/94     1    ID(3).NE.19) GO TO 2020
     1    ID(3).NE.19 .AND. ID(3).NE.64 .AND. ID(3).NE.83) GO TO 2020
      FROM = 415
      IF (ICURV .GT. 2) GO TO 2020
      STRAIN = .TRUE.
      ELEMEN = .TRUE.
      IOPT = 2
      NADD = 0
      IF (ID(3) .EQ.  6) NADD =  1
      IF (ID(3) .EQ. 17) NADD =  7
      IF (ID(3) .EQ. 18) NADD = 13
      IF (ID(3) .EQ. 19) NADD = 19
CWKBNB NCL93012 3/94
      IF (ID(3) .EQ. 64) NADD = 55
      IF (ID(3) .EQ. 83) NADD = 61
CWKBNE NCL93012 3/94
      IF (ICURV .EQ.  1) NADD = NADD + 24
      IF (ICURV .EQ.  2) NADD = 49
      GO TO 500
C
C     STRESSES AND FORCES IN LAYERED COMPOSITE ELEMENTS
C
  420 CALL OFCOMP (*60,FILE,J,IELTYP,IAPP,HEADNG,PNCHED,I)
      GO TO 60
C
  500 FROM = 500
      IF (B(I,J) .EQ. -1) GO TO 2020
      IF (PACK ) IOPT = 1
      POINT = NADD + B(I,J)*6
C
C     IS THIS MAGNITUDE / PHASE OUTPUT
C
      IF (ID(9).EQ.3 .AND. (IAPP.EQ.FREQ .OR. IAPP.EQ.CEIGEN))
     1    POINT = POINT + 6
C
      IF (STRAIN) GO TO 660
      IF (ELEMEN) GO TO 510
C
C     CALL NON-STRESS AND NON-FORCE OVERLAY.
C
      CALL OFPMIS (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 505
      GO TO 690
C
C     CALL PARTICULAR STRESS OR FORCE OVERLAY CONSIDERING
C     REAL, COMPLEX, SORT1, SORT2.
C
  510 IF (DUMMY) GO TO 580
      IF (ICURV .LE. 0) GO TO 515
      IF (J .EQ. 1) GO TO 650
      IF (J .EQ. 2) GO TO 670
      IF (J .EQ. 4) GO TO 680
  515 ITYPE = J + 4*(5-I)
      GO TO (520,530,540,560,570,610,620,640), ITYPE
C
  520 CALL OFPRS1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 525
      GO TO 690
C
  530 CALL OFPCS1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 535
      GO TO 690
C
  540 IF (IAPP .NE. STATIC) GO TO 550
      CALL OFRS2S (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 545
      GO TO 690
  550 CALL OFPRS2 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 555
      GO TO 690
C
  560 CALL OFPCS2 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 565
      GO TO 690
C
  570 CALL OFPRF1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 575
      IF (.NOT.HEAT .OR. ID(3).EQ.82) GO TO 690
      IF (ID(10) .NE. -9) GO TO 600
      L2 = 405
      L4 = 0
      L5 = 406
      ID(10) = 9
      GO TO 700
C
  580 CALL ODUM (1,IX,ITYPE,NMULT,NLINES,ID)
      DUMMY = .FALSE.
      FROM = 580
      GO TO 690
C
C     REAL FORCE SORT 1 (HEAT)
C
  600 L2 = 297
      IF (ID(10) .EQ. 5) L2 = 302
      L4 = 0
      L5 = 298
      IF (ID(10) .EQ. 5) L5 = 300
      GO TO 700
C
  610 CALL OFPCF1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 615
      IF (HEAT) GO TO 2020
      GO TO 690
C
  620 IF (IAPP .NE. STATIC) GO TO 630
      CALL OFRF2S (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 625
      GO TO 690
  630 CALL OFPRF2 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 635
      IF (.NOT.HEAT .OR. ID(3).EQ.82) GO TO 690
C
C     REAL FORCE SORT 2 (HEAT)
C
      L1 = 108
      L2 = 297
      IF (ID(10) .EQ. 5) L2 = 302
      L5 = 299
      IF (ID(10) .EQ. 5) L5 = 301
      GO TO 700
C
  640 CALL OFPCF2 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 645
      IF (HEAT) GO TO 2020
      GO TO 690
C
  650 CALL OFPSS1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 655
      GO TO 690
  660 CALL OFPSN1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 665
      GO TO 690
C
  670 CALL OFPCC1 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 675
      GO TO 690
C
  680 CALL OFPCC2 (IX,L1,L2,L3,L4,L5,POINT)
      FROM = 685
C
  690 IF (IX .EQ. 0) GO TO 2000
C
C     IF THERMAL DISPLACEMENTS IN -HEAT- PROBLEMS, CHANGE HEADING
C     FROM  DISPLACEMENT TO TEMPERATURE
C
  700 IF (TEMPER .AND. L2.EQ.1) L2 = 253
      IF (TEMPER .AND. L3.EQ.1) L3 = 253
C
C     HEAT PROBLEMS REAL-SORT1-VECTORS ONLY
C
      IF (HEAT .AND. PACK .AND. J.EQ.1) L5 = 296
      IF (HEAT .AND. SORT.EQ.2 .AND. .NOT.ELEMEN) L5 = 303
      IF (AXIC) L4 = -1
      IF (AXIC) L5 = 203
      IF (AXIC .AND. IAPP.EQ.TRANS  .AND. J.EQ.3) L5 = 402
      IF (AXIC .AND. IAPP.EQ.STATIC .AND. J.EQ.3) L5 = 403
      IF (AXIC .AND. IAPP.EQ.FREQ   .AND. J.EQ.4) L5 = 404
      IF (J .NE. 1) GO TO 710
      IF (IAPP.EQ.TRANS .AND. I.NE.8) L1 = 106
      IF ((IAPP.EQ.REIGEN .OR. IAPP.EQ.BK1) .AND. I.NE.6 .AND. I.NE.8
     1   .AND. I.NE.9) L1 = 102
      GO TO 720
  710 IF (J .NE. 2) GO TO 720
      IF (IAPP.EQ.CEIGEN .AND. I.NE.6 .AND. I.NE.9) L1 = 110
  720 IDD = 0
      IF (SORT .EQ. 1) GO TO 730
      IDD   = ID(5)
      ITEMP = IDD/10
      DEVICE= IDD - 10*ITEMP
      DEVICE= MOD(DEVICE,8)
      IDD   = ITEMP
      ID(5) = IDD
      IF (HEAT .AND. .NOT.ELEMEN .AND. SORT.EQ.2) L5 = 303
      IF (IAPP .EQ. STATIC) IDD = -1
C
C     SORT2 HARMONIC VECTOR OUTPUT
C
  730 IF (.NOT.PACK .OR. .NOT.FLUID .OR. SORT.EQ.1) GO TO 750
      IF (ID(5) .LT. 500000) GO TO 740
      IF (L1 .EQ. 107) L1 = 229
  740 FLUID = .FALSE.
      IF (ESE  .OR.   GPFB) GO TO 800
  750 IF (PACK .OR. ELEMEN) GO TO 800
      CALL OFP1
      HEADNG = .TRUE.
C
C     OUTPUT THE DATA BLOCK
C
  800 EOR = .FALSE.
      IF (ELEMEN  .AND. ID(3).EQ.35) AXIC = .TRUE.
      IF (ELEMEN  .AND. ID(3).EQ.70) AXIC = .TRUE.
      IF (ELEMEN  .AND. ID(3).EQ.71) AXIC = .TRUE.
      IF (AXIC) SOLSET = .TRUE.
C
C     D(IX) CONTINS TWO VALUES IN A PACKED 4 DIGIT NUMBER.
C     THE RIGHT 2 DIGITS GIVES THE NUMBER OF LINES FORMAT PRODUCES.
C     THE LEFT 2 DIGITS GIVES THE NUMBER OF DATA VECTORS PER LINE.
C     IF  THE LEFT 2 DIGITS ARE 0 OR NULL, 1 VECTOR IS ASSUMED.
C
      IF (HEAT ) GO TO 810
      IF (DUMMY) GO TO 820
      NMULT  = D(IX)/100
      NLINES = D(IX) - NMULT*100
      GO TO 820
  810 NMULT  = 1
      NLINES = 1
  820 IF (NMULT .EQ. 0) NMULT = 1
      NWDS  = ID(10)*NMULT
      NWDSAV= NWDS
      MAXN  = MAXLNS - NLINES
C
      IF (NWDS .EQ. 0) GO TO 60
  900 IF (EOR) GO TO 60
      FROM  = 900
      CALL READ (*2020,*910,FILE,IOUT(1),NWDS,0,FLAG)
      GO TO 920
  910 IF (FLAG .EQ. 0) GO TO 60
      IF (FLAG .EQ. 0) GO TO 60
      NWDS  = FLAG
      NWDSAV= NWDS
      EOR   = .TRUE.
  920 I1    = 0
      IF (AXIC) GO TO 930
      IGSE  = IOUT(2)
      IF (PACK .OR. GPST) IOUT(2) = GSE(IGSE)
      IF (ESE  .OR. GPFB) GO TO 930
      IF (.NOT.PACK .AND. .NOT.ELEMEN) GO TO 1030
  930 IF (SORT .EQ. 2) GO TO 990
      INCR = ID(10)
      I  = 1
      K1 = 1
  940 ITEMP  = IOUT(I)/10
      DEVICE = IOUT(I) - 10*ITEMP
      DEVICE = MOD(DEVICE,8)
      IOUT(I)= ITEMP
      IF (DEVICE .LT. 4) GO TO 950
      CALL OFPPUN (IOUT(I),IOUT(I),INCR,IOPT,IDD,PNCHED)
      DEVICE = DEVICE - 4
  950 IF (DEVICE .GT. 0) GO TO 980
C
C     ELIMINATE VECTOR FROM MULTIPLE VECTOR PER LINE
C
      NWDS = NWDS - INCR
      IF (NWDS .GT. I) GO TO 960
      DEVICE = 1
      IF (NWDS .GT. 0) GO TO 990
      IF (EOR) GO TO 60
      NWDS = NWDSAV
      GO TO 900
  960 K1 = K1 + INCR
      K2 = K1 + INCR - 1
      JJ = I - 1
      DO 970 J = K1,K2
      JJ = JJ + 1
  970 IOUT(JJ) = IOUT(J)
      GO TO 940
  980 I = I + INCR
      IF (I .LE. NWDS) GO TO 940
  990 IF (DEVICE .LT. 4) GO TO 1020
      IF (ELEMEN) GO TO 1000
      CALL OFPPUN (IOUT(1),IOUT(1),NWDS,IOPT,IDD,PNCHED)
      GO TO 1020
C
C     SORT 2 ELEMENT PUNCH
C
 1000 INCR = ID(10)
      DO 1010 JJ = 1,NWDS,INCR
      CALL OFPPUN (IOUT(JJ),IOUT(JJ),INCR,IOPT,IDD,PNCHED)
 1010 CONTINUE
 1020 IF (DEVICE.NE.1 .AND. DEVICE.NE.5) GO TO 900
 1030 IF (.NOT.PACK .OR. AXIC) GO TO 1100
      IF (FLUID .AND. SORT.EQ.1 .AND. IOUT(1).GE.500000) GO TO 1800
 1040 IF (IOUT(2) .NE. GSE(1)) GO TO 1720
C
C     BUILD FORMAT CHECKING DATA FOR SPECIAL CASES.
C
 1100 I = 1
      IF (HEAT .AND. ELEMEN .AND. ID(3).NE.82) GO TO 1400
      IF (DUMMY) GO TO 1640
      FMT(1) = OPAREN
      IFMT = 1
      J = IX + 1
      GO TO 1120
 1110 J = J + 1
      IFMT = IFMT + 1
      FMT(IFMT) = COMMA
C
C     IF K IS NEGATIVE THEN BUILDING BLOCK IS NOT FOR A VARIABLE.
C     IN THIS CASE THEN K IS ACTUAL POINTER TO BE USED IN THE ESINGL ARR
C
 1120 K = D(J)
      IF (K) 1130,1300,1140
 1130 K = -K
      IFMT = IFMT + 1
      FMT(IFMT) = ESINGL(K)
      GO TO 1110
C
C     CHECK FOR  SPECIAL PACKING FORMATS
C
 1140 K = 5*K - 5
      IF (.NOT. AXIC) GO TO 1150
      IF (K.NE.200 .AND. K.NE.275) GO TO 1160
      IF (IOUT(2) .EQ. IBLANK) GO TO 1230
      GO TO 1240
 1150 IF (.NOT.PACK .OR. IOUT(2).EQ.GSE(1)) GO TO 1160
      IF ((I.GE.I1 .AND. I.LE.8) .OR. (I.GE.I2 .AND. I.LE.14))
     1   GO TO 1250
C
C     IF SOLSET AND K=0 OR K=80 OR K=365 OR K=75 USE I15BLK IF INTEGER 1
C
 1160 IF (.NOT. SOLSET) GO TO 1170
      IF (K.NE.0 .AND. K.NE.80 .AND. K.NE.365 .AND. K.NE.75) GO TO 1170
      IF (IOUT(I) .NE. 1) GO TO 1170
      IOUT(I) = IBLANK
      IFMT = IFMT + 2
      FMT(IFMT-1) = I15BLK(1)
      FMT(IFMT  ) = I15BLK(2)
      IF (AXIC) FMT(IFMT) = I2X
      GO TO 1260
C
C     CHECK FOR  0.0 ON AN E-FORMAT
C
 1170 IF (K .LT. EEND) IF (OUT(I)) 1230,1240,1230
      IF (K .EQ.  440) IF (OUT(I)) 1230,1240,1230
C
C     CHECK FOR MID-EDGE OR CENTER STRESS POINTS ON ISOPARAMETRIC
C     SOLID ELEMENTS
C
      IF ((K.NE.390 .AND. K.NE.395) .OR. IOUT(I).NE.0) GO TO 1190
      IF (K .EQ. 395) GO TO 1180
      IOUT(I) = CENTER
      GO TO 1240
 1180 IOUT(I) = IBLANK
      GO TO 1240
C
C     CHECK FOR SPECIAL INTEGER ON E9.1 FORMAT ONLY
C
 1190 IF (K.NE.E9PT1 .OR. IOUT(I).NE.1) GO TO 1200
      IOUT(I) = IBLANK
      GO TO 1240
C
C     CHECK FOR SPECIAL GPST FORMATS
C
 1200 IF (IOUT(I).NE.0 .OR. K.LT.301 .OR. K.GT.325) GO TO 1210
      IOUT(I) = IBLANK
      GO TO 1240
C
C     CHECK FOR HARMONIC NUMBER OR POINT ANGLE
C
 1210 IF (K.NE.355 .AND. K.NE.360 .AND. K.NE.445) GO TO 1220
      IF (IOUT(I).LE.0 .OR. IOUT(I).GE.1000) GO TO 1220
      IOUT(I) = IOUT(I) - 1
      GO TO 1240
C
C     CHECK FOR PHASE ANGLE ON STRESSES WITH TRAPAX AND TRIAAX ELEMENTS
C
C     COMMENTS FROM G.CHAN/UNISYS   1/93
C     FMT AND PHASE ARE LOCAL. I SEE NOBODY SETTING UP FMT() TO PHASE.
C     PHASE IS '1PE9'. IN ANSI FORTRAN STANDARD, A COMMA IS NEEDED
C     BETWEEN P AND E IF PHASE IS REALLY USED IN SETTING UP FMT().
C
 1220 IF (K.NE.430 .OR. ID(9).NE.3 .OR. IAPP.NE.FREQ .OR. FMT(IFMT-4)
     1    .NE.PHASE) GO TO 1230
      GO TO 1240
C
C     NO OTHER SPECIAL CHECKS AT THIS TIME
C
C     *** ADD FORMAT BLOCKS ***
C
C     STANDARD BLOCKS
C
 1230 IFMT = IFMT + 2
      FMT(IFMT-1) = E(K+1)
      FMT(IFMT  ) = E(K+2)
      GO TO 1260
C
C     ALTERNATE BLOCKS
C
 1240 IFMT = IFMT + 3
      FMT(IFMT-2) = E(K+3)
      FMT(IFMT-1) = E(K+4)
      FMT(IFMT  ) = E(K+5)
      GO TO 1260
C
C     SPECIAL BLOCKS FOR PACKED OUTPUT
C
 1250 IFMT = IFMT + 1
      FMT(IFMT) = A4
      GO TO 1260
C
 1260 I = I + 1
      GO TO 1110
C
C     OUTPUT THE LINE OR LINES OF DATA WITH THE NEW FORMAT
C
 1300 FMT(IFMT) = CPAREN
      IF (LINE.GT.MAXN .OR. .NOT.HEADNG) CALL OFP1
      HEADNG = .TRUE.
      NWDS = NWDSAV
C
C     IF GRID-POINT-FORCE-BALANCE ENTRY, BLANK OUT NONEXISTENT (ZERO)
C     ELEMENT ID-S.
C
      IF (.NOT.GPFB) GO TO 1330
      IF (IOUT(2)) 1320,1310,1320
 1310 IOUT(2) = IBLANK
      FMT( 9) = A4
      FMT(10) = I9X
C
C     ALSO, FOR GPFB, SET FORMAT TO SPACE TWO LINES ON NEW POINT-ID.
C
 1320 IF (IOUT(1) .EQ. LASTID) GO TO 1330
      LASTID = IOUT(1)
      FMT(2) = IH0
      LINE   = LINE + 2
 1330 continue
!hgs revixe call to use new ofppnt: gfortran doesn't like variable format
!     ofppnt now calls forwrt to perform write
      CALL OFPPNT (IOUT,NWDS,FMT)
      GO TO 1700
C
C     ELEMENT FORCES IN HEAT PROBLEMS
C
 1400 IF (LINE.GT.MAXN .OR. .NOT.HEADNG) CALL OFP1
      HEADNG = .TRUE.
      IF (SORT .EQ. 2) GO TO 1520
C
C     BRANCH ON SPECIAL HBDY OUTPUT
C
      IF (NWDS    .EQ. 5) GO TO 1460
      IF (IOUT(5) .EQ. 1) GO TO 1440
      IF (IOUT(6) .EQ. 1) GO TO 1420
      IF (IOUT(2).EQ.HEX1 .OR. IOUT(2).EQ.HEX2) GO TO 1480
      IF (IOUT(2) .EQ. HEX3) GO TO 1500
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
CRPKR WRITE  (L,1410) IOUT(1),(OUT(I),I=2,9)
      WRITE  (L,1410) (IOUT(I),I=1,3), (OUT(I),I=4,9)
 1410 FORMAT (I14,4X,2A4,6(1P,E17.6))
      GO TO 1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1420 WRITE  (L,1430) IOUT(1),OUT(2),OUT(3),OUT(4),OUT(5),OUT(7),OUT(8)
 1420 WRITE  (L,1430) IOUT(1),IOUT(2),IOUT(3),OUT(4),OUT(5),
     *                OUT(7),OUT(8)
 1430 FORMAT (I14,4X,2A4,2(1P,E17.6),17X,2(1P,E17.6))
      GO TO 1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1440 WRITE  (L,1450) IOUT(1),OUT(2),OUT(3),OUT(4),OUT(7)
 1440 WRITE  (L,1450) IOUT(1),IOUT(2),IOUT(3),OUT(4),OUT(7)
 1450 FORMAT (I14,4X,2A4,1P,E17.6,34X,1P,E17.6)
      GO TO 1700
C
 1460 WRITE  (L,1470) IOUT(1),OUT(2),OUT(3),OUT(4),OUT(5)
 1470 FORMAT (18X,I18,4(1P,E18.6))
      GO TO 1700
C
 1480 WRITE  (L,1490) (IOUT(I),I=1,3),(OUT(I),I=4,9)
 1490 FORMAT (I14,1X,A4,I7,6(1P,E17.6))
      GO TO 1700
 1500 WRITE  (L,1510) (IOUT(I),I=1,3),(OUT(I),I=4,9)
 1510 FORMAT (I14,2X,A4,2X,A4,6(1P,E17.6))
      GO TO 1700
C
C     BRANCH ON SPECIAL HBDY FORCES
C
 1520 IF (NWDS    .EQ. 5) GO TO 1580
      IF (IOUT(5) .EQ. 1) GO TO 1560
      IF (IOUT(6) .EQ. 1) GO TO 1540
      IF (IOUT(2).EQ.HEX1 .OR. IOUT(2).EQ.HEX2) GO TO 1600
      IF (IOUT(2) .EQ. HEX3) GO TO 1620
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
CRPKR WRITE  (L,1530) (OUT(I),I=1,9)
      WRITE  (L,1530) OUT(1),IOUT(2),IOUT(3),(OUT(I),I=4,9)
 1530 FORMAT (1P,E14.6,4X,2A4,6(1P,E17.6))
      GO TO  1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1540 WRITE  (L,1550) (OUT(KK),KK=1,5),OUT(7),OUT(8)
 1540 WRITE  (L,1550) OUT(1),IOUT(2),IOUT(3),OUT(4),OUT(5),
     *                OUT(7),OUT(8)
 1550 FORMAT (1P,E14.6,4X,2A4,2(1P,E17.6),17X,2(1P,E17.6))
      GO TO  1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1560 WRITE  (L,1570) (OUT(KK),KK= 1,4),OUT(7)
 1560 WRITE  (L,1570) OUT(1),IOUT(2),IOUT(3),OUT(4),OUT(7)
 1570 FORMAT (1P,E14.6,4X,2A4,1P,E17.6,34X,1P,E17.6)
      GO TO  1700
 1580 WRITE  (L,1590) (OUT(KK),KK=1,5)
 1590 FORMAT (18X,5(1P,E18.6))
      GO TO  1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1600 WRITE  (L,1610) OUT(1),OUT(2),IOUT(3),(OUT(I),I=4,9)
 1600 WRITE  (L,1610) OUT(1),IOUT(2),IOUT(3),(OUT(I),I=4,9)
 1610 FORMAT (1P,E14.6,1X,A4,I7,6(1P,E17.6))
      GO TO  1700
CRPKR THE FOLLOWING LINE HAS BEEN CHANGED
C1620 WRITE  (L,1630) (OUT(I),I=1,9)
 1620 WRITE  (L,1630) OUT(1),IOUT(2),IOUT(3),(OUT(I),I=4,9)
 1630 FORMAT (1P,E14.6,2X,A4,2X,A4,6(1P,E17.6))
      GO TO  1700
C
C     DUMMY ELEMENT
C
 1640 IF (LINE.GT.MAXN .OR. .NOT.HEADNG) CALL ODUM (2,L,ITYPE,IAPP,0,ID)
      HEADNG = .TRUE.
      NWDS   = NWDSAV
      CALL ODUM (3,L,ITYPE,IAPP,NWDS,IOUT)
      GO TO 1700
C
 1700 LINE = LINE + NLINES
      IF (EOR ) GO TO 60
      IF (AXIC) GO TO 900
      IF (.NOT.PACK .OR. IOUT(2).EQ.GSE(1) .OR. I1.EQ.9) GO TO 900
C
C     TRANSFER THE SAVED BLOCK
C
      DO 1710 I = 1,NWDS
 1710 IOUT(I) = ISAVE(I)
      IF (.NOT.FLUID) GO TO 1040
      IF (IOUT(1) .GE. 500000) GO TO 1800
      GO TO 1040
C
C     SPECIAL ROUTINE TO PACK SCALAR OR EXTRA POINTS OUTPUT..
C     PACKING IS PERFORMED ONLY WHEN IDS ARE SEQUENTIAL,
C     AND THE TYPE REMAINS THE SAME.
C
 1720 I = 1
      GRDPT = IOUT(1)
      TYPE  = IOUT(2)
 1730 IF (I .EQ. 6) GO TO 1760
 1740 FROM = 1740
      CALL READ (*2020,*1790,FILE,ISAVE(1),NWDS,0,FLAG)
      IGSE = ISAVE(2)
      IF (PACK) ISAVE(2) = GSE(IGSE)
      IF (SORT .EQ. 2) GO TO 1750
      ITEMP  = ISAVE(1)/10
      DEVICE = ISAVE(1) - 10*ITEMP
      DEVICE = MOD(DEVICE,8)
      ISAVE(1) = ITEMP
 1750 IF (DEVICE .GE. 4) CALL OFPPUN (ISAVE(1),ISAVE(1),NWDS,IOPT,IDD,
     1                                PNCHED)
      IF (DEVICE.NE.1 .AND. DEVICE.NE.3 .AND. DEVICE.NE.5 .AND.
     1    DEVICE.NE.7) GO TO 1740
      J = GRDPT + I
      IF (FLUID .AND. ISAVE(1).GE.500000) GO TO 1760
      IF (ISAVE(2).NE.TYPE .OR. ISAVE(1).NE.(GRDPT+I)) GO TO 1760
C
C     PACK THIS VECTOR INTO LINE OF DATA
C     IF COMPLEX TWO LINES OF DATA
C     IMAGINARY PART WILL BE PACKED EVEN IF IT DOES NOT EXIST.
C
      I = I + 1
      IOUT(I+2) = ISAVE(3)
      IOUT(I+8) = ISAVE(9)
      GO TO 1730
C
C     PUT BLANKS IN ANY OPEN SLOTS
C
 1760 J = I + 3
      IF (J .GT. 8) GO TO 1780
      DO 1770 K  = J,8
      IOUT(K  ) = IBLANK
 1770 IOUT(K+6) = IBLANK
C
 1780 I1 = J
      I2 = J + 6
      GO TO 1100
C
 1790 EOR = .TRUE.
      GO TO 1760
C
C     SPECIAL LOGIC FOR SORT-1 VECTOR OUTPUT IN A FLUID PROBLEM FOR
C     HARMONIC POINTS ONLY
C
 1800 OLDHRM = -1
      L5  = 230
      LINE= MAXN + 1
      K   = 0
      EOR = .FALSE.
      GO TO 1820
 1810 FROM = 1810
      CALL READ (*2020,*1840,FILE,IOUT(1),NWDS,0,FLAG)
C
C     PUNCH PROCESSING
C
      ITEMP  = IOUT(1)/10
      DEVICE = IOUT(1) - 10*ITEMP
      IOUT(1)= ITEMP
      IF (DEVICE .LT. 4) GO TO 1820
      DEVICE = MOD(DEVICE,8)
      CALL OFPPUN (IOUT(1), IOUT(1),INCR,IOPT,IDD,PNCHED)
      DEVICE = DEVICE - 4
      IF (DEVICE .LE. 0) GO TO 1810
C
C     DECODE THE HARMONIC
C
 1820 ITEMP = MOD(IOUT(1),500000)
      NHARM = (IOUT(1)-ITEMP)/500000
      IOUT(1) = ITEMP
      IF (OLDHRM .EQ. -1) OLDHRM = NHARM
      IF (NHARM.NE.OLDHRM .OR. K.GE.5) GO TO 1850
      K = K + 1
 1830 REAL(2*K-1) = IOUT(1)
      REAL(2*K  ) = IOUT(3)
      IMAG(  K  ) = IOUT(9)
      GO TO 1810
C
C     OUTPUT THE LINE OF DATA
C
 1840 EOR = .TRUE.
      IF (K .LE. 0) GO TO 60
C
C     BUILD THE FORMAT
C
 1850 FMT(1) = I1X
      IF (NLINES .GT. 1) FMT(1) = I1H0
      FMT(2) = I12
      FMT(3) = I2XX
      IFMT   = 3
C
C     ADD STAR IF THIS IS AN UN-SYMETRIC HARMONIC
C
      IF (MOD(OLDHRM,2) .EQ. 0) GO TO 1860
      FMT(3) = ISTAR
      FMT(4) = I1XX
      IFMT   = 4
C
C     VARIABLES IN MAIN LINE
C
 1860 DO 1890 I = 1,K
      FMT(IFMT+1) = I8
      IF (FREAL(2*I)) 1870,1880,1870
 1870 FMT(IFMT+2) = PE
      FMT(IFMT+3) = E156
      IFMT = IFMT + 3
      GO TO 1890
 1880 FMT(IFMT+2) = PF
      FMT(IFMT+3) = F156
      FMT(IFMT+4) = I9X
      IFMT = IFMT + 4
 1890 CONTINUE
C
C     VARIABLES IN SECOND LINE IF COMPLEX
C
      IF (NLINES .LE. 1) GO TO 1940
      IFMT = IFMT + 1
      FMT(IFMT) = I15X
      DO 1930 I = 1,K
      IFMT = IFMT + 1
      FMT(IFMT) = COMMA
      IF (FIMAG(I)) 1910,1900,1910
 1900 FMT(IFMT+1) = PF
      FMT(IFMT+2) = F236
      FMT(IFMT+3) = I9X
      IFMT = IFMT + 3
      GO TO 1930
 1910 IF (L3 .EQ. 126) GO TO 1920
      FMT(IFMT+1) = PE
      FMT(IFMT+2) = E236
      IFMT = IFMT + 2
      GO TO 1930
 1920 FMT(IFMT+1) = PF
      FMT(IFMT+2) = F174
      FMT(IFMT+3) = I6X
      IFMT = IFMT + 3
 1930 CONTINUE
C
C     COMPLETE FORMAT
C
 1940 FMT(IFMT+1) = CPAREN
      IF (LINE .GT. MAXN) CALL OFP1
      LINE = LINE + NLINES
      K2   = 2*K
      IHARM= (OLDHRM-1)/2
      IF (NLINES .LE. 1) GO TO  1950
CRPKR THE FOLLOWING LINE HAS BEEN REPLACED BY TWO LINES
CRPKR WRITE (L,FMT) IHARM,(FREAL(I),I=1,K2),(FIMAG(I),I=1,K)
      WRITE (L,FMT) IHARM,(REAL(I),FREAL(I+1),I=1,K2,2),
     *                            (FIMAG(I),I=1,K)
      GO TO 1960
CRPKR THE FOLLOWING LINE HAS BEEN REPLACED
C1950 WRITE (L,FMT) IHARM,(FREAL(I),I=1,K2)
 1950 WRITE (L,FMT) IHARM,(REAL(I),FREAL(I+1),I=1,K2,2)
 1960 K = 1
      OLDHRM = NHARM
      IF (.NOT. EOR) GO TO 1830
      GO TO 60
C
C     ERROR CONDITION THIS FILE
C
 2000 WRITE  (L,2010) SWM,IX,POINT,FROM
 2010 FORMAT (A27,', OFP BLOCK DATA ROUTINES UNAVAILABLE FOR THIS ',
     1       'ELEMENT.',11X,'IX,POINT,FROM =,',3I5)
 2020 WRITE  (L,2030) UWM,FROM
 2030 FORMAT (A25,' 3030, OFP UNABLE TO PROCESS DATA BLOCK.  A TABLE ',
     1       'PRINT OF THE DATA BLOCK FOLLOWS.   FROM =',I5,'/OFP')
      CALL CLOSE  (FILE,1)
      CALL TABPRT (FILE)
      GO TO 2050
C
C     CLOSE FILE UP
C
 2040 CALL CLOSE (FILE,1)
 2050 IF (IFILE .EQ. 6) GO TO 2060
      GO TO 50
C
C     RESTORE TITLES TO WHATEVER THEY WERE AT ENTRY TO OFP
C
 2060 DO 2070 I = 1,96
 2070 HEAD(I) = TSAVE(I)
      RETURN
      END


C 	Copyright restrictions apply - see stsdas$copyright.stsdas, STECF CR
C
        SUBROUTINE YCLOFF(FRAME,NAME1,NAME2,XOFFS,YOFFS,NSPEC,
     $		DATA,ERR,EPS,N,PEDGR1,PEDGR2,DESCR1,DESCR2,GRNDMD,
     $          PFLAGS,ROOTO,ISTAT)
c*
c*  Module number:
c*
c*  Module name: YCLOFF
c*
c*  Keyphrase:
c*  ----------
c*       Perform FOS x-shift corrections
c*  Description:
c*  ------------
c*       This routine calculates and applies corrections to the X-location
c*       that stem from various sources (GIMP, wrong on-board GIMP, YBASE...)
c*
c*  FORTRAN name: YCLOFF.FOR
c*
c*  Keywords of accessed files and tables:
c*  --------------------------------------
c*  Name                         I/O     Description / Comments
c*       ccs7                    I       gimp corrections scale factors
c*       offparms       	        I	offset parameters
c
c*  Subroutines Called:
c*  -------------------
c*  CDBS:
c*       yrccs7, yrdoff, ygtorb, ygimp
c*
c*  STSDAS:
c*	udmget, udmfre, uhdgsb
c*
c*  History:
c*  --------
c*  Version      Date        Author          Description
c*       1       May 91	    S. Hulbert      Designed and coded
c*     1.1       Jun 91      S. Hulbert      Added y-offset
c*     1.1.2	Apr 93	    H. Bushouse	    Declare local variables
c*     1.2	Apr 93	    H. Bushouse     Corrected zero countrate roundoff
c*                                           errors
c*     1.3	May 93	    H. Bushouse	    Warn if onboard GIMP corr performed
c*	2	Mar 94	    H. Bushouse	    Mods to handle PEDIGREE keywords
c*     2.1      Mar 97      M. De La Pena   Added KYDEPLOY to CONFG1
c*     ////////////////////////////////////////////////////////////////////
c*           Start of Post Operational Archive versions (poa_calfos)
c*     ////////////////////////////////////////////////////////////////////
c*     1.0      May 00      M. Rosa         Rewrite, include additional POA
c*                                          corrections
c*              Jun 00      M. Rosa         Adapted POA version of XOFF calc.
c*                                          activate PERFORM/OMIT switch
c*     1.1      Oct 00      A. Alexov       Added ascii file for header output
c*     1.2.1    Oct 01      A. Alexov       CONTXT blank must have one space
c*                                          character for Dec Alpha compilation
c*-------------------------------------------------------------------------------
c*
c* INPUTS:
c*       frame - frame number (this is actually the group number)
c*       name1 - name of the CCS7 reference table
c*       name2 - name of the OFFS_TAB optional reference table
c*       nspec - number of spectra per frame
c*       n - number of points to calibrate
c*       fill - flag value for fill data
c*
c* INPUT/OUTPUT:
c*       xoffs - xoffsets array
c*       data - data array
c*       err - error array
c*       eps - data quality vector
c*
c* OUTPUT:
c*	pedgr1 - CCS7 PEDIGREE keyword string
c*	pedgr2 - OFFS_TAB PEDIGREE keyword string
c*	descr1 - CCS7 DESCRIP  keyword string
c*	descr2 - OFFS_TAB DESCRIP  keyword string
c*       istat - error status
c*
c*----------------------------------------------------------------------------
        IMPLICIT NONE

        CHARACTER*8 PFLAGS(15)
        CHARACTER*64 NAME1, NAME2
        CHARACTER*64 ROOTO, NAME, FILE
	CHARACTER*68 PEDGR1,PEDGR2,DESCR1,DESCR2
        INTEGER N, FRAME, ISTAT, NSPEC, II
        REAL DATA(N), ERR(N), EPS(N), XOFFS(NSPEC), YOFFS(NSPEC)
C------------------------------------------------------------------------------
C Get IRAF MEM common into main program.
      LOGICAL          MEMB(1)
      INTEGER*2        MEMS(1)
      INTEGER*4        MEMI(1)
      INTEGER*4        MEML(1)
      REAL             MEMR(1)
      DOUBLE PRECISION MEMD(1)
      COMPLEX          MEMX(1)
      EQUIVALENCE (MEMB, MEMS, MEMI, MEML, MEMR, MEMD, MEMX)
      COMMON /MEM/ MEMD
C------------------------------------------------------------------------------
      INTEGER TYINT
      PARAMETER (TYINT = 4)
      INTEGER TYREAL
      PARAMETER (TYREAL = 6)
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C Common block containing confiquration parameters
C
        CHARACTER*18 GRNDMD
        CHARACTER*5 DET
        CHARACTER*3 FGWAID,APERID,YTYPE(3)
        CHARACTER*1 POLID
        INTEGER FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME
        LOGICAL HEADER,TRAILR,DEFDDT,KYDPLY
        COMMON /CONFG1/KYDPLY,DET,FGWAID,APERID,POLID,YTYPE
        COMMON /CONFG2/FCHNL,NCHNLS,OVERSN,NXSTEP,YBASE,YRANGE,YSTEPS,
     *          INTS,SLICES,NPAT,NREAD,NCLEAR,LVTIME,HEADER,TRAILR,
     *          DEFDDT
C
C Common block containing input/output file descriptions
C
C       IDS - file id numbers
C       GCOUNT - group counts
C       NAXIS - naxis
C       NAXIS1 - first dimensions
C       NAXIS2 - second dimensions
C       FILL - Fill values
C
        INTEGER IDS(30),NAXIS(30),NAXIS1(30),NAXIS2(30),GCOUNT(30)
        REAL FILL(30)
        COMMON /IOCOM/IDS,GCOUNT,NAXIS,NAXIS1,NAXIS2,FILL
C
C gimp epsilon
C
        REAL EPSGMP
        PARAMETER (EPSGMP = 700)

C
C the POA header keys get placed into an ascii txt output file
C
        CHARACTER*64 POA_TXT
        COMMON /POA_T/ POA_TXT
        INTEGER GLOBAL_COUNT
        COMMON /GCOUNT/ GLOBAL_COUNT
C
C LOCAL VARIABLES ------------------------------------------------------
C
        INTEGER I, J, LASTFR, NOVS, II
        CHARACTER*80 CONTXT
c        CHARACTER*3 CHAR3
        REAL XSCALE,YSCALE
	REAL EXPOMAX
	INTEGER CLEARS, IREAD, NREPS
        INTEGER IXOFF, DATA0, ERR0, EPS0, DATA1, ERR1, EPS1
        INTEGER DATAOVS,ERROVS,EPSOVS
	INTEGER GDFRST, GDLST, DELTA, EDGE1, EDGE2
        REAL TEMP1, TEMP2
        INTEGER OFFSET, ISTATS(20)
	LOGICAL OBGIMP, CPOA
        LOGICAL FILEEX
C
C-----------------------------------------------------------------------
        CPOA = .TRUE.
        NOVS = 4*N
C read scale factors and/or offsets if first call
C determine which table is needed
        IF(FRAME.EQ.1)THEN
C we will want to watch for the last frame
            LASTFR= GCOUNT(1)
C buffer memory to hold the x offsets
            CALL UDMGET (NSPEC, TYINT, IXOFF, ISTATS(1))
            IF (ISTATS(1).NE.0) THEN
                     CONTXT = 'Error allocating dynamic memory'
                     GO TO 999
            ENDIF

C create new ascii output file for header storage
C first, create the name, using ROOTO + .poa
C FIND END OF ROOTO (FIRST BLANK)
C
4       DO 10 II=1,64
10              IF( ROOTO(II:II) .EQ. ' ') GO TO 20
20      FILE=ROOTO
        WRITE(NAME,99)FILE(1:II-1),'.poa'
99      FORMAT(A,A4)
        POA_TXT=NAME
C check if the output txt file already exists, then open/create it
        INQUIRE (FILE=POA_TXT, EXIST=FILEEX)
        IF (FILEEX .EQ. 0) THEN
           OPEN(29,FILE=POA_TXT,STATUS='NEW')
        ELSE
           OPEN(29,FILE=POA_TXT,STATUS='OLD')
           REWIND(29)
        ENDIF
C Initialize the file with some information
        WRITE(29,129) 'Filename: ', POA_TXT
129     FORMAT(A10,A64)
        CLOSE(29)

C
C check whether onboard GIMP was activated
	    CALL UHDGSB (IDS(1),'YFGIMPEN',OBGIMP,ISTAT)
	    IF (ISTAT .NE. 0) THEN
		CONTXT = 'WARNING: keyword YFGIMPEN not found'//
     $                   ' in .d0h; assume pre-onboard-gimp data'
                CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
                OBGIMP = .FALSE.
	    ENDIF
	    IF (OBGIMP) THEN
		CONTXT = 'Onboard GIMP was active'
		CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
	    ENDIF
C
C if multiple readouts set up buffers to hold previous
C raw and x-shift corrected frame
            IF (NREAD .GT. 1) THEN
C buffers for last readout not yet corrected
        	CALL UDMGET (N, TYREAL, DATA0, ISTATS(1))
        	CALL UDMGET (N, TYREAL, ERR0, ISTATS(2))
        	CALL UDMGET (N, TYREAL, EPS0, ISTATS(3))
C buffers for last readout x-shift corrected
        	CALL UDMGET (N, TYREAL, DATA1, ISTATS(4))
        	CALL UDMGET (N, TYREAL, ERR1, ISTATS(5))
        	CALL UDMGET (N, TYREAL, EPS1, ISTATS(6))
C buffers for oversampled intermediate step
        	CALL UDMGET (NOVS, TYREAL, DATAOVS, ISTATS(7))
        	CALL UDMGET (NOVS, TYREAL, ERROVS, ISTATS(8))
        	CALL UDMGET (NOVS, TYREAL, EPSOVS, ISTATS(9))
C
                DO 155 I = 1, 9
                    IF (ISTATS(I).NE.0) THEN
                        CONTXT = 'Error allocating dynamic memory'
                        GO TO 999
                    ENDIF
155        	CONTINUE
C
                DO 145 I = 1, N
        	    MEMR(DATA0+I-1) = 0.
        	    MEMR(ERR0+I-1) = 0.
        	    MEMR(EPS0+I-1) = 0.
        	    MEMR(DATA1+I-1) = 0.
        	    MEMR(ERR1+I-1) = 0.
        	    MEMR(EPS1+I-1) = 0.
 145             CONTINUE
                DO 147 I = 1, NOVS
        	    MEMR(DATAOVS+I-1) = 0.
        	    MEMR(ERROVS+I-1) = 0.
        	    MEMR(EPSOVS+I-1) = 0.
147             CONTINUE
            ENDIF
C
C        	COMPUT = .TRUE.
C ... and get orbital parameters from shp
                CALL YGTORB(ISTAT)
                IF(ISTAT.NE.0)GO TO 999
        ENDIF
C------------------- end of frame 1 only processing ---------------------------

       CONTXT = ' '
       CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
       CONTXT = '*** X-OFFSET corrections calculated from POA model ***'
       CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)

C--- here for all groups
       CALL YGIMP(XSCALE,YSCALE,XOFFS,YOFFS,NSPEC,GRNDMD,FRAME,ISTAT)
       IF (ISTAT.NE.0) THEN
          CONTXT = 'Error coming back from YGIMP'
          GO TO 999
       ENDIF

       OPEN(29,FILE=POA_TXT,STATUS='OLD',ACCESS='APPEND')
C
c convert the x-offsets to integer number of x-steps (no oversampling)
c Note:  poaoffx called by ygimp calculates offsets in pixels (=1/4 diode)
c        hence image data (NXSTEP=1) need to shift their data by only
c        XOFFS/4
        DO 100 I = 1, NSPEC
            MEMI(IXOFF+I-1) = NINT(NXSTEP*XOFFS(I)/4.)
            WRITE(CONTXT,97)  GRNDMD(1:4),XOFFS(I),MEMI(IXOFF+I-1)
 97     FORMAT(' POA x-offset for MODE = ',A4,' is ',F6.3,
     *   ' 1/4 diodes = ',I3,' array pix')
            CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
100    CONTINUE
C
       CLOSE(29)

            CONTXT = '*** End of POA calculations ***'
            CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)
            CONTXT = ' '
            CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)

C If OFF_CORR flag is 'OMIT' - do not apply the calculated corrections
       IF(PFLAGS(2).EQ.'PERFORM') THEN

C unravel non-destructive readouts (i.e. DEACCUM)
        IF (NREAD .GT. 1) THEN
C
C scale the data by the number of readouts and subtract from the
C previous readout. Square the errors, too.
C Save the subtracted values as the 'previous' frame for use
C with the next frame
C
C first calculate maximum exposure time of readout
	    CLEARS = (LASTFR-1) / NREAD
	    IREAD  = LASTFR - CLEARS*NREAD
	    NREPS  = IREAD * INTS * OVERSN * NPAT
	    EXPOMAX = NREPS * (LVTIME*7.8125E-6)
C
            DO 190 I = 1, N
        	TEMP1 = DATA(I) * FRAME
        	TEMP2 = (ERR(I) * FRAME)*(ERR(I) * FRAME)
        	DATA(I) = TEMP1 - MEMR(DATA0+I-1)
        	ERR(I)  = TEMP2 - MEMR(ERR0+I-1)
C correct for roundoff errors by setting the data (and errors) to
C exactly zero if the number of counts is less than 0.5/expomax
		IF (DATA(I) .LT. 0.5/EXPOMAX) THEN
		    DATA(I) = 0.0
		    TEMP1 = MEMR(DATA0+I-1)
		    ERR(I) = 0.0
		    TEMP2 = MEMR(ERR0+I-1)
		ENDIF
        	IF (ERR(I) .LT. 0.) THEN
        	    ERR(I) = 0.
        	    TEMP2 = MEMR(ERR0+I-1)
        	ENDIF
        	MEMR(DATA0+I-1) = TEMP1
        	MEMR(ERR0+I-1) = TEMP2
        	MEMR(EPS0+I-1) = EPS(I)
190            CONTINUE
        ENDIF
C
C set limits but ignore the stuff that falls off the edge
        DO 200 I = 1, NSPEC
            OFFSET = MEMI(IXOFF+I-1)
c            WRITE(CONTXT,98) I, OFFSET
c 98         FORMAT('Applying to group #',I4,' an offset of ',I4,' pix')
c       CALL YMSPUT(CONTXT,STDOUT,0,ISTAT)

            IF (OFFSET .NE. 0) THEN
        	IF (OFFSET .LT. 0) THEN
        	    GDFRST = (I-1) * N / NSPEC + 1 - OFFSET
        	    GDLST = I * N / NSPEC
        	    DELTA = 1
C set right edge count in offset space
        	    EDGE2 = I * N / NSPEC
        	    EDGE1 =  I * N / NSPEC + OFFSET + 1
                  ELSE
C fill this backwards
        	    GDFRST = I * N / NSPEC - OFFSET
        	    GDLST = (I-1) * N / NSPEC + 1
        	    DELTA = -1
C set left edge
        	    EDGE1 = 1
        	    EDGE2 = OFFSET
        	ENDIF
C offset
        	DO 210 J = GDFRST,GDLST,DELTA
        	        DATA(J+OFFSET) = DATA(J)
        	        ERR(J+OFFSET) = ERR(J)
        	        EPS(J+OFFSET) = EPS(J)
210        	CONTINUE
C
C now deal with the edges; fill with 0
        	DO 211 J = EDGE1, EDGE2
        	        DATA(J) = 0.0
        	        ERR(J) = 0.0
        	        EPS(J) = EPSGMP
211        	CONTINUE
            ENDIF
200        CONTINUE
C
C recombine non-destructive readouts
C add to the previous degimped, scale by the readout, take
C the square root of the error
C check the data quality for previous readouts and update latest
        IF (NREAD .GT. 1) THEN
            DO 191 I = 1, N
        	MEMR(DATA1+I-1) = DATA(I) + MEMR(DATA1+I-1)
        	MEMR(ERR1+I-1) = ERR(I) + MEMR(ERR1+I-1)
        	DATA(I) = MEMR(DATA1+I-1) / FRAME
        	ERR(I) = SQRT(MEMR(ERR1+I-1)) / FRAME
        	IF (EPS(I) .LT. MEMR(EPS1+I-1)) EPS(I) = MEMR(EPS1+I-1)
        	IF (EPS(I) .GE. EPSGMP) THEN
        	    DATA(I) = 0.0
        	    ERR(I) = 0.0
        	ENDIF
        	MEMR(EPS1+I-1) = EPS(I)
191            CONTINUE
         ENDIF
C end of applying the correction

       ENDIF
C
C clean up if all done
12345   CONTINUE
        IF (FRAME .EQ. LASTFR) THEN
            CALL UDMFRE (DATA0, TYREAL, ISTATS(1))
            CALL UDMFRE (ERR0, TYREAL, ISTATS(2))
            CALL UDMFRE (EPS0, TYREAL, ISTATS(3))
            CALL UDMFRE (DATA1, TYREAL, ISTATS(4))
            CALL UDMFRE (ERR1, TYREAL, ISTATS(5))
            CALL UDMFRE (EPS1, TYREAL, ISTATS(6))
            CALL UDMFRE (IXOFF, TYINT, ISTATS(7))
            DO 165 I = 1, 7
                IF (ISTATS(I).NE.0) THEN
                    CONTXT = 'Error deallocating dynamic memory'
                    GO TO 999
                ENDIF
165            CONTINUE
        ENDIF
C
        ISTAT=0
        GO TO 1000
999     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END