      SUBROUTINE PHO_HARINI(Ip,Idp1,Idp2,Pv1,Pv2,Nout,Mode)
C**********************************************************************
C
C     initialize calculation of hard cross section
C
C     must not be called during MC generation
C
C***********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , dummy , Pv1 , Pv2
      INTEGER Idp1 , Idp2 , Ip , Mode , Nout
      SAVE

      PARAMETER (DEPS=1.D-10)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  currently activated parton density parametrizations
      INCLUDE 'inc/poppdf'
C  some constants
      INCLUDE 'inc/pocons'
C  scale parameters for parton model calculations
      INCLUDE 'inc/pohscl'
C  data of c.m. system of Pomeron / Reggeon exchange
      INCLUDE 'inc/popcms'
C  obsolete cut-off information
      INCLUDE 'inc/pocut1'
C  hard scattering parameters used for most recent hard interaction
      INCLUDE 'inc/pohapa'

      DOUBLE PRECISION PHO_ALPHAS

      CHARACTER*20 rflag

C  set local Pomeron c.m. system data
      IDPdg1 = Idp1
      IDPdg2 = Idp2
      PVIrtp(1) = Pv1
      PVIrtp(2) = Pv2
C  initialize PDFs
      CALL PHO_ACTPDF(IDPdg1,1)
      CALL PHO_ACTPDF(IDPdg2,2)
C  initialize alpha_s calculation
      dummy = PHO_ALPHAS(0.D0,-4)
C  initialize scales with defaults
      IF ( (IDPdg1.EQ.22) .OR. (IDPdg1.EQ.990) ) THEN
         IF ( (IDPdg2.EQ.22) .OR. (IDPdg2.EQ.990) ) THEN
            AQQal = PARmdl(83)
            AQQali = PARmdl(86)
            AQQalf = PARmdl(89)
            AQQpd = PARmdl(92)
            NQQal = IPAmdl(83)
            NQQali = IPAmdl(86)
            NQQalf = IPAmdl(89)
            NQQpd = IPAmdl(92)
         ELSE
            AQQal = PARmdl(82)
            AQQali = PARmdl(85)
            AQQalf = PARmdl(88)
            AQQpd = PARmdl(91)
            NQQal = IPAmdl(82)
            NQQali = IPAmdl(85)
            NQQalf = IPAmdl(88)
            NQQpd = IPAmdl(91)
         END IF
      ELSE IF ( (IDPdg2.EQ.22) .OR. (IDPdg2.EQ.990) ) THEN
         AQQal = PARmdl(82)
         AQQali = PARmdl(85)
         AQQalf = PARmdl(88)
         AQQpd = PARmdl(91)
         NQQal = IPAmdl(82)
         NQQali = IPAmdl(85)
         NQQalf = IPAmdl(88)
         NQQpd = IPAmdl(91)
      ELSE
         AQQal = PARmdl(81)
         AQQali = PARmdl(84)
         AQQalf = PARmdl(87)
         AQQpd = PARmdl(90)
         NQQal = IPAmdl(81)
         NQQali = IPAmdl(84)
         NQQalf = IPAmdl(87)
         NQQpd = IPAmdl(90)
      END IF
      IF ( PARmdl(109+Ip).LT.DEPS ) PARmdl(109+Ip) = AQQal
      IF ( PARmdl(113+Ip).LT.DEPS ) PARmdl(113+Ip) = AQQali
      IF ( PARmdl(117+Ip).LT.DEPS ) PARmdl(117+Ip) = AQQalf
      IF ( PARmdl(121+Ip).LT.DEPS ) PARmdl(121+Ip) = AQQpd
      IF ( IPAmdl(64+Ip).LT.0 ) IPAmdl(64+Ip) = NQQal
      IF ( IPAmdl(68+Ip).LT.0 ) IPAmdl(68+Ip) = NQQali
      IF ( IPAmdl(72+Ip).LT.0 ) IPAmdl(72+Ip) = NQQalf
      IF ( IPAmdl(76+Ip).LT.0 ) IPAmdl(76+Ip) = NQQpd
      AQQal = PARmdl(109+Ip)
      AQQali = PARmdl(113+Ip)
      AQQalf = PARmdl(117+Ip)
      AQQpd = PARmdl(121+Ip)
      NQQal = IPAmdl(64+Ip)
      NQQali = IPAmdl(68+Ip)
      NQQalf = IPAmdl(72+Ip)
      NQQpd = IPAmdl(76+Ip)
      PTCut(1) = PARmdl(36)
      PTCut(2) = PARmdl(37)
      PTCut(3) = PARmdl(38)
      PTCut(4) = PARmdl(39)
      PTAno(1) = PARmdl(130)
      PTAno(2) = PARmdl(131)
      PTAno(3) = PARmdl(132)
      PTAno(4) = PARmdl(133)
      rflag = '(energy-independent)'
      IF ( IPAmdl(7).GT.0 ) rflag = '(energy-dependent)'

C  write out all settings
      IF ( (IDEb(66).GE.15) .OR. (Mode.GT.0) ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,99010) Ip , IDPdg1 , IDPdg2 ,
     &        PTCut(Ip) , rflag , PDFnam(1) , IGRp(1) , ISEt(1) ,
     &        IEXt(1) , PDFnam(2) , IGRp(2) , ISEt(2) , IEXt(2) ,
     &        PDFlam , NF , NQQal , AQQal , NQQpd , AQQpd
99010    FORMAT (/,' PHO_HARINI: hard scattering parameters for IP:',
     &           I3/,5X,'particle 1 / particle 2:',2I8,/,5X,
     &           'min. PT   :',F7.1,2X,A,/,5X,'PDF side 1:',2X,A8,
     &           ' IGRP/ISET/IEXT ',3I4,/,5X,'PDF side 2:',2X,A8,
     &           ' IGRP/ISET/IEXT ',3I4,/,5X,
     &           'LAMBDA1,2 (4 active flavours):',2F8.3,/,5X,
     &           'max. number of active flavours NF  :',I3,/,5X,
     &           'NQQAL/AQQAL/NQQPD/AQQPD:',I5,F8.3,I5,F8.3)
      END IF

      END SUBROUTINE


      SUBROUTINE GETEPH(TIM50,POS,VEL,IRESET,LUEPHEM,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE CONTROLS CALLS TO THE EPHEMERIS FILE READER. USING THIS
C  ROUTINE SAVES THE PROGRAMMER FROM HAVING TO CODE THE POSBUF, VELBUF,
C  R8V, AND I4V ARRAYS IN EACH ROUTINE THAT NEEDS TO READ THE EPHEM
C  FILE.
C
C  THIS ROUTINE HAS FOUR FUNCTIONS, DEFINED BY ENTRY POINTS:
C
C        1) IT GIVES SPACECRAFT POSITION AND VELOCITY AT A SPECIFIED
C           TIME USING DATA FROM AN EPHEM FILE. (CALL GETEPH)
C
C        2) IT RETURNS EPHEM FILE HEADER INFORMATION. (CALL GETEPHD)
C
C        3) IT REDEFINES THE EPOCH AND PRESERVES THE EARTH-FIXED
C           TRAJECTORY. (CALL GETEPHZ)
C
C        4) IT 'DEACTIVATES' PREVIOUSLY ACCESSED EPHEM FILES. SEE
C           COMMENTS BELOW THE DEFINITION OF ACTIVE.
C           (CALL GETEPH OR GETEPHD OR GETEPHZ)
C
C
C  THIS ROUTINE ALLOWS THE PROGRAM TO MULTIPLE FILES WITHIN A SINGLE
C  RUN. THE FILES INVOLVED MAY BE READ IN ANY SEQUENCE NEEDED. FOR
C  EXAMPLE, FOR EPHEM FILE UNITS 91, 92, AND 93, THE CALLS MAY USE
C  THEM IN THE ORDER 91,92,91,93,91,91,91,93,92,93,92,92,91,....
C
C  THIS ROUTINE CAN HANDLE UP TO 3(EASILY INCREASED) ACTIVE FILES. A
C  FILE IS CALLED 'ACTIVE' WITHIN THIS ROUTINE IF ITS ASSOCIATED ARRAYS
C  HAVE BEEN INITIALIZED. ARRAYS ARE INITIALIZED THE FIRST TIME THE FILE
C  IS NEEDED. THE FILE REMAINS ACTIVE UNTIL A CALL OCCURS TO DEACTIVATE
C  IT. WHEN A FILE IS DEACTIVATED, THIS ROUTINE FORGETS IT EVER USED
C  THE FILE AND A SUBSEQUENT CALL TO READ IT IS EXECUTED AS THOUGH IT
C  WERE THE FIRST CALL.
C
C  THIS ROUTINE CONTAINS CODE THAT ALLOWS YOU TO CHANGE THE EPOCH
C  ON THE FILE, PRESERVE THE EARTH-FIXED TRAJECTORY, AND RETURN
C  INERTIAL STATE VECTORS AS THOUGH THE EPHEM FILE WERE ORIGIALLY
C  GENERATED WITH THAT EPOCH. THIS OPTION IS NOT VALID FOR FORCE
C  MODELS INVOLVING THE SUN, MOON, AND SUN-DEPENDENT DRAG. IT IS VALID
C  FOR EARTH ZONAL AND TESSERAL FORCES.
C
C
C                    ********************
C********************* GETEPH ARGUMENTS ********************************
C                    ********************
C
C USAGE NOTE: IF AN EPOCH CHANGE IS DEFINED, THE FIRST GETEPH CALL MUST
C             BE PRECEEDED BY A GETEPHD CALL. THIS REQUIREMENT FORCES
C             THE PROGRAMMER TO CONSIDER THE FACT THAT THE HEADER
C             INFORMATION IS DEPENDENT UPON THE EPOCH IN USE AND THE
C             CALLING PROGRAM MAY NEED TO UPDATE ITS INFORMATION.
C
C  VARIABLE  DIM  TYPE  I/O   DESCRIPTION
C  --------  ---  ----  ---   -----------
C
C  TIM50     1    R*8    I    THE TIME IN SECONDS SINCE 1/1/50 0.0 HR UT
C                             THAT THE S/C POSITION AND VELOCITY ARE
C                             WANTED.
C
C  POS       3    R*8    O    THE S/C INERTIAL CARTESIAN POSITION
C                             COORDINATES AT TIM50. KM.
C
C                             THE POSITION DEPENDS UPON THE EPOCH IN
C                             USE. IT WILL DIFFER FROM THE FILE'S
C                             POSITION IF AN EPOCH CHANGE HAS BEEN
C                             DEFINED BY GETEPHZ, BUT THE EARTH-FIXED
C                             TRAJECTORY IS THE SAME.
C
C  VEL       3    R*8    O    THE S/C VELOCITY AT TIM50. KM/SEC.
C
C                             THE VELOCITY DEPENDS UPON THE EPOCH IN
C                             USE. IT WILL DIFFER FROM THE FILE'S
C                             VELOCITY IF AN EPOCH CHANGE HAS BEEN
C                             DEFINED BY GETEPHZ, BUT THE EARTH-FIXED
C                             TRAJECTORY IS THE SAME.
C
C  IRESET    1    I*4    I    A FLAG TO TELL THE ROUTINE TO READ THE
C                             HEADER INFORMATION FROM THE EPHEM FILE.
C
C                             =0 DO NOT RE-READ THE HEADER. THE FILE HAS
C                                NOT BEEN CHANGED SINCE THE LAST CALL.
C                                HEADER INFO ALREADY IN INTERNAL ARRAYS
C                                WILL BE USED.
C                             =1 RE-READ THE HEADER AND REPLACE THE
C                                CURRENT CONTENTS OF INTERNAL ARRAYS.
C                                USED IF THE FILE HAS BEEN REGENERATED
C                                SINCE THE LAST CALL.
C
C                             HEADER INFO IS NEEDED BY THE INTERPOLATION
C                             SCHEME FOR PRODUCING THE OUTPUT POS/VEL.
C
C                             THE HEADER IS READ AUTOMATICALLY THE FIRST
C                             TIME THIS FILE IS READ.
C
C  LUEPHEM   1    I*4    I    THE FORTRAN UNIT NUMBER ASSOCIATED WITH
C                             THE EPHEM FILE BEING READ.
C
C                             IF POSITIVE: THIS IS THE NUMBER OF THE
C                               FILE WE WANT TO READ NOW.
C
C                             IF NEGATIVE: WE ARE TELLING THIS ROUTINE
C                               TO SEARCH THE SET OF ACTIVE FILE NUMBERS
C                               FOR IABS(LUEPHEM) AND, IF FOUND, SET THE
C                               FILE TO INACTIVE STATUS. TO DEACTIVATE
C                               ALL FILE NUMBERS, USE -999. LUEPHEM AND
C                               IERR ARE THE ONLY ARGUMENTS REFERENCED.
C
C  LUERR     1    I*4    I    THE FORTRAN UNIT NUMBER FOR PRINTING OF
C                             ERROR MESSAGES. LUERR=0 MEANS NO
C                             MESSAGES ARE POSSIBLE.
C
C  IERR      1    I*4    O    ERROR RETURN FLAG.
C                             = 0, NO ERROR FOUND.
C                             = 1, ERROR FOUND.
C
C
C
C                    *********************
C********************* GETEPHD ARGUMENTS *******************************
C                    *********************
C
C  VARIABLE  DIM  TYPE  I/O   DESCRIPTION
C  --------  ---  ----  ---   -----------
C
C  IRESET     1   I*4    I    SAME DESCRIPTION AS ABOVE.
C
C  LUEPHEM    1   I*4    I    SAME DESCRIPTION AS ABOVE.
C
C  NHINFO     1   I*4    I    MUST EQUAL 52 FOR ERROR CHECKS.
C
C  HEADINFO  52   R*8    O    AN ARRAY CONTAINING INFO READ FROM THE
C                             EPHEMERIS FILE HEADER RECORDS.
C
C     HEADINFO ASSIGNMENTS ARE:
C
C       (1) TIME ASSOCIATED WITH THE INITIAL CONDITIONS. SECONDS SINCE
C           1/1/50, 0.0 HR UT
C
C       (2-8) KEPLERIAN ELEMENTS FOR INITIAL CONDITIONS. ORDER IS A, E,
C             I, N, W, MA, TA.   IN KM AND RADIANS.
C
C       (9) EARLIEST TIME THAT POS/VEL INFO IS GIVEN ON THE FILE.
C           IN SECONDS SINCE 1950.
C
C       (10) LATEST TIME THAT POS/VEL INFO IS GIVEN ON THE FILE.
C            IN SECONDS SINCE 1950.
C
C       (11) STEP SIZE BETWEEN CONSECUTIVE POSITION/VELOCITY ENTRIES.
C            IN SECONDS.
C
C       (12-31) AUXILIARY INFO.
C
C          12) YYMMDD.HHMMSS OBTAINED FROM COMPUTER CLOCK WHEN FILE
C              WAS MADE
C          13) COORDINATE SYSTEM ID. 1=M50, 2=MDT, 3=TOD
C          14) LOADED WITH INFO NOT USEFUL TO THE CALLER. IGNORE IT.
C          15) NUMBER OF GRAVITY PARAMETER POSITIONS PRESENT
C          16) NUMBER OF DRAG PARAMETER POSITIONS PRESENT
C          17) NUMBER OF AUXILIARY PARAMETER POSITIONS PRESENT
C          18-31) NOT USED
C
C       (32-38) GRAVITY MODEL INFO
C
C          32) SUN POINT MASS USED. (0.0=NO; OTHERWISE, YES)
C          33) MOON POINT MASS USED. (0.0=NO; OTHERWISE, YES)
C          34) NUMBER OF ZONAL HARMONICS USED
C          35) NUMBER OF TESSERAL HARMONICS USED
C          36) EARTH MU, KM**3/SEC**2
C          37) MOON MU, KM**3/SEC**2
C          38) SUN MU, KM**3/SEC**2
C
C       (39-52) DRAG MODEL INFO
C
C          39) DRAG FORCES USED. (0.0=DRAG WAS OFF; OTHERWISE, ON)
C              IF DRAG IS OFF, ELEMENTS 40-52 ARE NOT RELEVANT
C          40) S/C MASS, KG
C          41) DRAG COEFFICIENT
C          42) ATMOSPHERE MODEL NUMBER (1=HARPRI, 2=JAC-ROB, 3=ATM62)
C          43) RHO4 PARAMETER FOR HAR-PRI MODEL
C          44) NNCOS PARAMETER FOR HAR-PRI MODEL
C          45) DENSITY SOURCE FOR HAR-PRI.
C              (1=INTERNAL, 2=TOSS FILE, 3=USER)
C          46) HAR-PRI SOLAR FLUX IDENTIFIER
C              (1=65, 2=75, 3=100, 4=125, ..., 10=275)
C          47) FORTRAN UNIT NUMBER USED BY EPHEMGEN PGM FOR THE
C              DENSITY DATA
C          48) ATT-DEP DRAG INDICATOR (0=NO, 1=ATT-DEP, 3=ATT-DEP/SVDS)
C          49) S/C AREA NORMAL TO X-AXIS, OR CONST AREA FOR
C              NO ATTITUDE DEPENDENT DRAG
C          50) S/C AREA NORMAL TO Y-AXIS
C          51) S/C AREA NORMAL TO Z-AXIS
C          52) FORTRAN UNIT NUMBER USED BY EPHEMGEN PGM FOR THE
C              S/C ATTITUDE DATA
C
C  DELEP     1    R*8    O    THE NUMBER OF SECONDS BETWEEN THE ACTUAL
C                             EPOCH TIME USED WHEN THE EPHEM FILE WAS
C                             WRITTEN AND THE EPOCH TIME BEING USED IN
C                             THE GETEPH CALLS FOR POS/VEL INFORMATION.
C
C  LUERR     1    I*4    I    SAME DESCRIPTION AS ABOVE.
C
C  IERR      1    I*4    O    SAME DESCRIPTION AS ABOVE.
C
C
C
C                    *********************
C********************* GETEPHZ ARGUMENTS *******************************
C                    *********************
C
C USAGE NOTE: FOR THE EPHEM FILE INVOLVED ON THIS CALL, AFTER CALLING
C             GETEPHZ AND BEFORE CALLING GETEPH, YOU MUST CALL GETEPHD.
C             SEE A SIMILAR NOTE IN THE GETEPH DESCRIPTION ABOVE.
C
C  VARIABLE  DIM  TYPE  I/O   DESCRIPTION
C  --------  ---  ----  ---   -----------
C
C  EPOCHNEW   1    R*8   I    THE EPOCH TO WHICH THE STATE VECTORS
C                             RETURNED BY SUBSEQUENT GETEPH AND GETEPHD
C                             CALLS ARE TO BE REFERENCED. UNLESS
C                             REDEFINED BY A CALL TO GETEPHZ, STATES
C                             ARE REFERENCED TO THE EPOCH ON THE EPHEM
C                             FILE HEADER. IF EPOCH IS REDEFINED,
C                             STATE VECTORS WILL BE ROTATED TO PRESERVE
C                             THE EARTH-FIXED TRAJECTORY.
C
C  LUEPHEM    1    I*4   I    THE EPHEM FILE FOR WHICH THIS EPOCH
C                             DEFINITION WILL APPLY. IF NEGATIVE, THE
C                             FILE IS DEACTIVATED AND EPOCHNEW HAS NO
C                             EFFECT.
C
C  LUERR     1    I*4    I    SAME DESCRIPTION AS ABOVE.
C
C  IERR      1    I*4    O    SAME DESCRIPTION AS ABOVE.
C
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO 6/81.
C  MODIFIED....... CJP.  7/83. COMMENT MOD, NO CODE MOD.
C                  CJP.  3/85. MAJOR REWRITE TO ALLOW MULTIPLE FILES
C                              TO BE ACTIVE. CALLING SEQ REMAINS INTACT
C                              BUT LUEPHEM NEGATIVE NOW HAS A MEANING.
C                              ADDED ENTRY POINT GETEPHD AND ITS CODE.
C                  CJP.  5/85. MODS TO ALLOW FOR EPOCH CHANGE WHILE
C                              PRESERVING EARTH-FIXED TRAJECTORY.
C
C***********************************************************************
C
C
      INTEGER NUMERR/0/,MAXERR/15/
      REAL*8 TJD50/2433282.5D0/,SECDAY/86400.D0/
      REAL*8 POS(3),VEL(3),ROTMTX(3,3),POSHEAD(3),VELHEAD(3)
      REAL*8 DEGRAD / 57.29577951308232D0 /
      LOGICAL DEACTIVATE
C
      REAL*8 HEADINFO(1)
C
C MAXEPH IS THE MAX NUMBER OF FILES THAT CAN BE ACTIVE AT A TIME. TO
C INCREASE THE MAX, CHANGE THE MAXEPH VALUE. NO OTHER CHANGES NEEDED.
C
      PARAMETER MAXEPH=3
C
      REAL*8  POSBUF(3,100,MAXEPH), VELBUF(3,100,MAXEPH), EPOCH(MAXEPH)
      REAL*8  R8V(62,MAXEPH)
      INTEGER I4V( 6,MAXEPH)
      INTEGER LUINIT(MAXEPH)/MAXEPH*1/,    ! 1 SAYS HEADER NEEDS READING
     *        LUACTIVE(MAXEPH)/MAXEPH*-1/  ! ACTIVE FILE NUMBERS
      REAL*8  DELEPOCH(MAXEPH)/MAXEPH*0.D0/
      INTEGER KENTLAST(MAXEPH)/MAXEPH*0/
C
C
C
C
C >>>>>>> ENTER VIA GETEPH CALL.
C
      KENTRY = 1
      GO TO 2222
C
C
C >>>>>>> ENTER VIA GETEPHD CALL.
C
      ENTRY GETEPHD(IRESET,LUEPHEM,NHINFO,HEADINFO,DELEP,LUERR,IERR)
      KENTRY = 2
      GO TO 2222
C
C
C >>>>>>> ENTER VIA GETEPHZ CALL.
C
      ENTRY GETEPHZ(EPOCHNEW,LUEPHEM,LUERR,IERR)
      KENTRY = 3
C
C
C
 2222 CONTINUE
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) THEN
        IF(KENTRY.EQ.1) TEMP = PAKTIM50(TIM50)
        IF(KENTRY.EQ.2) TEMP = 999999.999999
        IF(KENTRY.EQ.3) TEMP = PAKTIM50(EPOCHNEW)
        WRITE(LUBUG,5001) TEMP,IRESET,LUEPHEM,LUACTIVE
 5001   FORMAT(/,' GETEPH. START DEBUG.',
     *       ' TIME=',G20.12,'  IRESET,LUEPHEM=',2I4/,
     *         '      LUACTIVE=',<MAXEPH>I3)
        END IF
C
      IERR = 0
C
C
C IF THIS IS A CALL TO DEACTIVATE A FILE, DO SO AND RETURN.
C
      IF(LUEPHEM.LT.0) THEN
        IEPH = 0
        LU = -LUEPHEM
        DO WHILE (IEPH.LT.MAXEPH)
          IEPH = IEPH + 1
          DEACTIVATE =  LU.EQ.999 .OR. LU.EQ.LUACTIVE(IEPH)
          IF(DEACTIVATE) THEN
            LUACTIVE(IEPH) = -1
            LUINIT(IEPH) = 1
            DELEPOCH(IEPH) = 0.D0
            END IF
          END DO
        GO TO 9999
        END IF
C
C
C SEE IF THE FILE IS ALREADY ACTIVE. IF SO, SET LUINDEX.
C
      LUINDEX = 0
      IEPH = 0
      DO WHILE (LUINDEX.EQ.0 .AND. IEPH.LT.MAXEPH)
        IEPH = IEPH + 1
        IF(LUACTIVE(IEPH).EQ.LUEPHEM) LUINDEX = IEPH
        END DO
C
C
C IF NOT ALREADY ACTIVE(IE, LUINDEX IS STILL ZERO), MAKE IT ACTIVE.
C
      IF(LUINDEX.EQ.0) THEN
        IEPH = 0
        DO WHILE(LUINDEX.EQ.0 .AND. IEPH.LT.MAXEPH)
          IEPH = IEPH + 1
          IF(LUACTIVE(IEPH).LE.0) THEN
            LUINDEX = IEPH
            LUINIT(IEPH) = 1
            LUACTIVE(LUINDEX) = LUEPHEM
            END IF
          END DO
        END IF
C
C IF STILL NOT ACTIVE, THEN MAX FILES WERE ACTIVE AND THERE WAS NO
C ROOM FOR A NEW ONE. THE USER CAN DEACTIVATE SOME FILES TO MAKE ROOM
C FOR THIS ONE, OR ELSE RECOMPLILE THIS ROUTINE WITH A LARGER MAXEPH
C VALUE. IN ANY CASE, THIS IS AN ERROR CONDITION. CODING COULD HAVE HAD
C THE CURRENT FILE REPLACE ONE ALREADY ACTIVE, BUT CJP PREFERS TO HAVE
C AN ERROR CONDITION SO THIS ROUTINE WILL BE USED PROPERLY.
C
      IF(LUINDEX.EQ.0) THEN
        IERR = 1
        IF(LUERR.GT.0) WRITE(LUERR,4001) LUEPHEM,LUACTIVE
 4001   FORMAT(/,
     *    ' GETEPH ERROR. HAVE NOT READ READ EPHEM FILE ',I2,
     *       '. MAX FILES ARE ACTIVE.'/,
     *    '        ACTIVE FILES ARE ',<MAXEPH>I3/)
        GO TO 9999
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,5002) LUINDEX
 5002 FORMAT(/,' GETEPH DEBUG 5002. LUINDEX=',I3)
C
C
C IF THIS FILE IS NEWLY ACTIVE WITH THIS CALL, READ THE HEADER RECORD
C AND LOAD R8V, I4V, POSBUF, VELBUF, AND EPOCH. THESE ARRAYS ARE CARRIED
C AS THEY ARE FOUND ON THE EPHEM FILE, NOT MODIFIED TO ACCOMMODATE ANY
C EPOCH CHANGE THAT MAY BE INVOLVED.
C
      NEWACTIVE = (IRESET.NE.0 .OR. LUINIT(LUINDEX).EQ.1)  .AND.
     *             KENTRY.NE.3
      IF(NEWACTIVE) THEN
        LUINIT(LUINDEX) = 0
        R8V(12,LUINDEX) = 1.D0
        R8V(13,LUINDEX) = 1.D0
        I4V( 1,LUINDEX) = LUEPHEM
        I4V( 2,LUINDEX) = 4
        I4V( 3,LUINDEX) = 1
        IF(IBUG.NE.0) WRITE(LUBUG,5009) LUEPHEM
 5009   FORMAT(/,' GETEPH DEBUG 5009. INITIALIZE BUFFERS FOR UNIT',I3)
        CALL RDEPHM('ZZZZZZZZ',POS,VEL,IER,LUERR,
     *        POSBUF(1,1,LUINDEX),VELBUF(1,1,LUINDEX),
     *        R8V(1,LUINDEX),I4V(1,LUINDEX))
        EPOCH(LUINDEX) = (R8V(14,LUINDEX) - TJD50) * SECDAY
C
C      ERROR CHECK. ERROR MESSAGE WOULD HAVE BEEN WRITTEN FROM RDEPHM.
        IF(IER.NE.0) THEN
          IERR = 1
          GO TO 9999
          END IF
C
C      DEBUG.
        IF(IBUG.NE.0) WRITE(LUBUG,1001) LUINDEX,LUEPHEM,
     *     (R8V(I,LUINDEX),I=1,62), (I4V(I,LUINDEX),I=1,6),
     *     (I,(POSBUF(J,I,LUINDEX),J=1,3),I=1,20)
 1001   FORMAT(' GETEPH DEBUG.   LUINDEX=',I2,'  LUEPHEM=',I3/,
     *         '  R8V = ',15(T12,4G15.7/),T12,2G15.7/,
     *         '  I4V = ',6I5/,
     *         '  POSBUF(1-3,1-20,LUINDEX) = '/,20(T5,I2,2X,3G15.7/))
        END IF
C
C
C *****************************
C * GET THE OUTPUT QUANTITIES *
C *****************************
C
C *** IF ENTERED VIA GETEPH, GET THE S/C POSITION AT TIME TIM50 ***
C
      IF(KENTRY.EQ.1) THEN
C
C     ERROR CHECK. SEE USAGE COMMENTS AT THE TOP OF THIS LISTING FOR
C     INFORMATION ON WHY GETEPHZ CALL FOLLOWED BY GETEPH CALL IS NOT
C     PERMITTED.
C
       IF(KENTLAST(LUINDEX).EQ.3) THEN
         STOP ' GETEPH. PROGRAMMER ERROR, NOT USER ERROR. STOPPED.'
         END IF
C
C      GET THE STATE VECTOR. TIM50 ACCOUNTS FOR ANY EPOCH CHANGE, AND
C      SINCE THE R8V, I4V, POSBUF, VELBUF, AND EPOCH ARRAYS ARE RELATED
C      TO THE ACTUAL EPOCH ON THE FILE, WE DO OUR COMPUTATIONS RELATIVE
C      TO THE ORIGINAL EPOCH, THEN ACCOUNT FOR THE EPOCH CHANGE.
        DT = DELEPOCH(LUINDEX)
        TFILE = (TIM50 - DT)  - EPOCH(LUINDEX)
        CALL RDEPHM(TFILE,POS,VEL,
     *         IER,LUERR,POSBUF(1,1,LUINDEX),VELBUF(1,1,LUINDEX),
     *         R8V(1,LUINDEX),I4V(1,LUINDEX))
C
C      ERROR CHECK. ERROR MESSAGE WOULD HAVE BEEN WRITTEN FROM RDEPHM.
        IF(IER.NE.0) THEN
          IERR = 1
          GO TO 9999
          END IF
C
C      IF AN EPOCH CHANGE IS INVOLVED, ROTATE THE STATE VECTOR.
        IF(DT.NE.0.D0) THEN
          KCOORD = JIDNNT(R8V(23,LUINDEX))
          CALL ROTSLIP1(KCOORD,TIM50-DT,DT,ROTMTX,LUERR,IER1)
          CALL VECROT(ROTMTX,POS,POS,3,1)
          CALL VECROT(ROTMTX,VEL,VEL,3,1)
          END IF
C
        KENTLAST(LUINDEX) = KENTRY
        END IF
C
C
C ********** IF ENTERED VIA GETEPHD, LOAD HEADER INFO ARRAY ************
C
      IF(KENTRY.EQ.2) THEN
C
C      EPOCH AND R8V ARE AS THEY ARE ON THE EPHEM FILE. LOAD HEADINFO
C      WITH THOSE VALUES. IF AN EPOCH CHANGE IS INVOLVED, MODIFY
C      HEADINFO AFTERWARD.
C
        HEADINFO(1) = EPOCH(LUINDEX)
        DO 200 I=1,7
  200   HEADINFO(1+I)=R8V(14+I,LUINDEX)  !SEE RDEPHM FOR R8V DESCRIPTION
        HEADINFO( 9) = EPOCH(LUINDEX) + (R8V(5,LUINDEX)-R8V(7,LUINDEX))
        HEADINFO(10) = EPOCH(LUINDEX) + (R8V(6,LUINDEX)+R8V(8,LUINDEX))
        HEADINFO(11) = R8V(3,LUINDEX)
C
C      CHANGE HEADINFO CONTENTS IF EPOCH CHANGE IS INVOLVED
        DELEP = DELEPOCH(LUINDEX)
        IF(DELEP.NE.0.D0) THEN
C        EPOCH.
          HEADINFO(1) = HEADINFO(1) + DELEP
C        KEPLERIAN ELEMENTS
          KCOORD = JIDNNT(R8V(23,LUINDEX))
          CALL ROTSLIP1(KCOORD,EPOCH(LUINDEX),DELEP,ROTMTX,LUERR,IER1)
          UEARTH = R8V(46,LUINDEX)
          CALL TOCART(UEARTH,HEADINFO(2),0,POSHEAD,VELHEAD,LUERR,IER1)
          CALL VECROT(ROTMTX,POSHEAD,POSHEAD,3,1)
          CALL VECROT(ROTMTX,VELHEAD,VELHEAD,3,1)
          CALL TOKEPL(UEARTH,POSHEAD,VELHEAD,HEADINFO(2),DUM,DUM)
          HEADINFO(8) = ANOMLY(1,HEADINFO(8),HEADINFO(3),LUERR,IER1)
C        EARLIEST/LATEST TIMES
          HEADINFO( 9) = HEADINFO( 9) + DELEP
          HEADINFO(10) = HEADINFO(10) + DELEP
          END IF
C
        NINFO1 = 11
        NGRAV =   7
        NDRAG =  14
        NAUXIL = 20
C
C      ERROR CHECK. DONE TO PROMOTE CONSISTENCY BETWEEN EPHEAD AND
C      GETEPH IN FUTURE MODS.  IE, IF CALLER CALLS WITH THE WRONG
C      VALUE, CALLER MODS ARE NEEDED BECAUSE THE QUANTITIES THE CALLER
C      EXPECTS IN HEADINFO ARE DIFFERENT THAN WHAT THIS ROUTINE WANTS
C      TO RETURN.
        IF( (NINFO1+NGRAV+NDRAG+NAUXIL).NE.NHINFO)
     *     STOP ' GETEPH. ENTRY GETEPHD. CODING ERROR. STOP 1.'
C
C      LOAD THE REST OF THE HEADINFO ARRAY
        INDX1 = 22
        INDX2 = NINFO1 + 1
        CALL MTXEQL(R8V(INDX1,LUINDEX),HEADINFO(INDX2),NAUXIL,1)
        INDX1 = INDX1 + NAUXIL
        INDX2 = INDX2 + NAUXIL
        CALL MTXEQL(R8V(INDX1,LUINDEX),HEADINFO(INDX2),NGRAV,1)
        INDX1 = INDX1 + NGRAV
        INDX2 = INDX2 + NGRAV
        CALL MTXEQL(R8V(INDX1,LUINDEX),HEADINFO(INDX2),NDRAG,1)
C
C      IF ONE OF THESE ERRORS OCCURS, THEN THE HEADINFO DESCRIPTION
C      IN THE PROLOGUE IS WRONG.  FORCE A LOOK AND A FIX.  THIS
C      DESCRIPTION DOES NOT AGREE WITH WHAT WAS WRITTEN ON THE
C      HEADER FILE BY EPHFILE.
        IF(JIDNNT(HEADINFO(15)).NE.NGRAV)
     *        STOP 'GETEPH. ENTRY GETEPHD. CODING ERROR. STOP 2.'
        IF(JIDNNT(HEADINFO(16)).NE.NDRAG)
     *        STOP 'GETEPH. ENTRY GETEPHD. CODING ERROR. STOP 3.'
        IF(JIDNNT(HEADINFO(17)).NE.NAUXIL)
     *        STOP 'GETEPH. ENTRY GETEPHD. CODING ERROR. STOP 4.'
C
        KENTLAST(LUINDEX) = KENTRY
        END IF
C
C
C ********** IF ENTERED VIA GETEPHZ, STORE THE EPOCH CHANGE ************
C
      IF(KENTRY.EQ.3) THEN
        DELEPOCH(LUINDEX) = EPOCHNEW - EPOCH(LUINDEX)
        KENTLAST(LUINDEX) = KENTRY
        END IF
C
C
C
 9999 CONTINUE
C
      IF(IBUG.NE.0) THEN
        IF(KENTRY.EQ.1) THEN
          WRITE(LUBUG,5003) PAKTIM50(TIM50),POS,VEL,IERR,LUACTIVE
 5003     FORMAT(/,' GETEPH RETURNING. TIME=',G20.12/,
     *         '   POS=',3G16.7/,'   VEL=',3G16.7/,
     *         '   IERR=',I3,'  LUACTIVE=',<MAXEPH>I4)
          END IF
        IF(KENTRY.EQ.2) THEN
          WRITE(LUBUG,5004)
     *       1,PAKTIM50(HEADINFO(1)),HEADINFO(2),HEADINFO(3),
     *       4,HEADINFO(4)*DEGRAD,HEADINFO(5)*DEGRAD,HEADINFO(6)*DEGRAD,
     *       7,HEADINFO(7)*DEGRAD,HEADINFO(8)*DEGRAD,
     *            PAKTIM50(HEADINFO(9)),
     *      10,PAKTIM50(HEADINFO(10)),HEADINFO(11),HEADINFO(12),
     *       (I,(HEADINFO(J),J=I,I+2),I=13,NHINFO,3)
 5004     FORMAT(/,' GETEPH(GETEPHD) RETURNING HEADER INFO:'/,
     *      999(T5,I3,') ',3G20.12/) )
          WRITE(LUBUG,5005) IERR,LUACTIVE
 5005     FORMAT('   IERR=',I3,'  LUACTIVE=',<MAXEPH>I4)
          END IF
        END IF
C
      RETURN
      END


        PROGRAM INDPAC
C
C
        PARAMETER(IM=51)
        PARAMETER(JM=51)
        PARAMETER(MMI=im-1)
        PARAMETER(MMJ=jm-1)
        CHARACTER*85 CDUM
        CHARACTER*4 CFIL,CRAP,CCCC
C
       REAL GDH1X(IM,JM),GDH2X(IM,JM),GDH1Y(IM,JM),
     Z GDH2Y(IM,JM),US1(IM,JM),US2(IM,JM),VS1(IM,JM),VS2(IM,JM),
     1    ECOM(JM)
        DIMENSION U1(IM,JM,3),U2(IM,JM,3),V1(IM,JM,3),V2(IM,JM,3),
     X H1(IM,JM,3),H2(IM,JM,3)
     2  ,IHM(IM,JM),IUM(IM,JM),IVM(IM,JM),WXS(IM,JM),WYS(IM,JM)
     6  ,U1MEAN(MMI,MMJ),RUS1(IM,JM),RVS1(IM,JM),V1MEAN(MMI,MMJ)
     7    ,TAUX(84,30),TAUY(84,30),IDAY(12),DUM(IM,JM)
        DIMENSION TPH(IM,JM),POTE(7),AKINE(7),ALAT1(7),ALAT2(7),
     1   ALONG1(7),ALONG2(7),IX1(7),IX2(7),IY1(7),IY2(7),ITM(IM,JM),
     2   STRKX(6),STRKY(6),TRGT(6),TRACKW(6),RMSTK(6),RMSREG(7),
     3   DAY(12),DOBS(IM,JM),TISO(6),IOBS(IM,JM),NOTAU(400),
     4   BY(IM,JM),VECW(IM,IM),H1P(IM,JM),DIFCORD(IM,JM),RHO(IM,JM),
     5   NOBS(7),NNOBS(6),DIFH(IM,JM),DINM(12),BX(IM,JM)
     6    ,WEIGHT(IM,JM),VARREG(7),VARTRK(6),IPOS(400),JPOS(400)
     7     ,ERR(IM,JM),ERRREG(7),ERRTK(6)
     8   ,TH1(IM,JM),TH2(IM,JM),TU1(IM,JM),TU2(IM,JM),TV1(IM,JM),
     9   TV2(IM,JM),DEX1(IM),STUA(IM),STUB(IM),STVA(IM),STVB(IM)
     9   ,DEY1(IM),IUP(IM,JM)
C
         DIMENSION HKM(IM,JM),HK(IM,JM),HKP(IM,JM),UKM(IM,JM),
     1    UK(IM,JM),UKP(IM,JM),VKM(IM,JM),VK(IM,JM),VKP(IM,JM)
     2   ,AMEAN(IM,JM),WXT(169,61),WYT(169,61),TIX(94,58),
     3    TIY(94,58),SUPOT(6),SUKIN(6)
c
	real hp(im,jm),up(im,jm),vp(im,jm)
c
	real wvert(im,jm),wupy(jm)
C
c
	common/vars/beta,dx,dy,fh(jm),fv(jm),wx(im,jm),wy(im,jm)
c
c.......open plot file......
c
	call newdev('prob3.ps',8)
	call psinit(.true.)
c
	open(unit=15,file='ex6_prob3.input',status='old')
c
c	open(unit=8,file='plottest.out',form='unformatted')
	open(unit=27,file='restart.dat',form='unformatted')
c
c.......read input parameters.......
c
        iftype=2
        ifnonl=0
c
	read(15,*)itstop
c	read(15,*)iftype
	read(15,*)phi0
	read(15,*)ipltm
	read(15,*)asubh
c	read(15,*)ifnonl
C
        itstop=12.*itstop
        asubh=1.e4*asubh
C
        IMAX=IM
        JMAX=JM
        IMJM=IM*JM
        IMIM=IM*IM
        IR=IMAX-2
C
C
       KTAU=0
C.......ISTART=START UP TIMESTEP FOR NEXT RUN...
        ISTART=16*30*12
C.......JJSTOP=STOP TIMESTEP FOR THIS RUN.....
        JJSTOP=16*30*itstop
C......IDSTR=START UP DAY....
        IDSTR=15
C......MTHSTR=START UP MONTH.......
        MTHSTR=1
C........IYR=START UP YEAR........
        IYR=77
        MONTH1=MTHSTR
        IYEAR1=IYR
        IMTH=MTHSTR
        JMTH=MTHSTR
        ITAU=KTAU
        ISTOP=0
          LNUP=0
        CFIL='FILE'
        JSUP=0
C
C.......DEFINE MEAN ISOTHERM DEPTH IN METRES....
C
        AMLD=200
C
C......CLEAR NVAL= NO. OF TIMESTEPS USED TO DETERMINE MEAN DEPTH OF
C      LAYER AT EACH GRIDPOINT...
C
       NVAL=0
C
       DO 22 I=1,IMAX
       DO 22 J=1,JMAX
        DO 23 KK=1,3
        V1(I,J,KK)=0.
        V2(I,J,KK)=0.
        U1(I,J,KK)=0.
        U2(I,J,KK)=0.
        H1(I,J,KK)=0.
        H2(I,J,KK)=0.
 23      CONTINUE
 22      CONTINUE
       KM=1
       K=2
       KP=3
       DO 24 I=1,IM
       DO 24 J=1,JM
        AMEAN(I,J)=0.0
        WEIGHT(I,J)=0.0
        ERR(I,J)=0.0
        DIFH(I,J)=0.0
        TPH(I,J)=0.0
        ITM(I,J)=0
        DOBS(I,J)=0.0
        IOBS(I,J)=0
        IUP(I,J)=0
        BX(I,J)=0.0
        BY(I,J)=0.0
        H1P(I,J)=0.0
        DIFCORD(I,J)=0.0
        RHO(I,J)=1.0
       US1(I,J)=0
      US2(I,J)=0
      VS1(I,J)=0
      VS2(I,J)=0
      GDH1X(I,J)=0.
      GDH2X(I,J)=0.
      GDH1Y(I,J)=0.
      GDH2Y(I,J)=0.
        WX(I,J)=0.0
        WY(I,J)=0.0
      WXS(I,J)=0.0
        WYS(I,J)=0.0
        DUM(I,J)=0.0
 24    CONTINUE
C        CALL SETRAR(WXT,10309,0.0)
C        CALL SETRAR(WYT,10309,0.0)
C        CALL SETRAR(TIX,5452,0.0)
C        CALL SETRAR(TIY,5452,0.0)
C        CALL SETRAR(NOTAU,400,0)
C        CALL SETRAR(IPOS,400,1)
C        CALL SETRAR(JPOS,400,1)
C
        DO 759 J=1,30
        DO 759 I=1,84
        TAUX(I,J)=0.0
 759    TAUY(I,J)=0.0
      ITAPE=100
 98    FORMAT(I5)
 97    FORMAT(1X,' KTAPE=',I5,' KTAU=',I5)
C*******************************
C......SET UP G12 SUCH THAT C=280 CM/S WITH ANY HH1.......
C
       G12=0.075
c       G12=0.4
C*******************************
       G23=0.0
        SCV=1.0E3
        SCH=1.0E2
        DX=1.E7/0.9
        DY=1.E7/0.9
C*******DEEPEN LAYER IF NECESSARY********
c       HH1=100000.
       HH1=400000.
       HH2=10000.
       BETA=2.E-13
       DO 765 I=1,IM
       DEX1(I)=HH1
       DEY1(I)=HH1
       STUA(I)=0.0
       STUB(I)=0.0
       STVA(I)=0.0
       STVB(I)=0.0
 765   CONTINUE
       TDX=2.*DX
       TDY=2.*DY
       DX2=DX*DX
       DY2=DY*DY
        RDX=1.0/DX
        RDY=1.0/DY
        RDX2=1.0/DX2
        RDY2=1.0/DY2
        DXDY=DX*DY
        RDXDY=1.0/DXDY
c        DAMP=1.0E4
        DAMP=0.
      DD=0.0
c      DD=1./(36.*30.*24.*3600.)
       IMAXM=IMAX-1
       JMAXM=JMAX-1
       ISMTH=31
       IPR=365
      DVT=0.0
c      DVT=1./(30.*24.*3600.)
      DVB=0.0
       DT=86400./16.
       TDT=2.*DT
C.....DEFINE VECTOR WORK SPACE
        CALL SETRAR(VECW,IMIM,0.0)
        DO 341 I=1,IM
        DO 341 II=1,IM
  341   VECW(II,I)=(I-II)
C
C******************************
        JE=(jm-1)/2+1
        IE=(im-1)/2+1
C********************************
c
c......f-plane...
c
       if(iftype.eq.1)then
c
	f0=2.*7.292e-5*sin(phi0*2.*4.*atan(1.0)/360.)
c
       DO J=2,JMAXM
        FH(J)=f0
        FV(J)=f0
       ENDDO
c
       endif
c
c......mid-latitude beta-plane...
c
       if(iftype.eq.2)then
c
	f0=2.*7.292e-5*sin(phi0*2.*4.*atan(1.0)/360.)
c
       DO 15 J=2,JMAXM
        FH(J)=f0+(J-JE-0.5)*DY*BETA
        FV(J)=f0+(J-JE)*DY*BETA
 15     CONTINUE
c
       endif
c
c......equatorial beta-plane...
c
       if(iftype.eq.3)then
c
       DO J=2,JMAXM
        FH(J)=(J-JE-0.5)*DY*BETA
        FV(J)=(J-JE)*DY*BETA
       ENDDO
c
       endif
c
	do j=2,jmaxm
c	  ecom(j)=2.e8
	  ecom(j)=asubh
	enddo
c
C********READ IN GEOMETRY*********
c
	do j=1,jm
	do i=1,im
	  ihm(i,j)=1
	enddo
	enddo
c
	do j=1,jm
	  ihm(1,j)=0
	  ihm(im,j)=0
	enddo
c
	do i=1,im
	  ihm(i,1)=0
	  ihm(i,jm)=0
	enddo
c
c......Add a ridge........
c
c	goto 8899
c
	iridge=25
c
c	do j=6,jm-5
c	   ihm(iridge,j)=0
c	   ihm(iridge+1,j)=0
c	enddo
c
c	goto 1059
c
	do j=6,10
	   ihm(iridge,j)=0
	   ihm(iridge+1,j)=0
	enddo
c
	do j=14,jm-16
	   ihm(iridge,j)=0
	   ihm(iridge+1,j)=0
	enddo
c
	do j=jm-12,jm-5
	   ihm(iridge,j)=0
	   ihm(iridge+1,j)=0
	enddo
c
 1059   continue
c
 8899   continue
c
        DO 43 J=1,JM
       DO 43 I=1,IMAXM
 43     IUM(I,J)=IHM(I,J)*IHM(I+1,J)
       DO 46 J=1,JMAXM
       DO 46 I=1,IM
 46     IVM(I,J)=IHM(I,J)*IHM(I,J+1)
C
c
c########################################
c
c	skip read!!!
c
c########################################
c
c
c.......set up the upwelling array.....
c
	do j=1,jm
	  do i=1,im
	    wvert(i,j)=0.0
	  enddo
	enddo
c
	do j=1,jm
c	   wupy(j)=sin(4.*atan(1.0)*float(j-1)/float(jm-1))
	   wupy(j)=1.0
	enddo
c
	print *,'wupy=',wupy
c
c.......set a source in the NW corner....
c
c........vtrans is the source strength in cm^3/s
c
c	vtrans=0.5*1.e6*1.e6
	vtrans=10.*1.e6*1.e6
	npcnt=0
	do j=jm-3,jm-1
	   do i=2,4
	    npcnt=npcnt+ihm(i,j)
	   enddo
	enddo
c
	npland=0.
	do j=2,jm-1
	do i=2,im-1
	  npland=npland+ihm(i,j)
	enddo
	enddo
c
	print *,'npcnt=',npcnt,' npland=',npland
c
	wdown=-1.*vtrans/(float(npcnt)*dx*dy)
c
c	wup=vtrans/((npland-npcnt)*dx*dy)
c
	print *,'wdown=',wdown,' wup=',wup
c
	do j=2,jm-1
	 do i=2,im-1
c	   wvert(i,j)=wup
	   wvert(i,j)=wupy(j)
	 enddo
	enddo
c
	wtrans=0.
	do j=2,jm-4
	do i=2,im-1
	   wtrans=wtrans+wvert(i,j)*dx*dy
	enddo
	enddo
c
	do i=5,im-1
	  do j=jm-3,jm-1
	   wtrans=wtrans+wvert(i,j)*dx*dy
	  enddo
	enddo
c
	do j=2,jm-1
	  do i=2,im-1
	    wvert(i,j)=vtrans*wvert(i,j)/wtrans
	  enddo
	enddo
c
	do j=jm-3,jm-1
	   do i=2,4
	    wvert(i,j)=wdown
	   enddo
	enddo
c
	print *,'wvert=',(wvert(2,j),j=1,im)
c
c
	wtrans=0.
	do j=2,jm-1
	do i=2,im-1
	   wtrans=wtrans+wvert(i,j)*dx*dy
	enddo
	enddo
c
	print *,'wtrans over whole domain=',wtrans
c
C
 500    CONTINUE
c
       KTAU=KTAU+1
c
c	print *,'ktau=',ktau
c
       TDT=2.*DT
       IF(KTAU.EQ.1)TDT=DT
C
c
c#######################################
c
c       skip the wind read and interpolation
c
c######################################
c
c	if(ktau.le.16*30*2)then
c	do j=27,37
c	do i=154,164
c	  wx(i,j)=0.1
c	  wy(i,j)=0.
c	enddo
c	enddo
c	endif
c
c	if(ktau.gt.16*30*2)then
c	do j=27,37
c	do i=154,164
c	  wx(i,j)=0.
c	  wy(i,j)=0.
c	enddo
c	enddo
c	endif
c
C
C     *****
C     IF YOU CHANGE FORCING AMPLITUDE, CHANGE THE SCALING
C
      SCV=1.0E3
      SCH=1.0E2
       DO 20 J=2,JMAXM
       DO 20 I=2,IMAXM
       GDH2X(I,J)=-G23*(H2(I+1,J,K)-H2(I,J,K))/DX
       GDH2Y(I,J)=-G23*(H2(I,J+1,K)-H2(I,J,K))/DY
 20     CONTINUE
       DO 21 J=2,JMAXM
       DO 21 I=2,IMAXM
       GDH1X(I,J)=GDH2X(I,J)-G12*(H1(I+1,J,K)-H1(I,J,K))/DX
       GDH1Y(I,J)=GDH2Y(I,J)-G12*(H1(I,J+1,K)-H1(I,J,K))/DY
 21     CONTINUE
       DO 128 J=2,JMAXM
      DO 28 I=2,IMAXM
      H1AX=HH1+(H1(I,J,K)+H1(I+1,J,K))/2.
      H2AX=HH2+(H1(I,J,K)+H1(I+1,J,K))/2.-(H2(I,J,K)+H2(I+1,J,K))/2.
      H1AY=HH1+(H1(I,J,K)+H1(I,J+1,K))/2.
      H2AY=HH2+(H1(I,J,K)+H1(I,J+1,K))/2.-(H2(I,J,K)+H2(I,J+1,K))/2.
      US1(I,J)=U1(I,J,K)/H1AX
      VS1(I,J)=V1(I,J,K)/H1AY
      US2(I,J)=U2(I,J,K)/H2AX
      VS2(I,J)=V2(I,J,K)/H2AY
 399     FORMAT(1X,2I5,8E12.3)
 28      CONTINUE
 128    CONTINUE
C
C
C........DEFINE TEMPORARY ARRAYS....
C
         DO 6789 J=1,JM
         DO 6789 I=1,IM
         HKM(I,J)=H1(I,J,KM)
         HK(I,J)=H1(I,J,K)
         HKP(I,J)=H1(I,J,KP)
         UKM(I,J)=U1(I,J,KM)
         UK(I,J)=U1(I,J,K)
         UKP(I,J)=U1(I,J,KP)
         VKM(I,J)=V1(I,J,KM)
         VK(I,J)=V1(I,J,K)
         VKP(I,J)=V1(I,J,KP)
 6789    CONTINUE
C
C
       DO 30 J=2,JMAXM
CDIR$ IVDEP
       DO 30 I=2,IMAXM
      DEX1(I)=HH1+(HK(I,J)+HK(I+1,J))/2.
C     DEX2=HH2-(H2(I,J,K)+H2(I+1,J,K)-H1(I,J,K)-H1(I+1,J,K))/2.
      STUA(I)=DVT*(UKM(I,J) - U2(I,J,KM))
C      STUB(I)=DVB*U2(I,J,KM)
       UKP(I,J)=UKM(I,J)+TDT*IUM(I,J)*(
     1 0.25*( FV(J)*(VK(I,J)+VK(I+1,J))
     1  +FV(J-1)*(VK(I,J-1)+VK(I+1,J-1))) +GDH1X(I,J)*DEX1(I)
     2 + WX(I,J) - STUA(I)
     3 +ECOM(J)*((UKM(I+1,J)-2.*UKM(I,J)+UKM(I-1,J))/DX2+
     5  ((UKM(I,J+1)-UKM(I,J))/DY*IUM(I,J)*IUM(I,J+1)
     5  +(UKM(I,J-1)-UKM(I,J))/DY*IUM(I,J)*IUM(I,J-1))/DY)
     9         )
30    CONTINUE
C
c.......switch on nonlinear terms if required....
c
	if(ifnonl.ne.0)then
c
	do j=2,jmaxm
	do i=2,imaxm
c
       UKP(I,J)=UKP(I,J)+TDT*IUM(I,J)*(
     5  -(((UK(I+1,J)+UK(I,J))*(US1(I+1,J)+US1(I,J))-
     6  (UK(I-1,J)+UK(I,J))*(US1(I-1,J)+US1(I,J)))/DX
     7  +((VK(I+1,J)+VK(I,J))*(US1(I,J+1)+US1(I,J))-
     8   (VK(I+1,J-1)+VK(I,J-1))*(US1(I,J)+US1(I,J-1)))/DY)/4.
     9         )
c
	enddo
	enddo
c
	endif
c
       DO 31 J=2,JMAXM
CDIR$ IVDEP
       DO 31 I=2,IMAXM
      DEY1(I)=HH1+(HK(I,J)+HK(I,J+1))/2.
C     DEY2=HH2-(H2(I,J,K)+H2(I,J+1,K)-H1(I,J,K)-H1(I,J+1,K))/2.
      STVA(I)=DVT*(V1(I,J,KM) - V2(I,J,KM))
C      STVB(I)=DVB*V2(I,J,KM)
      VKP(I,J)=VKM(I,J)+TDT*IVM(I,J)*(
     1 -0.25*(FH(J+1)*(UK(I,J+1)+UK(I-1,J+1))
     1  +FH(J)*(UK(I,J)+UK(I-1,J)))+GDH1Y(I,J)*DEY1(I)
     2  +WY(I,J) - STVA(I)
     3 +ECOM(J)*(((VKM(I+1,J)-VKM(I,J))/DX*IVM(I,J)*IVM(I+1,J)+
     3 (VKM(I-1,J)-VKM(I,J))/DX*IVM(I,J)*IVM(I-1,J))/DX+
     4         (VKM(I,J+1)-2.*VKM(I,J)+VKM(I,J-1))/DY2)
     9         )
31     CONTINUE
c
c......switch on nonlinear terms if required....
c
	if(ifnonl.ne.0)then
c
	do j=2,jmaxm
	do i=2,imaxm
c
      VKP(I,J)=VKP(I,J)+TDT*IVM(I,J)*(
     5  -(((UK(I,J)+UK(I,J+1))*(VS1(I,J)+VS1(I+1,J))-
     6   (UK(I-1,J)+UK(I-1,J+1))*(VS1(I-1,J)+VS1(I,J)))/DX
     7  +((VK(I,J+1)+VK(I,J))*(VS1(I,J+1)+VS1(I,J))-
     8  (VK(I,J-1)+VK(I,J))*(VS1(I,J-1)+VS1(I,J)))/DY)/4.
     9         )
c
	enddo
	enddo
c
	endif
C
C
       DO 32 J=2,JMAXM
       DO 32 I=2,IMAXM
       HKP(I,J)=HKM(I,J)+TDT*IHM(I,J)*(
     1 -1.*((UK(I,J)-UK(I-1,J))/DX+
     1 (VK(I,J)-VK(I,J-1))/DY) - DD*HKM(I,J)
     2   +DAMP*(((HKM(I+1,J)-HKM(I,J))*IHM(I,J)*IHM(I+1,J)
     3   +(HKM(I-1,J)-HKM(I,J))*IHM(I,J)*IHM(I-1,J))*RDX2
     4   +((HKM(I,J+1)-HKM(I,J))*IHM(I,J)*IHM(I,J+1)
     5   +(HKM(I,J-1)-HKM(I,J))*IHM(I,J-1)*IHM(I,J))*RDY2)
     6   -wvert(i,j)
     6           )
  32    CONTINUE
C
C......RESET H1, U1 AND V1 ARRAYS...........
C
       DO 6790 J=1,JM
       DO 6790 I=1,IM
       H1(I,J,KP)=HKP(I,J)
       U1(I,J,KP)=UKP(I,J)
       V1(I,J,KP)=VKP(I,J)
 6790  CONTINUE
C
       IF(KTAU/ISMTH*ISMTH.NE.KTAU) GO TO 700
       DO 600 J=1,JMAX
       DO 600 I=1,IMAX
       U1(I,J,KP)=.5*(U1(I,J,KP)+U1(I,J,K))
       U1(I,J,K )=.5*(U1(I,J,KM)+U1(I,J,K))
       V1(I,J,KP)=.5*(V1(I,J,KP)+V1(I,J,K))
       V1(I,J,K )=.5*(V1(I,J,KM)+V1(I,J,K))
C      U2(I,J,KP)=.5*(U2(I,J,KP)+U2(I,J,K))
C      U2(I,J,K )=.5*(U2(I,J,KM)+U2(I,J,K))
C      V2(I,J,KP)=.5*(V2(I,J,KP)+V2(I,J,K))
C      V2(I,J,K )=.5*(V2(I,J,KM)+V2(I,J,K))
       H1(I,J,KP)=.5*(H1(I,J,KP)+H1(I,J,K))
       H1(I,J,K )=.5*(H1(I,J,KM)+H1(I,J,K))
C      H2(I,J,KP)=.5*(H2(I,J,KP)+H2(I,J,K))
C      H2(I,J,K )=.5*(H2(I,J,KM)+H2(I,J,K))
 600    CONTINUE
 700    CONTINUE
C
C.....PREVENT THERMOCLINE FROM SURFACING........
C
c        DO 9191 J=1,JM
c        DO 9191 I=1,IM
c 9191   H1(I,J,KP)=AMIN1(H1(I,J,KP),0.9*HH1)
c 9191   H1(I,J,KP)=AMIN1(H1(I,J,KP),1.65E4)
c
	do j=1,jm
	do i=1,im
	  if(h1(i,j,kp).gt.0.95*hh1)h1(i,j,kp)=0.95*hh1
	enddo
	enddo
C
C
C......WRITE OUT FIELDS FOR START UP..........
        IF(KTAU.NE.JJSTOP)GOTO 3132
C        KMTH=IMTH-1
C       IF(KTAU.NE.ITAU)GOTO 3132
C       IF(KMTH.NE.3.AND.KMTH.NE.6.AND.KMTH.NE.
C    1   9.AND.KMTH.NE.10.AND.KMTH.NE.11.AND.
C    2   KMTH.NE.12)GOTO 3132
C       REWIND 27
        ISTOP=KTAU-ITAU
        WRITE(27)MONTH1,IYEAR1,ISTOP,KTAU
        WRITE(27)((H1(I,J,K),I=1,IM),J=1,JM)
        WRITE(27)((H1(I,J,KP),I=1,IM),J=1,JM)
        WRITE(27)((U1(I,J,K),I=1,IM),J=1,JM)
        WRITE(27)((U1(I,J,KP),I=1,IM),J=1,JM)
        WRITE(27)((V1(I,J,K),I=1,IM),J=1,JM)
        WRITE(27)((V1(I,J,KP),I=1,IM),J=1,JM)
C       WRITE(27)(NOTAU(I),I=1,400)
C       WRITE(27)((DIFH(I,J),I=1,IM),J=1,JM)
 3132   CONTINUE
C
c
c##############################
c
c.......write h1 for plotting........
c
c##############################
c
	if(mod(ktau,16*30*ipltm).eq.0)then
c
c	  write(8)ihm
c	  write(8)((h1(i,j,k),i=1,im),j=1,jm)
c
	do j=1,jm
	  do i=1,im
	    hp(i,j)=h1(i,j,k)
	    up(i,j)=us1(i,j)
	    vp(i,j)=vs1(i,j)
	  enddo
	enddo
c
	  call resplt(ktau,hh1,hp,up,vp,ihm,ium,ivm)
c
	endif
c
	if(mod(ktau,2880).eq.0)then
              write(77)ktau
	      write(77)((h1(i,j,k),i=1,im),j=1,jm)
	endif
C
C
        TDT=2.0*DT
       KS=KM
       KM=K
       K=KP
       KP=KS
 987    FORMAT(1X,13E8.2)
  323 CONTINUE
C
C
       IF(KTAU.LT.JJSTOP) GO TO 500
 398       CONTINUE
C
c......close plot file.....
c
	call plotnd
c
C
 8889      FORMAT(1P,8E10.3)
 8890      FORMAT(I5)
 8892     FORMAT(4I5)
 8893     FORMAT(8I10)
C
      STOP
      END
      SUBROUTINE GPRINT(ARR,IMP,JMP,SC)
       REAL ARR(169,61)
      REAL DUM(168)
       IMPM=IMP-1
       JMPM=JMP-1
       DO 20 JJ=1,JMP
      J=JMP+1-JJ
      DO 10 I=1,IMP
   10 DUM(I)=ARR(I,J)/SC
C     WRITE(6,3252)J,(DUM(I),I=1,6),(DUM(I),I=10,60,5),(DUM(I),I=61,63)
      WRITE(6,3252)J,(DUM(I),I=1,46,2)
 20    CONTINUE
      WRITE(6,528)
 3252    FORMAT(1X,I2,23F5.2)
 528    FORMAT(//)
      RETURN
       END
        SUBROUTINE TRKVAR(A,ITM,IOBS,IUA,VAR)
C
        REAL A(169,61)
C
        INTEGER IUA(169,61),ITM(169,61),IOBS(169,61)
C
        IM=169
        JM=61
        VAR=0.0
        N=0
        SUMSQ=0.0
C
        DO 100 J=1,JM
        DO 100 I=1,IM
        SUMSQ=SUMSQ+A(I,J)*A(I,J)*IUA(I,J)*IOBS(I,J)*ITM(I,J)
 100    N=N+ITM(I,J)*IUA(I,J)*IOBS(I,J)
        IF(N.EQ.0)GOTO 110
        AN=N
        SUMSQ=SUMSQ/AN
 110    VAR=SQRT(SUMSQ)
        RETURN
        END
        SUBROUTINE REGVAR(A,I1,I2,J1,J2,IUA,IOBS,VAR)
C
        REAL A(169,61)
C
        INTEGER IUA(169,61),IOBS(169,61)
C
        VAR=0.0
        SUMSQ=0.0
        N=0
C
        DO 100 J=J1,J2
        DO 100 I=I1,I2
        SUMSQ=SUMSQ+A(I,J)*A(I,J)*IUA(I,J)*IOBS(I,J)
 100    N=N+IUA(I,J)*IOBS(I,J)
        IF(N.EQ.0)GOTO 110
        AN=N
        SUMSQ=SUMSQ/AN
 110    VAR=SQRT(SUMSQ)
        RETURN
        END
        SUBROUTINE CALRMS(A,I1,I2,J1,J2,IUA,IOBS,N,RMS)
C
        REAL A(169,61)
        INTEGER IUA(169,61),IOBS(169,61)
C
        RMS=0.0
        N=0
        DO 100 J=J1,J2
        DO 100 I=I1,I2
        RMS=RMS+A(I,J)*A(I,J)*IUA(I,J)*IOBS(I,J)
 100    N=N+IUA(I,J)*IOBS(I,J)
        IF(N.EQ.0)GOTO 110
        AN=N
        RMS=SQRT(RMS/AN)
 110     CONTINUE
        RETURN
        END
        SUBROUTINE RMSTRK(A,ITM,IOBS,IUA,N,RMS)
C
        REAL A(169,61)
C
        INTEGER IUA(169,61),ITM(169,61),IOBS(169,61)
C
        IM=169
        JM=61
        RMS=0.0
        N=0
        DO 100 J=1,JM
        DO 100 I=1,IM
        RMS=RMS+A(I,J)*A(I,J)*ITM(I,J)*IOBS(I,J)*IUA(I,J)
 100    N=N+ITM(I,J)*IOBS(I,J)*IUA(I,J)
        IF(N.EQ.0)GOTO 110
        AN=N
        RMS=SQRT(RMS/AN)
 110      CONTINUE
        RETURN
        END
       SUBROUTINE SETRAR(A,LEN,VALUE)
       REAL A(LEN)
       DO 320 I=1,LEN
  320  A(I)=VALUE
       RETURN
       END
        SUBROUTINE STRESS(WX,WY,IUM,IVM,IM,JM,IDATE)
C
        REAL WX(IM,JM),WY(IM,JM),DUM(169,61)
        INTEGER IUM(IM,JM),IVM(IM,JM)
C
C.....DUMMY ARRAY.....
C
        DO 100 J=1,JM
        DO 100 I=1,IM
 100     DUM(I,J)=0.0
         ITEST=IDATE
C
C
C.......SET UP CORRECT WIND DATA INPUT CHANNEL...
C
        IF(IDATE.EQ.820110)NIN=3
        GOTO 998
 999    NP=NIN
        IF(NP.EQ.3)NIN=90
        IF(NP.GT.80)NIN=NIN+1
        IF(NP.EQ.96)STOP 7777
 998    CONTINUE
         READ(NIN,310,END=999)IDATE,IDTYP,
     1  ((DUM(I,J),I=2+(J/60),168),J=60,2,-1)
            READ(NIN,300,END=999)IDATE,IDTYP,
     2                      ((DUM(I,J),I=2,168),J=60,2,-1)
            READ(NIN,300,END=999)IDATE,IDTYP,
     2                      ((WX(I,J),I=2,168),J=60,2,-1)
            READ(NIN,300,END=999)IDATE,IDTYP,
     2                      ((WY(I,J),I=2,168),J=60,2,-1)
 300    FORMAT(I6,I1,35X,13F6.1/(20F6.1))
 310      FORMAT(I6,I1,41X,12F6.1/(20F6.1))
        WRITE(6,800)IDATE
 800   FORMAT(1X,'WIND READ AT   ',I7)
C
C
C.......CONVERT PSEUDO WIND STRESS TO REAL WIND STRESS IN
C       NEWTONS PER SQUARE METRE USING THE DRAG EQUATION....
C
        RHO=1.25
        DO 766 J=1,JM
        DO 766 I=1,IM
        AMODV=(WX(I,J)*WX(I,J)+WY(I,J)*WY(I,J))**0.25
        CD=1.0E-3*(0.61+0.063*AMODV)
        IF(AMODV.LE.7.8)CD=1.1E-3
        WX(I,J)=CD*RHO*WX(I,J)*IUM(I,J)
 766    WY(I,J)=CD*RHO*WY(I,J)*IVM(I,J)
C
C.......CONVERT WIND UNITS TO DYNES PER SQUARE CENTIMETRE....
        DO 767 J=1,JM
        DO 767 I=1,IM
        WX(I,J)=WX(I,J)*10.0
 767    WY(I,J)=WY(I,J)*10.0
C
        RETURN
        END
C
        SUBROUTINE TOTWIND(WX,WY,IM,JM,MONTH,IYEAR,KTAU)
C
        REAL WX(IM,JM),WY(IM,JM),TAUX(84,30),TAUY(84,30),
     1  TIX(94,58),TIY(94,58),WXT(169,61),WYT(169,61)
C
C
C.......READ IN PACIFIC WIND AND CONVERT TO STRESS
C
        NIN=3
        IF(KTAU.GE.39664)NIN=10
        READ(NIN,7614)MONTH,IYEAR,TAUX,TAUY
        WRITE(6,757)MONTH,IYEAR
 7614   FORMAT(2I5,14F5.1/(16F5.1))
 757    FORMAT(1X,'WIND READ ON MONTH=',I3,' YEAR=19',I2)
        CALL WIND(TAUX,TAUY,WXT,WYT,169,61)
C
C.......READ IN INDIAN WIND AND CONVERT TO STRESS....
C
        READ(8,7614)INDM,INDY,TIX,TIY
        IF(INDM.NE.MONTH)PRINT *,'WIND MONTHS DONT MATCH'
        IF((INDY-1900).NE.IYEAR)PRINT *,'WIND YEARS DONT MATCH'
        IF(INDM.NE.MONTH)STOP 8888
        IF((INDY-1900).NE.IYEAR)STOP 9999
C
        DO 680 J=1,58
        DO 680 I=1,94
        IF(TIX(I,J).GT.980.0)TIX(I,J)=0.0
 680    IF(TIY(I,J).GT.980.0)TIY(I,J)=0.0
C
        RHO=1.25
        DO 681 J=1,58
        DO 681 I=1,93
        AMODV=(TIX(I,J)*TIX(I,J)+TIY(I,J)*TIY(I,J))**0.25
        CD=1.0E-3*(0.61+0.063*AMODV)
        IF(AMODV.LE.7.8)CD=1.1E-3
        WX(I,J)=CD*RHO*TIX(I,J)
 681    WY(I,J)=CD*RHO*TIY(I,J)
C
C........CONVERT INDIAN WINDS TO DYNES/CM2....
C
        DO 684 J=1,58
        DO 684 I=1,93
        WX(I,J)=WX(I,J)*10.0
  684   WY(I,J)=WY(I,J)*10.0
C
C........MAP PACIFIC WIND STRESS INTO WX AND WY.....
C
        DO 682 J=1,61
        DO 682 I=2,169
        WX(I+92,J+2)=WXT(I,J)
 682    WY(I+92,J+2)=WYT(I,J)
C
C.......LINEARLY INTERPOLATE BETWEEN INDIAN AND PACIFIC WINDS
C       ALONG I=93
C
        DO 683 J=1,JM
        WX(93,J)=0.5*(WX(92,J)+WX(94,J))
 683    WY(93,J)=0.5*(WY(92,J)+WY(94,J))
        RETURN
        END
C
        SUBROUTINE WIND(TAUX,TAUY,WX,WY,IM,JM)
C
        REAL TAUX(84,30),TAUY(84,30),WX(IM,JM),WY(IM,JM)
C
        IMAX=IM
        JMAX=JM
C.......SET TAUX AND TAUY TO ZERO OVER LAND....
        DO 758 J=1,30
        DO 758 I=1,84
        IF(TAUX(I,J).GT.998.0)TAUX(I,J)=0.0
  758   IF(TAUY(I,J).GT.998.0)TAUY(I,J)=0.0
C
C.......PUT PSEUDO WIND STRESS ONTO A 2 DEGREE GRID....
C
        DO 760 J=1,30
        DO 760 I=1,84
        WX(2*I,2*J)=TAUX(I,J)
 760    WY(2*I,2*J)=TAUY(I,J)
C.......SET WX AND WY TO ZERO AT BOUNDARIES...
        DO 761 J=1,JM
        WX(1,J)=0.0
        WX(IM,J)=0.0
        WY(1,J)=0.0
 761    WY(IM,J)=0.0
C
        DO 762 I=1,IM
        WX(I,1)=0.0
        WX(I,JM)=0.0
        WY(I,1)=0.0
  762   WY(I,JM)=0.0
C......LINEARLY INTERPOLATE PSEUDO WIND STRESS ONTO A I DEGREE GRID..
C
        JMAXM2=JMAX-2
        IMAXM2=IMAX-2
        JMAXM=JMAX-1
        IMAXM=IMAX-1
        DO 763 J=2,JMAXM,2
        DO 763 I=3,IMAXM2,2
        WX(I,J)=0.5*(WX(I+1,J)+WX(I-1,J))
 763    WY(I,J)=0.5*(WY(I+1,J)+WY(I-1,J))
C
        DO 764 J=3,JMAXM2,2
        DO 764 I=2,IMAXM,2
        WX(I,J)=0.5*(WX(I,J+1)+WX(I,J-1))
 764    WY(I,J)=0.5*(WY(I,J+1)+WY(I,J-1))
C
        DO 765 J=3,JMAXM2,2
        DO 765 I=3,IMAXM2,2
        WX(I,J)=0.25*(WX(I-1,J-1)+WX(I-1,J+1)+WX(I+1,J-1)+WX(I+1,J+1))
 765    WY(I,J)=0.25*(WY(I-1,J-1)+WY(I-1,J+1)+WY(I+1,J-1)+WY(I+1,J+1))
C
C.......CONVERT PSEUDO WIND STRESS TO REAL WIND STRESS IN
C       NEWTONS PER SQUARE METRE USING THE DRAG EQUATION....
C
        RHO=1.25
        DO 766 J=1,JM
        DO 766 I=1,IM
        AMODV=(WX(I,J)*WX(I,J)+WY(I,J)*WY(I,J))**0.25
        CD=1.0E-3*(0.61+0.063*AMODV)
        IF(AMODV.LE.7.8)CD=1.1E-3
        WX(I,J)=CD*RHO*WX(I,J)
 766    WY(I,J)=CD*RHO*WY(I,J)
C
C.......CONVERT WIND UNITS TO DYNES PER SQUARE CENTIMETRE....
        DO 767 J=1,JM
        DO 767 I=1,IM
        WX(I,J)=WX(I,J)*10.0
 767    WY(I,J)=WY(I,J)*10.0
C
        RETURN
        END
        SUBROUTINE ENERGY(H1,US1,VS1,HBAR,G12
     1                   ,POTE,AKINE,IHM,IUM,IVM,IM,JM)
C
        REAL H1(IM,JM),US1(IM,JM),VS1(IM,JM),POTEGY(63),AKEGY(63)
     1       ,POTE(7),AKINE(7),ALAT1(7),ALAT2(7),ALONG1(7)
     2      ,ALONG2(7)
        INTEGER IHM(IM,JM),IUM(IM,JM),IVM(IM,JM)
     1          ,IX1(7),IX2(7),JY1(7),JY2(7)
C
        DATA ALAT1/5.,5.,-5.,-5.,-17.,-17.,-24./
        DATA ALAT2/20.,20.,5.,5.,-5.,-5.,-17./
        DATA ALONG1/144.,176.,150.,235.,154.,202.,165./
        DATA ALONG2/160.,220.,205.,280.,198.,260.,275./
C........CALC. INDICES FOR TRAPEZOIDAL SUMMATIONS.....
C
        DO 800 LMN=1,7
        IX1(LMN)=ALONG1(LMN)-122.5
        IX2(LMN)=ALONG2(LMN)-122.5
        JY1(LMN)=ALAT1(LMN)+31.5
        JY2(LMN)=ALAT2(LMN)+31.5
 800    CONTINUE
C
        DO 111 II=1,7
C
        DO 101 J=1,JM
        POTEGY(J)=0.0
 101    AKEGY(J)=0.0
        I1=IX1(II)
        I2=IX2(II)
        J1=JY1(II)
        J2=JY2(II)
C
        I1P1=I1+1
        I2M1=I2-1
        J1P1=J1+1
        J2M1=J2-1
C........CALC. PE AND KE ALONG LINES OF CONSTANT LAT...
C
        DO 10 J=J1,J2
        SUMETA2=0.0
        SUMVEL2=0.0
        DO 11 I=I1P1,I2M1
        SUMETA2=SUMETA2+H1(I,J)*H1(I,J)*IHM(I,J)
        SUMVEL2=SUMVEL2+US1(I,J)*US1(I,J)*IUM(I,J)
     1         +VS1(I,J)*VS1(I,J)*IVM(I,J)
  11       CONTINUE
        POTEGY(J)=0.25*G12*(H1(I1,J)*H1(I1,J)*IHM(I1,J)
     1           +2.*SUMETA2+H1(I2,J)*H1(I2,J)*IHM(I2,J))
        AKEGY(J)=0.25*HBAR*(US1(I1,J)*US1(I1,J)*IUM(I1,J)
     1          +VS1(I1,J)*VS1(I1,J)*IVM(I1,J)+2.*SUMVEL2
     2          +US1(I2,J)*US1(I2,J)*IUM(I2,J)
     3          +VS1(I2,J)*VS1(I2,J)*IVM(I2,J))
 10     CONTINUE
C
C......CALC. PE AND KE OVER MODEL DOMAINS.....
C
        SUMPE=0.0
        SUMKE=0.0
        DO 12 J=J1P1,J2M1
        SUMPE=SUMPE+POTEGY(J)
        SUMKE=SUMKE+AKEGY(J)
 12     CONTINUE
        POTE(II)=0.5*(POTEGY(J1)+2.*SUMPE+POTEGY(J2))
        AKINE(II)=0.5*(AKEGY(J1)+2.*SUMKE+AKEGY(J2))
 111    CONTINUE
        RETURN
        END
C
        SUBROUTINE SPINUP(H1,US1,VS1,HBAR,G12
     1                   ,POTE,AKINE,IHM,IUM,IVM,IM,JM)
C
        REAL H1(IM,JM),US1(IM,JM),VS1(IM,JM),POTEGY(63),AKEGY(63)
     1       ,POTE(6),AKINE(6),ALAT1(6),ALAT2(6),ALONG1(6)
     2      ,ALONG2(6)
        INTEGER IHM(IM,JM),IUM(IM,JM),IVM(IM,JM)
     1          ,IX1(6),IX2(6),JY1(6),JY2(6)
C
        DATA ALAT1/1.,28.,38.,1.,28.,38./
        DATA ALAT2/27.,37.,63.,27.,37.,63./
        DATA ALONG1/1.,1.,1.,93.,93.,93./
        DATA ALONG2/94.,94.,94.,261.,261.,261./
C........CALC. INDICES FOR TRAPEZOIDAL SUMMATIONS.....
C
        DO 800 LMN=1,6
        IX1(LMN)=ALONG1(LMN)
        IX2(LMN)=ALONG2(LMN)
        JY1(LMN)=ALAT1(LMN)
        JY2(LMN)=ALAT2(LMN)
 800    CONTINUE
C
        DO 111 II=1,6
C
        DO 101 J=1,JM
        POTEGY(J)=0.0
 101    AKEGY(J)=0.0
        I1=IX1(II)
        I2=IX2(II)
        J1=JY1(II)
        J2=JY2(II)
C
        I1P1=I1+1
        I2M1=I2-1
        J1P1=J1+1
        J2M1=J2-1
C........CALC. PE AND KE ALONG LINES OF CONSTANT LAT...
C
        DO 10 J=J1,J2
        SUMETA2=0.0
        SUMVEL2=0.0
        DO 11 I=I1P1,I2M1
        SUMETA2=SUMETA2+H1(I,J)*H1(I,J)*IHM(I,J)
        SUMVEL2=SUMVEL2+US1(I,J)*US1(I,J)*IUM(I,J)
     1         +VS1(I,J)*VS1(I,J)*IVM(I,J)
  11       CONTINUE
        POTEGY(J)=0.25*G12*(H1(I1,J)*H1(I1,J)*IHM(I1,J)
     1           +2.*SUMETA2+H1(I2,J)*H1(I2,J)*IHM(I2,J))
        AKEGY(J)=0.25*HBAR*(US1(I1,J)*US1(I1,J)*IUM(I1,J)
     1          +VS1(I1,J)*VS1(I1,J)*IVM(I1,J)+2.*SUMVEL2
     2          +US1(I2,J)*US1(I2,J)*IUM(I2,J)
     3          +VS1(I2,J)*VS1(I2,J)*IVM(I2,J))
 10     CONTINUE
C
C......CALC. PE AND KE OVER MODEL DOMAINS.....
C
        SUMPE=0.0
        SUMKE=0.0
        DO 12 J=J1P1,J2M1
        SUMPE=SUMPE+POTEGY(J)
        SUMKE=SUMKE+AKEGY(J)
 12     CONTINUE
        POTE(II)=0.5*(POTEGY(J1)+2.*SUMPE+POTEGY(J2))
        AKINE(II)=0.5*(AKEGY(J1)+2.*SUMKE+AKEGY(J2))
 111    CONTINUE
        RETURN
        END
c
	subroutine resplt(ktau,hh1,h,u,v,ihm,ium,ivm)
c
         parameter(im=51,jm=51,imm=im-2,jmm=jm-2)
c
	 parameter(nval=15)
c
	real h(im,jm),hp(imm,jmm)
c
	real u(im,jm),up(im,jm)
c
	real v(im,jm),vp(im,jm)
c
	real spv(2),cfill(3),grylev(3),cval(nval),cval1(1)
c
	real conp(nval)
	real conm(nval)
c
	real xlrr(4),ylrr(4)
c
	integer ihm(im,jm)
c
	integer ium(im,jm)
c
	integer ivm(im,jm)
c
	real sver1(im,jm),wcurl(im,jm)
c
	real sum1(im,jm),sumc(im,jm)
c
	common/vars/beta,dxm,dym,fh(jm),fv(jm),wx(im,jm),wy(im,jm)
c
	character carrow*10,char1*3,char2*7,char4*7,char3*17
c
      COMMON/CONPAR/ISPEC,IOFFPP,SPVALL,ILEGG,ILABB,NHII,NDECCN,NLBLL,
     .              LSCAL,LDASH,HGTLAB
c
      DATA ISPEC,IOFFPP,SPVALL,ILEGG,ILABB,NHII,NDECCN,NLBLL,
     .   LSCAL,LDASH,HGTLAB
     1  /   1 ,     1,  -99999., 1,    1,   -1,    1,     2, 1, 0, 0/
c
	ch1=0.25
	ch2=0.2
c
c.......compute the sverdrup transport and wind stress curl....
c
	do j=1,jm-1
	 do i=1,im-1
	    hfl1=hh1-0.25*(h(i,j)+h(i+1,j)+h(i,j+1)+h(i+1,j+1))
	    vfl1=0.5*(v(i,j)+v(i+1,j))
	    wcurl(i,j)=(wy(i+1,j)-wy(i,j))/dxm-(wx(i,j+1)-wx(i,j))/dym
	    sver1(i,j)=beta*hfl1*vfl1
	 enddo
	enddo
c
c.......zonally integrate the Sverdrup transport and wind stress curl....
c
	do j=1,jm-1
	   do i=im,1,-1
	      sum1(i,j)=0.0
	      sumc(i,j)=0.0
	      do ii=im,i+1,-1
	         sum1(i,j)=sum1(i,j)+sver1(ii,j)*dxm
	         sumc(i,j)=sumc(i,j)+wcurl(ii,j)*dxm
	      enddo
	   enddo
	enddo
c
	do j=1,jm
	  do i=1,im
	    sver1(i,j)=-1.*sum1(i,j)
	    wcurl(i,j)=-1.*sumc(i,j)
	  enddo
	enddo
c
c
	char1='t= '
	char4=' months'
	ptime=float(ktau)/(16.*30.)
	write(char2,'(f7.1)')ptime
	char3=char1//char2//char4
c
	cval1(1)=0.5
c
	do i=1,nval
	   cval(i)=float(i-1)*0.2
	enddo
c
        xlen=5.
        ylen=float(jm)*xlen/float(im)
c
	call factor(3./5.)
c
        call plot(1.,9.,-3)
c
	chh1=hh1/100.
c
c......convert h to m......
c
	do j=1,jm
	  do i=1,im
	    h(i,j)=h(i,j)/100.
	  enddo
	enddo
c
c########set NW corner to zero for plotting######
c
	do j=jm-8,jm
	   do i=2,7
	    h(i,j)=0.0
	   enddo
	enddo
c
c......find the largest value of h and compute the
c      contour interval
c
	bigh=-1.e20
	do j=1,jm
	  do i=1,im
	   if(abs(h(i,j)).gt.bigh)bigh=abs(h(i,j))
	  enddo
	enddo
c
c########set NW corner to zero for plotting######
c
	do j=jm-8,jm
	   do i=2,7
	    h(i,j)=spvall
	   enddo
	enddo
c
c
	print *,'bigh=',bigh
c
	bigh=bigh
c
c	dc=abs(chh1-bigh)/float(nval)
	dc=bigh/float(nval)
	do i=1,nval
c	  conp(i)=float(i)*dc+chh1
c	  conm(i)=-1.*abs(chh1-bigh)+float(i-1)*dc+chh1
	  conp(i)=float(i)*dc
	  conm(i)=-1.*bigh+float(i-1)*dc
	enddo
c
c
	do j=1,jm
	 do i=1,im
	  if(ihm(i,j).eq.0)h(i,j)=spvall
	 enddo
	enddo
c
	do j=2,jm-1
	   jj=j-1
	   do i=2,im-1
           ii=i-1
	   hp(ii,jj)=h(i,j)
	   enddo
	enddo
c
        cfill(1)=-1.e20
        cfill(2)=conp(1)
        cfill(3)=1.e20
        grylev(1)=1.0
        grylev(2)=1.0
        grylev(3)=0.75
c
c        call confill(hp,imm,imm,jmm,xlen,ylen,
c     &    cfill,grylev,3,ioffpp,spvall)
c
        call confill(h,im,im,jm,xlen,ylen,
     &    cfill,grylev,3,ioffpp,spvall)
c
c
c        call conrec(hp,imm,imm,jmm,xlen,ylen,conp,nval)
c        call conrec(hp,imm,imm,jmm,xlen,ylen,conm,nval)
c
        call conrec(h,im,im,jm,xlen,ylen,conp,nval)
        call conrec(h,im,im,jm,xlen,ylen,conm,nval)
c
        call border(xlen,ylen,-1111,1111,1,1,2,1)
c
	call keksym(0.5*xlen,1.05*ylen,ch1,1Hh,0.,1,1)
c
	call keksymc(xlen+0.5,1.2*ylen,1.2*ch1,char3,0.,17,1)
c
c
	call coast(xlen,ylen)
c
	call plot(0.,-1.*(ylen+1.5),-3)
c
	do j=1,jm
	 do i=1,im
	   up(i,j)=0.0
	   vp(i,j)=0.0
	 enddo
	enddo
c
	do j=2,jm-1
	   do i=2,im-1
	   up(i,j)=0.5*(u(i,j)+u(i-1,j))
	   vp(i,j)=0.5*(v(i,j)+v(i-1,j))
	   enddo
	enddo
c
        call border(xlen,ylen,-1111,1111,1,1,1,1)
c
c########set NW corner to zero for plotting######
c
	do j=jm-8,jm
	   do i=2,7
	    up(i,j)=0.0
	    vp(i,j)=0.0
	   enddo
	enddo
c
	bigwn=-1.e20
	do j=1,jm
	  do i=1,im
	   spd=sqrt(up(i,j)*up(i,j)+vp(i,j)*vp(i,j))
	   if(spd.gt.bigwn)bigwn=spd
	  enddo
	enddo
c
        dx=xlen/float(im-1)
        dy=ylen/float(jm-1)
        scale=0.3
        do j=2,jm-1
        y=float(j-1)*dy
        do i=2,im-1
        x=float(i-1)*dx
        spd=sqrt(up(i,j)*up(i,j)+vp(i,j)*vp(i,j))
        alen=scale*spd
	x1=x
	y1=y
	if(bigwn.gt.0.0)then
        x1=x+up(i,j)*scale/bigwn
        y1=y+vp(i,j)*scale/bigwn
	endif
c
c	if(spd.gt.0.)then
c           x1=x+up(i,j)*scale
c           y1=y+vp(i,j)*scale
c	endif
c
c        if(spd.ge.0.3*bigwn)call arrow(x,y,x1,y1,0.08,20.,0)
c        if(spd.ge.1.e-6)call arrow(x,y,x1,y1,0.08,20.,0)
c        if(spd.ge.0.1*bigwn)then
        if(spd.gt.1.e-3)then
        ang=atan2((y1-y),(x1-x))
	pi=4.*atan(1.0)
        ang=0.5*pi-ang
        ang=360.*ang/(2.*pi)
        call sldlin(x,y,x1,y1,0.01)
        call farohed(x1,y1,ang,0.08,20.,0,.true.)
        endif
        enddo
        enddo
c
        call sldlin(0.,-0.3,scale,-0.3,0.01)
        call farohed(scale,-0.3,90.,0.08,20.,0,.true.)
c
	write(carrow,'(1p,1e10.3)')bigwn
c
	call keksymc(scale+0.1,-0.3,ch2,carrow,0.,10,0)
c
	call keksym(0.5*xlen,1.05*ylen,ch1,1HV,0.,1,1)
c
	call coast(xlen,ylen)
c
	lscal=0
c
        call plot(xlen+1.,ylen+1.5,-3)
c
c########set NW corner to zero for plotting######
c
	do j=jm-8,jm
	   do i=2,7
	    sver1(i,j)=0.0
	   enddo
	enddo
c
c......find the largest value of sver1 and sver2, etc and compute the
c      contour interval
c
	bigs1=-1.e20
	bigwc=-1.e20
	do j=1,jm
	  do i=1,im
	   if(abs(sver1(i,j)).gt.bigs1)bigs1=abs(sver1(i,j))
	   if(abs(wcurl(i,j)).gt.bigwc)bigwc=abs(wcurl(i,j))
	  enddo
	enddo
c
c########set NW corner to zero for plotting######
c
	do j=jm-8,jm
	   do i=2,7
	    sver1(i,j)=spvall
	   enddo
	enddo
c
	do j=3,jm-2
	do i=3,im-2
	   isum=(ihm(i,j)+ihm(i+1,j)+ihm(i,j+1)+ihm(i+1,j+1))/4
	   if(isum.ne.1)sver1(i,j)=spvall
	enddo
	enddo
c
c
	print *,'bigs1=',bigs1
	print *,'bigwc=',bigwc
c
	bigh=bigs1
	dc=bigh/float(nval)
	do i=1,nval
	  conp(i)=float(i)*dc
	  conm(i)=-1.*bigh+float(i-1)*dc
	enddo
c
        cfill(1)=-1.e20
        cfill(2)=conp(1)
        cfill(3)=1.e20
        grylev(1)=1.0
        grylev(2)=1.0
        grylev(3)=0.75
c
        call confill(sver1,im,im,jm,xlen,ylen,
     &    cfill,grylev,3,ioffpp,spvall)
c
        call conrec(sver1,im,im,jm,xlen,ylen,conp,nval)
        call conrec(sver1,im,im,jm,xlen,ylen,conm,nval)
c
        call border(xlen,ylen,-1111,1111,1,1,2,1)
c
	call keksym(0.5*xlen,1.05*ylen+0.3,0.7*ch1,
     &         28HZonally Integrated Northward,0.,28,1)
	call keksym(0.5*xlen,1.05*ylen,0.7*ch1,
     &       30HTransport from East in Layer 1,0.,30,1)
c
	call coast(xlen,ylen)
c
	goto 1789
c
	call plot(0.,-1.*(ylen+1.5),-3)
c
c	bigh=bigwc
c	dc=bigh/float(nval)
c	do i=1,nval
c	  conp(i)=float(i)*dc
c	  conm(i)=-1.*bigh+float(i-1)*dc
c	enddo
c
        call confill(wcurl,im,im,jm,xlen,ylen,
     &    cfill,grylev,3,ioffpp,spvall)
c
        call conrec(wcurl,im,im,jm,xlen,ylen,conp,nval)
        call conrec(wcurl,im,im,jm,xlen,ylen,conm,nval)
c
        call border(xlen,ylen,-1111,1111,1,1,2,1)
c
	call keksym(0.5*xlen,1.05*ylen+0.3,0.7*ch1,
     &         18HZonally Integrated,0.,18,1)
	call keksym(0.5*xlen,1.05*ylen,0.7*ch1,
     &       16HWind Stress Curl,0.,16,1)
c
	call coast(xlen,ylen)
c
 1789   continue
c
	call chopit(0.,0.)
c
	lscal=1
c
c
	return
        end
c
	subroutine coast(xlen,ylen)
c
        PARAMETER(IM=51)
        PARAMETER(JM=51)
c
	real xlrr(4),ylrr(4)
c
c       west coast
c
         dlx=xlen/(float(im-1))
         dly=ylen/float(jm-1)
	 xlrr(1)=0.0
	 ylrr(1)=0.0
	 xlrr(2)=0.5*dlx
	 ylrr(2)=ylrr(1)
	 xlrr(3)=xlrr(2)
	 ylrr(3)=ylen
	 xlrr(4)=0.
	 ylrr(4)=ylrr(3)
         call filrgn(xlrr,ylrr,4,0.)
c
c       east coast
c
	 xlrr(1)=xlen-0.5*dlx
	 ylrr(1)=0.0
	 xlrr(2)=xlen
	 ylrr(2)=ylrr(1)
	 xlrr(3)=xlrr(2)
	 ylrr(3)=ylen
	 xlrr(4)=xlen-0.5*dlx
	 ylrr(4)=ylrr(3)
         call filrgn(xlrr,ylrr,4,0.)
c
	 xlrr(1)=0.0
	 ylrr(1)=0.0
	 xlrr(2)=xlen
	 ylrr(2)=ylrr(1)
	 xlrr(3)=xlrr(2)
	 ylrr(3)=0.5*dly
	 xlrr(4)=0.
	 ylrr(4)=ylrr(3)
         call filrgn(xlrr,ylrr,4,0.)
c
	 xlrr(1)=0.0
	 ylrr(1)=ylen-0.5*dly
	 xlrr(2)=xlen
	 ylrr(2)=ylrr(1)
	 xlrr(3)=xlrr(2)
	 ylrr(3)=ylen
	 xlrr(4)=0.
	 ylrr(4)=ylrr(3)
         call filrgn(xlrr,ylrr,4,0.)
c
	return
	end


submodule (neutral) perturb

use, intrinsic :: ieee_arithmetic, only: ieee_is_finite

use grid, only : gridflag
use reader, only : get_neutral2, get_neutral3
use timeutils, only : dateinc, date_filename

use mpimod, only: mpi_realprec, mpi_integer, mpi_comm_world, mpi_status_ignore, &
tag=>gemini_mpi

implicit none (type, external)

external :: mpi_send, mpi_recv

interface ! proj.f90
module subroutine gridproj_dneu2D(cfg,flagcart,x)
type(gemini_cfg), intent(in) :: cfg
logical, intent(in) :: flagcart
type(curvmesh), intent(inout) :: x
end subroutine gridproj_dneu2D

module subroutine gridproj_dneu3D(cfg,x)
type(gemini_cfg), intent(in) :: cfg
type(curvmesh), intent(inout) :: x
end subroutine gridproj_dneu3D
end interface

interface ! interp.f90

module subroutine spaceinterp_dneu2D(flagcart)
logical, intent(in) :: flagcart
end subroutine spaceinterp_dneu2D

module subroutine spaceinterp_dneu3D()
end subroutine spaceinterp_dneu3D

module subroutine timeinterp_dneu(t,dt,dNOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow,dTninow)
real(wp), intent(in) :: t,dt
real(wp), dimension(:,:,:), intent(out) :: dNOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow,dTninow
end subroutine timeinterp_dneu

end interface

contains

module procedure neutral_perturb
! subroutine neutral_perturb(cfg,dt,dtneu,t,ymd,UTsec,x,v2grid,v3grid,nn,Tn,vn1,vn2,vn3)

if (cfg%interptype==0) then                           !cartesian interpolation drho inputs (radial distance) will be interpreted as dy (horizontal distance)
!  call neutral_perturb_cart(dt,dtneu,t,ymd,UTsec,neudir,drhon,dzn,meanlat,meanlong,x,nn,Tn,vn1,vn2,vn3)
  call neutral_perturb_cart(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)
else if (cfg%interptype==1) then                      !axisymmetric interpolation
  call neutral_perturb_axisymm(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)
else if (cfg%interptype==3) then                      !3D interpolation drhon is takent to be dyn (northward distance)
  call neutral_perturb_3D(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)
else
  error stop '...Invalid interpolation type specified from input file...'
end if

!> adjust for the grid drift speed; note we assume this gets sets to zero if not a Lagrangian grid
vn2=vn2-v2grid
vn3=vn3-v3grid

end procedure neutral_perturb

!FOR CONSISTENCY I'D LIKE TO STRUCTURE NEUTRAL PERTURB OPERATIONS LIKE GRAVITY IS HANDLED IN THE GRID MODULE, I.E. HAVE AN EXPLICIT CONSTRUCTORS/DESTRUCTOR TYPE ROUTINE THAT HANDLES ALLOCATION AND DEALLOCATION, WHICH WILL CLEAN UP THE NEUTRAL_PERTURB SUBROUTINE, I.E. REMOVE ALLOCATES OF PERSISTENT MODULE VARIABLES.
subroutine neutral_perturb_axisymm(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)

!------------------------------------------------------------
!-------COMPUTE NEUTRAL PERTURBATIONS FOR THIS TIME STEP.  ADD
!-------THEM TO MSIS PERTURBATIONS TO GET ABSOLUTE VALUES FOR
!-------EACH PARAMETER
!-------
!-------THIS VERSION ASSUMES THE INPUT NEUTRAL DATA ARE IN
!-------CYLINDRICAL COORDINATES.
!------------------------------------------------------------

real(wp), intent(in) :: dt,dtneu
real(wp), intent(in) :: t
integer, dimension(3), intent(in) :: ymd    !date for which we wish to calculate perturbations
real(wp), intent(in) :: UTsec
type(gemini_cfg), intent(in) :: cfg

type(curvmesh), intent(inout) :: x         !grid structure  (inout becuase we want to be able to deallocate unit vectors once we are done with them)
real(wp), dimension(:,:,:,:), intent(out) :: nn   !neutral params interpolated to plasma grid at requested time
real(wp), dimension(:,:,:), intent(out) :: Tn,vn1,vn2,vn3

integer :: ix1,ix2,ix3,iid!,irhon,izn
integer, dimension(3) :: ymdtmp
real(wp) :: UTsectmp

!CHECK WHETHER WE NEED TO LOAD A NEW FILE
if (t+dt/2 >= tnext .or. t < 0) then   !negative time means that we need to load the first frame

  !IF FIRST LOAD ATTEMPT CREATE A NEUTRAL GRID AND COMPUTE GRID SITES FOR IONOSPHERIC GRID.  Since this needs an input file, I'm leaving it under this condition here
  if (.not. allocated(zn)) then     !means this is the first tiem we've tried to load neutral simulation data, should we check for a previous neutral file to load??? or just assume everything starts at zero?  This needs to somehow check for an existing file under certain conditiosn, maybe if it==1???  Actually we don't even need that we can just check that the neutral grid is allocated (or not)
    !initialize dates
    ymdprev=ymd
    UTsecprev=UTsec
    ymdnext=ymdprev
    UTsecnext=UTsecprev

    !Create a neutral grid, do some allocations and projections
    call gridproj_dneu2D(cfg,.false.,x)    !set false to denote not Cartesian; here and below...
  end if

  !Read in neutral data from a file
  call read_dneu2D(tprev,tnext,t,dtneu,dt,cfg%sourcedir,ymdtmp,UTsectmp,.false.)

  !Spatial interpolatin for the frame we just read in
  if (mpi_cfg%myid==0 .and. debug) then
    print *, 'Spatial interpolation and rotation of vectors for date:  ',ymdtmp,' ',UTsectmp
  end if
  call spaceinterp_dneu2D(.false.)

  !UPDATE OUR CONCEPT OF PREVIOUS AND NEXT TIMES
  tprev=tnext
  UTsecprev=UTsecnext
  ymdprev=ymdnext

  tnext=tprev+dtneu
  UTsecnext=UTsectmp
  ymdnext=ymdtmp

end if !done loading frame data...

!Interpolation in time
call timeinterp_dneu(t,dt,dnOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow,dTninow)

!Add interpolated perturbations to reference atmosphere arrays
call neutral_update(nn,Tn,vn1,vn2,vn3)

end subroutine neutral_perturb_axisymm

!! THIS SHARES SO MUCH CODE WITH THE AXISYMMETRIC VERSION THAT THEY SHOULD PROBABLY BE COMBINED
subroutine neutral_perturb_cart(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)

!------------------------------------------------------------
!-------COMPUTE NEUTRAL PERTURBATIONS FOR THIS TIME STEP.  ADD
!-------THEM TO MSIS PERTURBATIONS TO GET ABSOLUTE VALUES FOR
!-------EACH PARAMETER.
!-------
!-------THIS VERSION ASSUMES THE INPUT NEUTRAL DATA ARE IN
!-------CARTESIAN COORDINATES.
!------------------------------------------------------------

real(wp), intent(in) :: dt,dtneu
real(wp), intent(in) :: t
integer, dimension(3), intent(in) :: ymd    !date for which we wish to calculate perturbations
real(wp), intent(in) :: UTsec
type(gemini_cfg), intent(in) :: cfg

type(curvmesh), intent(inout) :: x         !grid structure  (inout becuase we want to be able to deallocate unit vectors once we are done with them)
real(wp), dimension(:,:,:,:), intent(out) :: nn   !neutral params interpolated to plasma grid at requested time
real(wp), dimension(:,:,:), intent(out) :: Tn,vn1,vn2,vn3

integer :: ix1,ix2,ix3,iid
integer, dimension(3) :: ymdtmp
real(wp) :: UTsectmp

!CHECK WHETHER WE NEED TO LOAD A NEW FILE
if (t+dt/2d0 >= tnext .or. t < 0) then
  !IF FIRST LOAD ATTEMPT CREATE A NEUTRAL GRID AND COMPUTE GRID SITES FOR IONOSPHERIC GRID.  Since this needs an input file, I'm leaving it under this condition here
  if (.not. allocated(zn)) then     !means this is the first tiem we've tried to load neutral simulation data, should we check for a previous neutral file to load???
    !initialize dates
    ymdprev=ymd
    UTsecprev=UTsec
    ymdnext=ymdprev
    UTsecnext=UTsecprev

    !Create a neutral grid, do some allocations and projections
    call gridproj_dneu2D(cfg,.true.,x)    !set true to denote Cartesian...
  end if

  !Read in neutral data from a file
  call read_dneu2D(tprev,tnext,t,dtneu,dt,cfg%sourcedir,ymdtmp,UTsectmp,.true.)

  !Spatial interpolatin for the frame we just read in
  if (mpi_cfg%myid==0 .and. debug) then
    print *, 'Spatial interpolation and rotation of vectors for date:  ',ymdtmp,' ',UTsectmp
  end if
  call spaceinterp_dneu2D(.true.)

  !UPDATE OUR CONCEPT OF PREVIOUS AND NEXT TIMES
  tprev=tnext
  UTsecprev=UTsecnext
  ymdprev=ymdnext

  tnext=tprev+dtneu
  UTsecnext=UTsectmp
  ymdnext=ymdtmp

end if

!Interpolation in time
call timeinterp_dneu(t,dt,dNOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow,dTninow)

!> update neutral atmosphere
call neutral_update(nn,Tn,vn1,vn2,vn3)

end subroutine neutral_perturb_cart

subroutine neutral_perturb_3D(dt,dtneu,t,ymd,UTsec,cfg,x,nn,Tn,vn1,vn2,vn3)

!------------------------------------------------------------
!-------COMPUTE NEUTRAL PERTURBATIONS FOR THIS TIME STEP.  ADD
!-------THEM TO MSIS PERTURBATIONS TO GET ABSOLUTE VALUES FOR
!-------EACH PARAMETER.
!-------
!-------THIS VERSION ASSUMES THE INPUT NEUTRAL DATA ARE IN
!-------CARTESIAN COORDINATES AND IN THREE DIMENSIONS.
!------------------------------------------------------------

real(wp), intent(in) :: dt,dtneu
real(wp), intent(in) :: t
integer, dimension(3), intent(in) :: ymd    !date for which we wish to calculate perturbations
real(wp), intent(in) :: UTsec
type(gemini_cfg), intent(in) :: cfg

type(curvmesh), intent(inout) :: x         !grid structure  (inout becuase we want to be able to deallocate unit vectors once we are done with them)
real(wp), dimension(:,:,:,:), intent(out) :: nn   !neutral params interpolated to plasma grid at requested time
real(wp), dimension(:,:,:), intent(out) :: Tn,vn1,vn2,vn3

integer :: ix1,ix2,ix3,iid
integer, dimension(3) :: ymdtmp
real(wp) :: UTsectmp

real(wp) :: starttime,endtime

!CHECK WHETHER WE NEED TO LOAD A NEW FILE
if (t + dt/2 >= tnext .or. t < 0) then
  !IF FIRST LOAD ATTEMPT CREATE A NEUTRAL GRID AND COMPUTE GRID SITES FOR IONOSPHERIC GRID.  Since this needs an input file, I'm leaving it under this condition here
  if (.not. allocated(zn)) then     !means this is the first tiem we've tried to load neutral simulation data, should we check for a previous neutral file to load???
    !initialize dates
    ymdprev=ymd
    UTsecprev=UTsec
    ymdnext=ymdprev
    UTsecnext=UTsecprev

    !Create a neutral grid, do some allocations and projections
    if (mpi_cfg%myid==0 .and. debug) then
      print*, 'Creating a neutral grid...'
    end if
    call gridproj_dneu3D(cfg,x)
  end if

  !Read in neutral data from a file
  if (mpi_cfg%myid==0 .and. debug) then
    print*, 'Reading in data from neutral file'
    call cpu_time(starttime)
  end if
  call read_dneu3D(tprev,tnext,t,dtneu,dt,cfg%sourcedir,ymdtmp,UTsectmp)
  if (mpi_cfg%myid==0 .and. debug) then
    call cpu_time(endtime)
    print*, 'Neutral data input required time:  ',endtime-starttime
  end if

  !Spatial interpolation for the frame we just read in
  if (mpi_cfg%myid==0 .and. debug) then
    print *, 'Spatial interpolation and rotation of vectors for date:  ',ymdtmp,' ',UTsectmp
    call cpu_time(starttime)
  end if
  call spaceinterp_dneu3D()
  if (mpi_cfg%myid==0 .and. debug) then
    call cpu_time(endtime)
    print*, 'Spatial interpolation in 3D took time:  ',endtime-starttime
  end if

  !UPDATE OUR CONCEPT OF PREVIOUS AND NEXT TIMES
  tprev=tnext
  UTsecprev=UTsecnext
  ymdprev=ymdnext

  tnext=tprev+dtneu
  UTsecnext=UTsectmp
  ymdnext=ymdtmp

end if

!Interpolation in time
if (mpi_cfg%myid==0 .and. debug) then
  print*, 'Interpolating in time'
end if
call timeinterp_dneu(t,dt,dNOinow,dnN2inow,dnO2inow,dvn1inow,dvn2inow,dvn3inow,dTninow)

!> update neutral atmosphere
call neutral_update(nn,Tn,vn1,vn2,vn3)

end subroutine neutral_perturb_3D

subroutine read_dneu2D(tprev,tnext,t,dtneu,dt,neudir,ymdtmp,UTsectmp,flagcart)

! This subroutine reads in neutral frame data, if necessary and puts the results
! in a module-scope variable for later use
! This version is for 2D source neutral data

real(wp), intent(in) :: tprev,tnext,t,dtneu,dt        !times of previous input frame,next frame and then current time
character(*), intent(in) :: neudir                    !directory where neutral simulation data is kept
integer, dimension(3), intent(out) :: ymdtmp          !storage space for incrementing date without overwriting ymdnext...
real(wp), intent(out) :: UTsectmp
logical, intent(in) :: flagcart

integer :: iid,ierr
integer :: lhorzn
!! number of horizontal grid points

if (flagcart) then
  lhorzn=lyn
else
  lhorzn=lrhon
end if

if (mpi_cfg%myid==0) then    !root
  !read in the data from file
  ymdtmp=ymdnext
  UTsectmp=UTsecnext
  call dateinc(dtneu,ymdtmp,UTsectmp)    !get the date for "next" params

  call get_neutral2(date_filename(neudir,ymdtmp,UTsectmp), &
    dnO,dnN2,dnO2,dvnrho,dvnz,dTn)

  if (debug) then
    print *, 'Min/max values for dnO:  ',minval(dnO),maxval(dnO)
    print *, 'Min/max values for dnN:  ',minval(dnN2),maxval(dnN2)
    print *, 'Min/max values for dnO:  ',minval(dnO2),maxval(dnO2)
    print *, 'Min/max values for dvnrho:  ',minval(dvnrho),maxval(dvnrho)
    print *, 'Min/max values for dvnz:  ',minval(dvnz),maxval(dvnz)
    print *, 'Min/max values for dTn:  ',minval(dTn),maxval(dTn)
  endif

  if (.not. all(ieee_is_finite(dnO))) error stop 'dnO: non-finite value(s)'
  if (.not. all(ieee_is_finite(dnN2))) error stop 'dnN2: non-finite value(s)'
  if (.not. all(ieee_is_finite(dnO2))) error stop 'dnO2: non-finite value(s)'
  if (.not. all(ieee_is_finite(dvnrho))) error stop 'dvnrho: non-finite value(s)'
  if (.not. all(ieee_is_finite(dvnz))) error stop 'dvnz: non-finite value(s)'
  if (.not. all(ieee_is_finite(dTn))) error stop 'dTn: non-finite value(s)'

  !send a full copy of the data to all of the workers
  do iid=1,mpi_cfg%lid-1
    call mpi_send(dnO,lhorzn*lzn,mpi_realprec,iid,tag%dnO,MPI_COMM_WORLD,ierr)
    call mpi_send(dnN2,lhorzn*lzn,mpi_realprec,iid,tag%dnN2,MPI_COMM_WORLD,ierr)
    call mpi_send(dnO2,lhorzn*lzn,mpi_realprec,iid,tag%dnO2,MPI_COMM_WORLD,ierr)
    call mpi_send(dTn,lhorzn*lzn,mpi_realprec,iid,tag%dTn,MPI_COMM_WORLD,ierr)
    call mpi_send(dvnrho,lhorzn*lzn,mpi_realprec,iid,tag%dvnrho,MPI_COMM_WORLD,ierr)
    call mpi_send(dvnz,lhorzn*lzn,mpi_realprec,iid,tag%dvnz,MPI_COMM_WORLD,ierr)
  end do
else     !workers
  !receive a full copy of the data from root
  call mpi_recv(dnO,lhorzn*lzn,mpi_realprec,0,tag%dnO,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dnN2,lhorzn*lzn,mpi_realprec,0,tag%dnN2,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dnO2,lhorzn*lzn,mpi_realprec,0,tag%dnO2,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dTn,lhorzn*lzn,mpi_realprec,0,tag%dTn,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dvnrho,lhorzn*lzn,mpi_realprec,0,tag%dvnrho,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dvnz,lhorzn*lzn,mpi_realprec,0,tag%dvnz,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
end if

!DO SPATIAL INTERPOLATION OF EACH PARAMETER (COULD CONSERVE SOME MEMORY BY NOT STORING DVNRHOIPREV AND DVNRHOINEXT, ETC.)
if (mpi_cfg%myid==mpi_cfg%lid/2 .and. debug) then
  print*, 'neutral data size:  ',lhorzn,lzn, mpi_cfg%lid
  print *, 'Min/max values for dnO:  ',minval(dnO),maxval(dnO)
  print *, 'Min/max values for dnN:  ',minval(dnN2),maxval(dnN2)
  print *, 'Min/max values for dnO:  ',minval(dnO2),maxval(dnO2)
  print *, 'Min/max values for dvnrho:  ',minval(dvnrho),maxval(dvnrho)
  print *, 'Min/max values for dvnz:  ',minval(dvnz),maxval(dvnz)
  print *, 'Min/max values for dTn:  ',minval(dTn),maxval(dTn)
  print*, 'coordinate ranges:  ',minval(zn),maxval(zn),minval(rhon),maxval(rhon),minval(zi),maxval(zi),minval(rhoi),maxval(rhoi)
end if

end subroutine read_dneu2D

subroutine read_dneu3D(tprev,tnext,t,dtneu,dt,neudir,ymdtmp,UTsectmp)

! This subroutine reads in neutral frame data, if necessary and puts the results
! in a module-scope variable for later use
! this version is for 3D neutral source data

real(wp), intent(in) :: tprev,tnext,t,dtneu,dt        !times of previous input frame,next frame and then current time
character(*), intent(in) :: neudir                    !directory where neutral simulation data is kept
integer, dimension(3), intent(out) :: ymdtmp          !storage space for incrementing date without overwriting ymdnext...
real(wp), intent(out) :: UTsectmp

integer :: iid,ierr
integer :: lhorzn                        !number of horizontal grid points
real(wp), dimension(:,:,:), allocatable :: parmtmp    !temporary resizable space for subgrid neutral data

lhorzn=lyn

if (mpi_cfg%myid==0) then    !root
  !read in the data from file
  ymdtmp=ymdnext
  UTsectmp=UTsecnext
  call dateinc(dtneu,ymdtmp,UTsectmp)                !get the date for "next" params

  !FIXME: we probably need to read in and distrubute the input parameters one at a time to reduce memory footprint...
  call get_neutral3(date_filename(neudir,ymdtmp,UTsectmp), &
    dnOall,dnN2all,dnO2all,dvnxall,dvnrhoall,dvnzall,dTnall)

  if (debug) then
    print *, 'Min/max values for dnOall:  ',minval(dnOall),maxval(dnOall)
    print *, 'Min/max values for dnNall:  ',minval(dnN2all),maxval(dnN2all)
    print *, 'Min/max values for dnO2all:  ',minval(dnO2all),maxval(dnO2all)
    print *, 'Min/max values for dvnxall:  ',minval(dvnxall),maxval(dvnxall)
    print *, 'Min/max values for dvnrhoall:  ',minval(dvnrhoall),maxval(dvnrhoall)
    print *, 'Min/max values for dvnzall:  ',minval(dvnzall),maxval(dvnzall)
    print *, 'Min/max values for dTnall:  ',minval(dTnall),maxval(dTnall)
  endif

  if (.not. all(ieee_is_finite(dnOall))) error stop 'dnOall: non-finite value(s)'
  if (.not. all(ieee_is_finite(dnN2all))) error stop 'dnN2all: non-finite value(s)'
  if (.not. all(ieee_is_finite(dnO2all))) error stop 'dnO2all: non-finite value(s)'
  if (.not. all(ieee_is_finite(dvnxall))) error stop 'dvnxall: non-finite value(s)'
  if (.not. all(ieee_is_finite(dvnrhoall))) error stop 'dvnrhoall: non-finite value(s)'
  if (.not. all(ieee_is_finite(dvnzall))) error stop 'dvnzall: non-finite value(s)'
  if (.not. all(ieee_is_finite(dTnall))) error stop 'dTnall: non-finite value(s)'

  ! FIXME: should we loop through the workers for each parameter first? that way we can overwrite that parameter and also not worry about worker 2 having to block until worker 1 receives all of its data...  The issue is that parmtmp changes size for each worker...   Possibly allocated a single linear buffer that can hold the full data and pack that with the data to be sent to avoid repeated allocation and deallocations...  Can we also interleave interpolation with the message passing???
  !in the 3D case we cannnot afford to send full grid data and need to instead use neutral subgrid splits defined earlier
  do iid=1,mpi_cfg%lid-1
    allocate(parmtmp(lzn,slabsizes(iid,1),slabsizes(iid,2)))    !get space for the parameters for this worker

    parmtmp=dnOall(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dnO,MPI_COMM_WORLD,ierr)

    parmtmp=dnN2all(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dnN2,MPI_COMM_WORLD,ierr)

    parmtmp=dnO2all(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dnO2,MPI_COMM_WORLD,ierr)

    parmtmp=dTnall(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dTn,MPI_COMM_WORLD,ierr)

    parmtmp=dvnrhoall(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dvnrho,MPI_COMM_WORLD,ierr)

    parmtmp=dvnzall(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dvnz,MPI_COMM_WORLD,ierr)

    parmtmp=dvnxall(1:lzn,indx(iid,3):indx(iid,4),indx(iid,5):indx(iid,6))
    call mpi_send(parmtmp,lzn*slabsizes(iid,1)*slabsizes(iid,2),mpi_realprec,iid,tag%dvnx,MPI_COMM_WORLD,ierr)

    deallocate(parmtmp)
  end do

  !root needs to grab its piece of data
  dnO=dnOall(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dnN2=dnN2all(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dnO2=dnO2all(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dTn=dTnall(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dvnrho=dvnrhoall(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dvnz=dvnzall(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
  dvnx=dvnxall(1:lzn,indx(0,3):indx(0,4),indx(0,5):indx(0,6))
else     !workers
  !receive a subgrid copy of the data from root
  call mpi_recv(dnO,lzn*lxn*lyn,mpi_realprec,0,tag%dnO,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dnN2,lzn*lxn*lyn,mpi_realprec,0,tag%dnN2,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dnO2,lzn*lxn*lyn,mpi_realprec,0,tag%dnO2,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dTn,lzn*lxn*lyn,mpi_realprec,0,tag%dTn,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dvnrho,lzn*lxn*lyn,mpi_realprec,0,tag%dvnrho,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dvnz,lzn*lxn*lyn,mpi_realprec,0,tag%dvnz,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
  call mpi_recv(dvnx,lzn*lxn*lyn,mpi_realprec,0,tag%dvnx,MPI_COMM_WORLD,MPI_STATUS_IGNORE,ierr)
end if

if (mpi_cfg%myid==mpi_cfg%lid/2 .and. debug) then
  print*, 'neutral data size:  ',mpi_cfg%myid,lzn,lxn,lyn
  print *, 'Min/max values for dnO:  ',mpi_cfg%myid,minval(dnO),maxval(dnO)
  print *, 'Min/max values for dnN:  ',mpi_cfg%myid,minval(dnN2),maxval(dnN2)
  print *, 'Min/max values for dnO2:  ',mpi_cfg%myid,minval(dnO2),maxval(dnO2)
  print *, 'Min/max values for dvnx:  ',mpi_cfg%myid,minval(dvnx),maxval(dvnx)
  print *, 'Min/max values for dvnrho:  ',mpi_cfg%myid,minval(dvnrho),maxval(dvnrho)
  print *, 'Min/max values for dvnz:  ',mpi_cfg%myid,minval(dvnz),maxval(dvnz)
  print *, 'Min/max values for dTn:  ',mpi_cfg%myid,minval(dTn),maxval(dTn)
!  print*, 'coordinate ranges:  ',minval(zn),maxval(zn),minval(rhon),maxval(rhon),minval(zi),maxval(zi),minval(rhoi),maxval(rhoi)
end if

end subroutine read_dneu3D

end submodule perturb


      REAL FUNCTION TWDRIZ(DATA,WEI,NDAT,NCOU,YSTART,
     : NX,NY,DNY,ONX,ONY,WCS,WCSOUT,PXG,PYG,XGDIM,YGDIM,
     : PFRACT,KERNEL,COEFFS,FILSTR,VFLAG,CLEN,NMISS,NSKIP,VERS)
C
C Call Wdrizzle without use of IRAF interfaces.
C
C Supplied:
C
C   DATA - a 2d REAL array with dimensions (NX,NY): the input
C          data.
C
C   WEI - a 2d REAL array with dimensions (NX,NY): the input
C          weight array.
C
C   NDAT - a 2d REAL array with dimensions (ONX,ONY): the output
C          data array which is updated. It should be initialised
C          the first time around.
C
C   NCOU - a 2d REAL array with dimensions (ONX,ONY): the output
C          weight array which is updated. It should be initialised
C          the first time around.
C
C   NX,NY,ONX,ONY - INTEGERs: the dimensions of the arrays described
C                   above.
C
C   WCS,WCSOUT - double precision arrays, 8 elements in each.
C                Input and output WCS.
C
C   PFRACT - REAL: the drizzle "pixfrac" parameter.
C
C   KERNEL - CHARACTER*8 f77 character string: the type of kernel
C            used to distribute weight onto the output. Currently
C            supports "square","gaussian","tophat","point","turbo",
C            "lanczos2" and "lanczos3".
C
C   COEFFS - CHARACTER*80 f77 character string: the name of the
C            text file containing distortion correction coefficients.
C
C Returned:
C
C    a REAL status is returned: the status return of the DOBOX
C    routine
C
C This was developed as a simple interface to the lower-level
C drizzle utilities which could be invoked without the need for
C an IRAF environment.
C
C If it is intended to be called from IDL the following applies:
C
C All parameters are passed from IDL using the "call external"
C mechanism. The intermediate file is idldriz.f. The linking looks
C something like this on Solaris 8:
C
C  f77 -c idlwdriz.f tdriz.f drutil.f drcall.f -pic -G
C  f77 -o idlwdriz.so drcall.o drutil.o idldriz.o tdriz.o -G -lF77 -lM77 -lsunmath -lm -lc
C
C If just being called directly from some f77 application it is
C only necessary to link in the following:
C
C  f77 -o app app.f twdriz.f drutil.f drcall.f
C
C where "app" is the top-level application.
C
C Notes:
C
C  - Some parameters, not included in the calling sequence, are hardcoded
C below in the section marked below.
C
C  - Secondary parameters are not supported at present
C
C  - All the weighting information must be supplied in the WEI array.
C    Ie, wt_scl=1.0.
C
C  - Context images are not currently supported
C
C  Test version, Richard Hook, ST-ECF, STScI, September 2002
C  Improved documentation, Richard Hook, ST-ECF, STScI, November 2002
C
C Modified to run under Linux, Richard Hook, ST-ECF, STScI, April 2003
C
C Wdrizzle version, ST-ECF, STScI, September 2003
C Added VFLAG for verbosity, STScI/ECF, October 2003
C
      IMPLICIT NONE

      INTEGER NX,NY,ONX,ONY,DNY
      INTEGER IDD,ISTAT,XMIN,YMIN,XMAX,YMAX,YSTART
      INTEGER VFLAG
      INTEGER NMISS,NSKIP

C Distortion coefficients and related
      INTEGER COTY,COMAX,CONUM
      PARAMETER (COMAX=100)
      REAL LAM,XCO(COMAX),YCO(COMAX)
      CHARACTER*80 COEFFS, FILSTR
      INTEGER CLEN

C Distortion image arrays
      REAL PXG(XGDIM,YGDIM), PYG(XGDIM,YGDIM)
      INTEGER XGDIM,YGDIM
      LOGICAL DISIM

C Verbose flag
      LOGICAL VERBOSE
      COMMON /VERBOSE/VERBOSE

C Maximum size (in X) of the input image
      INTEGER MAXNX
      PARAMETER (MAXNX=100000)

      REAL DATA(NX,DNY),WEI(NX,DNY)
      REAL NDAT(ONX,ONY),NCOU(ONX,ONY)

      DOUBLE PRECISION WCS(8)
      DOUBLE PRECISION WCSOUT(8)

      REAL XI(MAXNX,4),YI(MAXNX,4),XO(MAXNX,4),YO(MAXNX,4)
      REAL XIB(MAXNX),YIB(MAXNX),XOB(MAXNX),YOB(MAXNX)
      REAL XSH,YSH,ROT,DROT,SCALE
      REAL WTSCL,EXPIN,PFRACT,FILVAL
      INTEGER NEN,UNIQID

C Context related things
      LOGICAL CON
      LOGICAL BITCON
      LOGICAL FILL

C We give these minimal dimensions
      INTEGER NCON(1,1)
      INTEGER DONE(1,1)
      INTEGER MAXEN,MAXIM
      PARAMETER (MAXIM=100,MAXEN=100)
      INTEGER INTAB(MAXIM,MAXEN)

      CHARACTER*8 ALIGN,KERNEL
      LOGICAL ROTFIR,UPDATE,USEWEI,INCPS,USEWCS,NOOVER

C Secondary geometrical parameters, added in V1.5
      LOGICAL SECPAR
      REAL XSH2,YSH2,ROT2,XSCALE,YSCALE
      CHARACTER*8 SHFR2
      LOGICAL ROTF2
      CHARACTER*50 VERS

C Check for verbose
      IF(VFLAG.EQ.1) THEN
         VERBOSE=.TRUE.
      ELSE
         VERBOSE=.FALSE.
      ENDIF

C Define Version ID
      VERS = 'Callable WDRIZZLE Version 0.5 (25rd June 2004)'
C Announce
      CALL UMSPUT(VERS,1,0,ISTAT)

C Get geometric distortion coefficients
      IDD = 0
      CALL GETGEO(COEFFS,IDD,LAM,COTY,COMAX,CONUM,
     :                  XCO,YCO,CLEN,ISTAT)
      IF(ISTAT.NE.0) RETURN

C Set DISIM logical based on whether distortion images have
C  been passed in for use or not.
      IF (XGDIM .EQ. 2 .AND. YGDIM .EQ. 2) THEN
         DISIM = .FALSE.
      ELSE
         DISIM = .TRUE.
      ENDIF

C Setup reasonable defaults for the drizzling
      XMIN=1
      XMAX=ONX
      YMIN=1
      YMAX=ONY
      NOOVER=.FALSE.

C All weighting is done by the weight array
      WTSCL=1.0
      INCPS=.TRUE.

C Input exposure assumed to be 1.0s
      EXPIN=1.0
      ROTFIR=.FALSE.

C Convert the rotation to radians
      ROT=DROT*3.141592653/180.0

C Secondary parameters are not currently supported
      SECPAR=.FALSE.
      UPDATE=.TRUE.
      USEWEI=.TRUE.

C Wdrizzle, hence...
      USEWCS=.TRUE.
      CON=.FALSE.
      UNIQID = 1

C Do the drizzling
      CALL DOBOX(DATA,WEI,NDAT,NCOU,NCON,DONE,NX,NY,DNY,
     :     YSTART,XMIN,XMAX,YMIN,YMAX,NOOVER,
     :     KERNEL,XI,XO,YI,YO,XIB,XOB,YIB,YOB,
     :     ONX,ONY,COTY,CONUM,XCO,YCO,DISIM,PXG,PYG,XGDIM,YGDIM,
     :     WTSCL,ALIGN,INCPS,EXPIN,
     :     PFRACT,SCALE,ROT,XSH,YSH,WCS,WCSOUT,ROTFIR,
     :     SECPAR,XSH2,YSH2,ROT2,XSCALE,YSCALE,SHFR2,ROTF2,
     :     CON,BITCON,INTAB,MAXIM,MAXEN,NEN,UNIQID,
     :     UPDATE,USEWEI,USEWCS,ISTAT,NMISS,NSKIP)

C The arrays NDAT and NCOU will have been updated
C Check for meaningful values
      IF(FILSTR(1:5).NE.'INDEF'.AND.FILSTR(1:5).NE.'indef') THEN
         READ(FILSTR,*,IOSTAT=ISTAT) FILVAL
         IF(ISTAT.NE.0) THEN
            CALL UMSPUT('! Invalid filling value specified',
     :                  1,0,ISTAT)
            FILL=.FALSE.
         ELSE
            FILL=.TRUE.
         ENDIF
      ELSE
         FILL=.FALSE.
      ENDIF

C Put in the fill values (if defined)
      IF (FILL) CALL PUTFIL(NDAT,NCOU,XMAX-XMIN+1,
     :    YMAX-YMIN+1,FILVAL)

C Return the value of status
      TWDRIZ=FLOAT(ISTAT)

      END