                             PROGRAM RIGIDSF
c
C       ****************************************************************
C      *  THIS PROGRAM IS AN ADAPTATION OF THE BLECK AND BOUDRA (1986) *
C      *       ISOPYCNIC COORDINATE GENERAL CIRCULATION MODEL.         *
C      *  RECTANGULAR BASIN VERSION  WITH OR WITHOUT NO-SLIP BOUNDARY  *
C      *                      CONDITION                                *
C      *****************************************************************
C
C       II  =  NUMBER OF GRID POINTS IN x-DIRECTION                 C
C       JJ  =  NUMBER OF GRID POINTS IN y-DIRECTION                 C
C       KK  =  NUMBER OF LAYERS                                     C
C       II1 = II - 1                                                C
C       JJ1 = JJ - 1                                                C
C	DP          --> LAYER THICKNESS in pressure units
C	PBOT	    --> PRESSURE AT THE BOTTOM  [dyn/(cm**2)]
C	UFLUX       --> LAYER VELOCITY TIMES LAYER THICKNESS
C	UTROP       --> BAROTROPIC VELOCITY
C
C======================================================================C
C======================================================================C
C	RECALL THAT THE # OF GRID POINTS HAS TO BE A PRODUCT OF SMALL
C       PRIMES IN ORDER TO MAKE USE OF THE FFT TO SOLVE THE POISSON
C	EQUATION.
C

      PARAMETER(II=101,JJ=II,KK=2,II2=II-2,JJ2=JJ-2,MAX=II2)
      PARAMETER(NW=INT(2.5*MAX+II))
C
C======================================================================C
C
      REAL U(II,JJ,2*KK) ,V(II,JJ,2*KK) ,DP(II,JJ,2*KK),MONTG(II,JJ,KK)
     .    ,P(II,JJ,KK+1) ,CORIO(II,JJ)  ,ABSVOR(II,JJ)
     .    ,UTROP(II,JJ)  ,VTROP(II,JJ)  ,VORT(II,JJ)   ,PS(II,JJ)
     .    ,DEL2U(II,JJ)  ,STRESY(II,JJ) ,STRMF(II,JJ)  ,WSAVE(NW)
     .    ,EIG(II,JJ)    ,UFLUX(II,JJ)
     .    ,VFLUX(II,JJ)  ,UOLD(II,JJ,KK), DEL2V(II,JJ)
     .    ,VOLD(II,JJ,KK),PBOT(JJ)      ,THETA(KK)     ,DP0(KK)
     .    ,DISVIS(KK)    ,STRESS(KK)    ,XCONT(KK)     ,ZETA(II,JJ)
     .    ,UTIL1(II,JJ)  ,DPM(II,JJ,KK)    ,UM(II,JJ,KK)
     .    ,UTIL2(II,JJ)  , VM(II,JJ,KK)
     .    ,STRESX(II,JJ), PU(II,JJ,KK+1), PV(II,JJ,KK+1), ULD(II,JJ,KK)
     .    ,VLD(II,JJ,KK)
c
c
C
      EQUIVALENCE   (VORT,STRMF)
C
C     ----------------------------------------------------------------------
C
c	-------------------------------------------------------------
c
C ---           FUNCTIONS TO MIMIC CRAY VECTOR MASK FUNCTIONS
c
              CVMGP(A,B,C)=A*(.5+SIGN(.5,C))+B*(.5-SIGN(.5,C))
c
c	-------------------------------------------------------------
C
C
C======================================================================C
C                   DEFINE PHYSICAL PARAMETERS                         C
C======================================================================C
C
C --- SUBTRACT FOLLOWING VALUES FROM 1. TO OBTAIN LAYER SPECIFIC VOLUME
c
              DATA THETA/0.0263,0.0265/
c
C
c	RHO=1./(1-THETA) GIVES THE RELATION BETWEEN RHO AND THETA
c
C
C --- HORIZONTAL GRID SCALE

               DATA SCALE/20.E5/             ! in cm
C
c
C --- PRESSURE AND DP's  ARE GIVEN IN UNITS OF dyn/(cm**2)
C --- EAST-WEST DIRECTION ARRAY OF BOTTOM PRESSURES

               DATA PBOT/II*5000.E5/
	       DATA PBOTTM/5000.E5/

C
C --- GRAVITATIONAL ACCELERATION
               DATA G/980.6/
C
C
C --- VELOCITY TIME SMOOTHING WEIGHTS
               DATA WGT1,WGT2/.75,.125/
C
C
C --- DEPTH OF WIND STRESS FORCING AND LINEAR BOTTOM DRAG COEFFICIENT
               DATA PSTRES/50.E5/,DRAG/1.E-7/
C
C
C --- TWO LEAP FROG TIME LEVELS
               DATA M,N/2,1/
C
               DATA VISCOS/1.E6/
C
               DATA EPS/1.E5/,EPS1/1.E5/,EPSIL/1.E-9/
C
C --- 'EPS' IS USED WHEREVER LAYER THICKNESS MUST
C ---       BE BOUNDED AWAY FROM ZERO.
C

c
C --- MODEL IS TO BE INTEGRATED FROM TIME STEP 'NSTEP1' TO 'NSTEP2'
C
        READ(5,*) NDAY1,NDAY2
          print*,'nday1= ', nday1, ' nday2 = ', nday2
C
	READ(5,*)DELT               ! TIME STEP OF INTEGRATION
C
        READ(5,*)(DP0(K),K=1,KK)
          print*,'dp0(1) = ',dp0(1),' dp0(2) = ',dp0(2)
C
        READ(5,*)STRESSA,IFREE
          print*,'stressa = ', stressa
	if(ifree.eq.1) print*,'Model run with free-slip boundary cond.'
	if(ifree.eq.2) print*,'Model run with no-slip boundary cond.'
C
C --------------------------------------------------------------------
C
      NSTEP1=NDAY1*86400./DELT + .0001
      NSTEP2=NDAY2*86400./DELT + .0001
C
C -------------------------------------------------------------------
C
	       SCALE2=SCALE**2
               X=1./SCALE
               II1 = II-1
               JJ1 = JJ-1
               BETA=2.E-13
C
C
C
C======================================================================C
C                        INITIALIZATION                                C
C======================================================================C
C
C --- CALL INITIALIZATION SUBROUTINE FOR POISSON SOLVER:
C
          CALL POINIT(II-2,JJ-2,II,PBOT,EIG,WSAVE)
C
C --- SPECIFY INITIAL AND BOUNDARY CONDITIONS
C
C
      DO 10 I=1,II
          DO 10 J=1,JJ
C
C --- CORIOLIS PARAMETER
          CORIO(I,J)=.93E-4+FLOAT(J-JJ1/2)*SCALE*BETA
C
C======================================================================C
C                    WIND STRESS PROFILE                               C
C======================================================================C
C
          STRESX(I,J)=STRESSA*COS(FLOAT(J-1)/FLOAT(JJ1)
     .                *6.28318530718)*G/PSTRES
          STRESY(I,J)=0.
C
C======================================================================C
c	The wind stress is prescribed as a body force and is assumed
c	to decrease linearly to the depth corresponding to PSTRES.
c	If the upper layer thickness (actually corresponding pressure)
c	becomes less than PSTRES, then the forcing is distributed
c	to the second layer and so on according to the linear law.
C
C
          ABSVOR(I,J)=CORIO(I,J)
          UFLUX(I,J)=0.
          VFLUX(I,J)=0.
          STRMF(I,J)=0.
          MONTG(I,J,KK)=0.
          P(I,J,1)=0.
C
             DO 10 K=1,KK
             U(I,J,K   )=0.
             U(I,J,K+KK)=0.
             V(J,J,K   )=0.
             V(I,J,K+KK)=0.
             DP(I,J,K   )=DP0(K)
10           DP(I,J,K+KK)=DP0(K)
C======================================================================C
C======================================================================C
C
                   DELT1=DELT
C
        WRITE(6,551)II
551	FORMAT(2X'NUMBER OF GRID ELEMENTS IN EACH DIRECTION : 'I3)
       WRITE(6,552)SCALE
552	FORMAT(2X'GRID SIZE : 'E6.1)
       WRITE(6,553)DELT
553	FORMAT(2X'TIME STEP : 'F8.1)
       WRITE(6,554)VISCOS
554	FORMAT(2X'Viscosity : 'e10.4)
C
C======================================================================C
C --- RESTART FROM RESTART FILES IF COMPUTATION IS NOT TO START         C
C               FROM REST                                              C
C======================================================================C
C
       IF(NSTEP1.EQ.0) GO TO 75
c
C     ---------------------------------------------------------------
C
      DELT1=DELT+DELT
C
C     ---------------------------------------------------------------
C
      NO=10
      READ (NO) NSTEP0,TIME0,U
      NO=11
      READ (NO) NSTEP0,TIME0,V
      NO=12
      READ (NO) NSTEP0,TIME0,DP
C
C======================================================================C
C
C --- FOLLOWIND DO LOOP NEEDED ONLY IF HISTORY FILE USED TO RESTART
C
C           DO 2 K = 1,KK
C           DO 2 I = 1,II
C           DO 2 J = 1,JJ
C      V(I,J,K+KK) = V(I,J,K)
C      U(I,J,K+KK) = U(I,J,K)
C    2 DP(I,J,K+KK)= DP(I,J,K)
C      DELT1=DELT
C
C======================================================================C
C
       WRITE (6,1112) NSTEP0,NSTEP1
1112    FORMAT (15X'TIME STEP IN HISTORY FILE - 'I7,9X'WANTED - 'I7)
C
C
      IF(NSTEP0.NE.NSTEP1) THEN
      WRITE (6,103) NSTEP0,NSTEP1
103   FORMAT (/' STEP NO.'I5' SHOULD BE'I5)
      ENDIF
C
75       	CONTINUE
      IREC=0
      NSTEP=NSTEP1
      WRITE (6,102) NSTEP
102   FORMAT (/' MODEL INTEGRATION STARTS FROM TIME STEP ',I6/)
C
C
C
C=======================================================================C
C                                                                       C
C                     MAIN LOOP STARTS HERE                             C
C                     =====================                             C
C                           =========                                   C
C=======================================================================C
C
15    MM=(M-1)*KK
      NN=(N-1)*KK
c
c
      NSTEP=NSTEP+1
      TIME=NSTEP*DELT/86400.
      INDEX=0
      IF (AMOD(TIME+.0001,1.).LT..0002) INDEX=1
C
C
C=======================================================================C
C           CONTINUITY EQUATION (LAYER THICKNESS PREDICTION)            C
C=======================================================================C
C
C     ****************************************************************
C --- ----------------------------------------------------------------
C
C ---    (USING 'FLUX CORRECTED TRANSPORT' ALGORITHM)
C
C --- ----------------------------------------------------------------
C     ****************************************************************
C
      DO 39 J=1,JJ1
      DO 39 I=1,II1
      UTROP(I,J)=0.
39    VTROP(I,J)=0.
      DO 1 K=1,KK
      KM=K+MM
      KN=K+NN
C
C --- COMPUTE LOW-ORDER (DIFFUSIVE) FLUXES
C
      DO 11 J=1,JJ1
      DO 11 I=2,II1
11    UFLUX(I,J)=U(I,J,KM)*CVMGP(DP(I-1,J,KN),DP(I,J,KN),U(I,J,KM))
      DO 12 J=2,JJ1
      DO 12 I=1,II1
12    VFLUX(I,J)=V(I,J,KM)*CVMGP(DP(I,J-1,KN),DP(I,J,KN),V(I,J,KM))
C
C --- ADVANCE  DP  FIELD USING LOW-ORDER (DIFFUSIVE) FLUX VALUES
C
      DO 19 J=1,JJ1
      DO 19 I=1,II1
      UOLD(I,J,K)=DP(I,J,KN)
19    DP(I,J,KN)=DP(I,J,KN)-(UFLUX(I+1,J)-UFLUX(I,J)
     .                      +VFLUX(I,J+1)-VFLUX(I,J))*X*DELT1
C
C --- COMPUTE 'ANTIDIFFUSIVE' (I.E., HIGH-ORDER MINUS LOW-ORDER) FLUXES
C
C
C --- SECOND-ORDER FLUXES FOR CONTINUITY EQUATION
C
      DO 16 J=1,JJ1
      UFLUX(  2,J)=U(  2,J,KM)*.5*(DP(  2,J,KM)+DP(  1,J,KM))-
     .UFLUX(  2,J)
16    UFLUX(II1,J)=U(II1,J,KM)*.5*(DP(II2,J,KM)+DP(II1,J,KM))-
     .UFLUX(II1,J)
      DO 17 I=1,II1
      VFLUX(I,  2)=V(I,  2,KM)*.5*(DP(I,  2,KM)+DP(I,  1,KM))-
     .VFLUX(I,  2)
17    VFLUX(I,JJ1)=V(I,JJ1,KM)*.5*(DP(I,JJ2,KM)+DP(I,JJ1,KM))-
     .VFLUX(I,JJ1)
      DO 20 J=1,JJ1
      DO 20 I=3,II2
   20 UFLUX(I,J)=U(I,J,KM)*.5*(DP(I,J,KM)+DP(I-1,J,KM))-
     .UFLUX(I,J)
      DO 21 J=3,JJ2
      DO 21 I=1,II1
   21 VFLUX(I,J)=V(I,J,KM)*.5*(DP(I,J,KM)+DP(I,J-1,KM))-
     .VFLUX(I,J)
C
C --- AT EACH GRID POINT, DETERMINE THE RATIO OF THE LARGEST PERMISSIBLE
C --- POS. (NEG.) CHANGE IN  DP  TO THE SUM OF ALL INCOMING (OUTGOING) FLUXES
C
C --- FIRST, THE FOUR CORNER POINTS...
      UTIL1(  1,  1)=-(DP(  1,  1,KN)-AMAX1(
     .DP(  1,  1,KN),DP(  2,  1,KN),DP(  1,  2,KN)))
     ./((-AMIN1(0.,UFLUX(  2,  1))
     .   -AMIN1(0.,VFLUX(  1,  2))+EPSIL)*X*DELT1)
      UTIL2(  1,  1)=-(DP(  1,  1,KN)-AMAX1(0.,AMIN1(
     .DP(  1,  1,KN),DP(  2,  1,KN),DP(  1,  2,KN))))
     ./((-AMAX1(0.,UFLUX(  2,  1))
     .   -AMAX1(0.,VFLUX(  1,  2))-EPSIL)*X*DELT1)
C
      UTIL1(  1,JJ1)=-(DP(  1,JJ1,KN)-AMAX1(
     .DP(  1,JJ1,KN),DP(  2,JJ1,KN),DP(  1,JJ2,KN)))
     ./((-AMIN1(0.,UFLUX(  2,JJ1))
     .   +AMAX1(0.,VFLUX(  1,JJ1))+EPSIL)*X*DELT1)
      UTIL2(  1,JJ1)=-(DP(  1,JJ1,KN)-AMAX1(0.,AMIN1(
     .DP(  1,JJ1,KN),DP(  2,JJ1,KN),DP(  1,JJ2,KN))))
     ./((-AMAX1(0.,UFLUX(  2,JJ1))
     .   +AMIN1(0.,VFLUX(  1,JJ1))-EPSIL)*X*DELT1)
C
      UTIL1(II1,  1)=-(DP(II1,  1,KN)-AMAX1(
     .DP(II1,  1,KN),DP(II2,  1,KN),DP(II1,  2,KN)))
     ./(( AMAX1(0.,UFLUX(II1,  1))
     .   -AMIN1(0.,VFLUX(II1,  2))+EPSIL)*X*DELT1)
      UTIL2(II1,  1)=-(DP(II1,  1,KN)-AMAX1(0.,AMIN1(
     .DP(II1,  1,KN),DP(II2,  1,KN),DP(II1,  2,KN))))
     ./(( AMIN1(0.,UFLUX(II1,  1))
     .   -AMAX1(0.,VFLUX(II1,  2))-EPSIL)*X*DELT1)
C
      UTIL1(II1,JJ1)=-(DP(II1,JJ1,KN)-AMAX1(
     .DP(II1,JJ1,KN),DP(II2,JJ1,KN),DP(II1,JJ2,KN)))
     ./(( AMAX1(0.,UFLUX(II1,JJ1))
     .   +AMAX1(0.,VFLUX(II1,JJ1))+EPSIL)*X*DELT1)
      UTIL2(II1,JJ1)=-(DP(II1,JJ1,KN)-AMAX1(0.,AMIN1(
     .DP(II1,JJ1,KN),DP(II2,JJ1,KN),DP(II1,JJ2,KN))))
     ./(( AMIN1(0.,UFLUX(II1,JJ1))
     .   +AMIN1(0.,VFLUX(II1,JJ1))-EPSIL)*X*DELT1)
C
C --- NOW THE REMAINING LATERAL BOUNDARY POINTS...
      DO 25 I=2,II2
      UTIL1(I,  1)=-(DP(I,  1,KN)-AMAX1(
     .DP(I,  1,KN),DP(I-1,  1,KN),DP(I+1,  1,KN),DP(I,  2,KN)))
     ./((AMAX1(0.,UFLUX(I,  1))-AMIN1(0.,UFLUX(I+1,  1))
     .                         -AMIN1(0.,VFLUX(I  ,  2))+EPSIL)*X*DELT1)
      UTIL2(I,  1)=-(DP(I,  1,KN)-AMAX1(0.,AMIN1(
     .DP(I,  1,KN),DP(I-1,  1,KN),DP(I+1,  1,KN),DP(I,  2,KN))))
     ./((AMIN1(0.,UFLUX(I,  1))-AMAX1(0.,UFLUX(I+1,  1))
     .                         -AMAX1(0.,VFLUX(I  ,  2))-EPSIL)*X*DELT1)
      UTIL1(I,JJ1)=-(DP(I,JJ1,KN)-AMAX1(
     .DP(I,JJ1,KN),DP(I-1,JJ1,KN),DP(I+1,JJ1,KN),DP(I,JJ2,KN)))
     ./((AMAX1(0.,UFLUX(I,JJ1))-AMIN1(0.,UFLUX(I+1,JJ1))
     .  +AMAX1(0.,VFLUX(I,JJ1))                         +EPSIL)*X*DELT1)
 25   UTIL2(I,JJ1)=-(DP(I,JJ1,KN)-AMAX1(0.,AMIN1(
     .DP(I,JJ1,KN),DP(I-1,JJ1,KN),DP(I+1,JJ1,KN),DP(I,JJ2,KN))))
     ./((AMIN1(0.,UFLUX(I,JJ1))-AMAX1(0.,UFLUX(I+1,JJ1))
     .  +AMIN1(0.,VFLUX(I,JJ1))                         -EPSIL)*X*DELT1)
C
      DO 26 J=2,JJ2
      UTIL1(  1,J)=-(DP(  1,J,KN)-AMAX1(
     .DP(  1,J,KN),DP(  2,J,KN),DP(  1,J-1,KN),DP(  1,J+1,KN)))
     ./((                      -AMIN1(0.,UFLUX(  2,J  ))
     .  +AMAX1(0.,VFLUX(  1,J))-AMIN1(0.,VFLUX(  1,J+1))+EPSIL)*X*DELT1)
      UTIL2(  1,J)=-(DP(  1,J,KN)-AMAX1(0.,AMIN1(
     .DP(  1,J,KN),DP(  2,J,KN),DP(  1,J-1,KN),DP(  1,J+1,KN))))
     ./((                      -AMAX1(0.,UFLUX(  2,J  ))
     .  +AMIN1(0.,VFLUX(  1,J))-AMAX1(0.,VFLUX(  1,J+1))-EPSIL)*X*DELT1)
      UTIL1(II1,J)=-(DP(II1,J,KN)-AMAX1(
     .DP(II1,J,KN),DP(II2,J,KN),DP(II1,J-1,KN),DP(II1,J+1,KN)))
     ./((AMAX1(0.,UFLUX(II1,J))
     .  +AMAX1(0.,VFLUX(II1,J))-AMIN1(0.,VFLUX(II1,J+1))+EPSIL)*X*DELT1)
 26   UTIL2(II1,J)=-(DP(II1,J,KN)-AMAX1(0.,AMIN1(
     .DP(II1,J,KN),DP(II2,J,KN),DP(II1,J-1,KN),DP(II1,J+1,KN))))
     ./((AMIN1(0.,UFLUX(II1,J))
     .  +AMIN1(0.,VFLUX(II1,J))-AMAX1(0.,VFLUX(II1,J+1))-EPSIL)*X*DELT1)
C
C --- FINALLY, THE INTERIOR GRID POINTS...
      DO 27 J=2,JJ2
      DO 27 I=2,II2
      UTIL1(I,J)=-(DP(I,J,KN)-AMAX1(
     .DP(I,J,KN),DP(I-1,J,KN),DP(I+1,J,KN),DP(I,J-1,KN),DP(I,J+1,KN)))
     ./((AMAX1(0.,UFLUX(I,J))-AMIN1(0.,UFLUX(I+1,J))
     .  +AMAX1(0.,VFLUX(I,J))-AMIN1(0.,VFLUX(I,J+1))+EPSIL)*X*DELT1)
 27   UTIL2(I,J)=-(DP(I,J,KN)-AMAX1(0.,AMIN1(
     .DP(I,J,KN),DP(I-1,J,KN),DP(I+1,J,KN),DP(I,J-1,KN),DP(I,J+1,KN))))
     ./((AMIN1(0.,UFLUX(I,J))-AMAX1(0.,UFLUX(I+1,J))
     .  +AMIN1(0.,VFLUX(I,J))-AMAX1(0.,VFLUX(I,J+1))-EPSIL)*X*DELT1)
C
C --- LIMIT ANTIDIFFUSIVE FLUXES
C --- (RETAIN INFORMATION ABOUT FLUX CLIPPING IN -UTROP,VTROP-. THIS
C --- WILL ALLOW US LATER TO RESTORE NONDIVERGENCE OF BAROTROPIC FLOW.)
C
      DO 28 J=1,JJ1
      DO 28 I=2,II1
      UTROP(I,J)=UTROP(I,J)+UFLUX(I,J)*
     .(1.-CVMGP(AMIN1(1.,UTIL1(I,J),UTIL2(I-1,J)),
     .          AMIN1(1.,UTIL2(I,J),UTIL1(I-1,J)),UFLUX(I,J)))
28    UFLUX(I,J)=UFLUX(I,J)*CVMGP(AMIN1(1.,UTIL1(I,J),UTIL2(I-1,J)),
     .                            AMIN1(1.,UTIL2(I,J),UTIL1(I-1,J)),
     .UFLUX(I,J))
      DO 29 J=2,JJ1
      DO 29 I=1,II1
      VTROP(I,J)=VTROP(I,J)+VFLUX(I,J)*
     .(1.-CVMGP(AMIN1(1.,UTIL1(I,J),UTIL2(I,J-1)),
     .          AMIN1(1.,UTIL2(I,J),UTIL1(I,J-1)),VFLUX(I,J)))
29    VFLUX(I,J)=VFLUX(I,J)*CVMGP(AMIN1(1.,UTIL1(I,J),UTIL2(I,J-1)),
     .                            AMIN1(1.,UTIL2(I,J),UTIL1(I,J-1)),
     .VFLUX(I,J))
C
C --- ADD ANTIDIFFUSIVE FLUXES TO  DP  FIELD
C
      DO 1 J=1,JJ1
      DO 1 I=1,II1
1     DP(I,J,KN)=DP(I,J,KN)-(UFLUX(I+1,J)-UFLUX(I,J)
     .                      +VFLUX(I,J+1)-VFLUX(I,J))*X*DELT1
C
C --- RESTORE NONDIVERGENCE OF VERTICALLY INTEGRATED FLOW
C
      DO 5 J=1,JJ1
      DO 5 K=1,KK
      DO 5 I=1,II1
5     P(I,J,K+1)=P(I,J,K)+DP(I,J,K+NN)
      DO 14 K=1,KK
      KN=K+NN
      DO 44 J=1,JJ1
      DO 44 I=2,II1
44    UFLUX(I,J)=UTROP(I,J)*CVMGP(DP(I-1,J,KN)/P(I-1,J,KK+1),
     .                            DP(I  ,J,KN)/P(I  ,J,KK+1),UTROP(I,J))
      DO 45 J=2,JJ1
      DO 45 I=1,II1
45    VFLUX(I,J)=VTROP(I,J)*CVMGP(DP(I,J-1,KN)/P(I,J-1,KK+1),
     .                            DP(I,J  ,KN)/P(I,J  ,KK+1),VTROP(I,J))
      DO 14 J=1,JJ1
      DO 14 I=1,II1
14    DP(I,J,KN)=DP(I,J,KN)-(UFLUX(I+1,J)-UFLUX(I,J)
     .                      +VFLUX(I,J+1)-VFLUX(I,J))*X*DELT1
C
C     ****************************************************************
C
C ---                   END OF  F C T  CALCULATIONS
C
C     ****************************************************************
C
C=======================================================================C
C                       HYDROSTATIC EQUATION                            C
C=======================================================================C
C
      DO 83 J=1,JJ1
      DO 8 K=1,KK
      DO 8 I=1,II1
    8      P(I,J,K+1)=P(I,J,K)+DP(I,J,K+MM)
      DO 13 KI=2,KK
      K=KK+1-KI
      DO 13 I=1,II1
   13    MONTG(I,J,K)=MONTG(I,J,K+1)+P(I,J,K+1)*(THETA(K+1)-THETA(K))
C
C --- TIME SMOOTHING OF THICKNESS FIELD
C
      DO 83 K=1,KK
      DO 83 I=1,II1
   83      DP(I,J,K+MM)=DP(I,J,K+MM)*.98+(UOLD(I,J,K)+DP(I,J,K+NN))*.01
C
C
C=======================================================================C
C                       MOMENTUM EQUATIONS                              C
C=======================================================================C
C
      DO 9 K=1,KK

      KM=K+MM
      KN=K+NN
      XCONT(K)=0.
      DISVIS(K)=0.
      STRESS(K)=0.
C
c
C
c
C=======================================================================C
C                        VORTICITY COMPUTATION                          C
C=======================================================================C
C
      DO 80 I=2,II1
      DO 80 J=2,JJ1
   80 ABSVOR(I,J)=(CORIO(I,J)+(V(I,J,KM)-V(I-1,J,KM)-U(I,J,KM)
     .+U(I,J-1,KM))*X)
c
c     Impose the boundary conditions on the calculation of ABSVOR
c     near the boundaries
c
C
	IF(IFREE.EQ.2) THEN      ! for no-slip

      DO 81 J=2,JJ1
      ABSVOR(1,J)=(CORIO(1,J)+2.*V(1,J,KM)*X)
   81 ABSVOR(II,J)=(CORIO(II,J)-2.*V(II1,J,KM)*X)
C
      DO 82 I=2,II1
      ABSVOR(I,1)=(CORIO(I,1)-2.*U(I,1,KM)*X)
 82   ABSVOR(I,JJ)=(CORIO(I,JJ)+2.*U(I,JJ1,KM)*X)

	ENDIF
C
C
C======================================================================C
C                       OOOOOOOOOOOOOOOOOOOOO                           C
C=======================================================================C
C                            U EQUATION                                 C
C=======================================================================C
C
C=======================================================================C
C                THICKNESS FIELD FOR LATERAL DIFFUSION                  C
C=======================================================================C

      DO 412 J=1,JJ1
      PS(1,J)=DP(1,J,KM)
      PS(II,J)=DP(II1,J,KM)
      UOLD(1,J,K)=0.
      UOLD(II,J,K)=0.
C
      DO 412 I=2,II1
      PS(I,J)=.5*(DP(I,J,KM)+DP(I-1,J,KM))
      UOLD(I,J,K)=U(I,J,KN)
  412 CONTINUE
C
      DO 37 J=1,JJ1
      JA=MAX0(  1,J-1)
      JB=MIN0(JJ1,J+1)
c
c	Set up the free-slip or no-slip boundary conditions
c	(if.ifree.eq.1 ---> free slip boundary condition)
C
             SIG1 = 1.
             SIG2 = 1.
	if(ifree.eq.2) then        ! no-slip boundary condition
             IF(J.EQ.  1) SIG1 = -1.
             IF(J.EQ.JJ1) SIG2 = -1.
	endif
C
C --- RECTANGULAR BASIN
c
C	...this DEL2U term is neccesary for the laplacian viscosity term...
C
      DO 37 I=2,II1
   37 DEL2U(I,J)=
     .((PS(I+1,J)+PS(I,J))*(UOLD(I+1,J,K)-UOLD(I,J,K))-
     . (PS(I,J)+PS(I-1,J))*(UOLD(I,J,K)-UOLD(I-1,J,K))+
     . (PS(I,JB)+PS(I,J))*(SIG2*UOLD(I,JB,K)-UOLD(I,J,K))-
     . (PS(I,J )+PS(I,JA))*(UOLD(I,J,K)-SIG1*UOLD(I,JA,K)))*.5

C=======================================================================C
C            BEGIN INTEGRATION OF U MOMENTUM EQUATION                   C
C=======================================================================C
      DO 61 J=1,JJ1
CDIR$ IVDEP
      DO 6 I=2,II1
6     U(I,J,KN)=
C
C --- HORIZONTAL PRESSURE FORCE (X-DIRECTION)
     .U(I,J,KN)-DELT1*((MONTG(I,J,K)-MONTG(I-1,J,K)
C
C --- GRADIENT OF KINETIC ENERGY
     .+.25*(U(I+1,J,KM)**2+V(I  ,J,KM)**2+V(I  ,J+1,KM)**2
     .     -U(I-1,J,KM)**2-V(I-1,J,KM)**2-V(I-1,J+1,KM)**2))*X
C
C --- ABSOLUTE VORTICITY FLUX
     .-.125*(V(I,J,KM)+V(I,J+1,KM)+V(I-1,J,KM)+V(I-1,J+1,KM))*
     .(ABSVOR(I,J)+ABSVOR(I,J+1))
C
C --- WIND STRESS FORCING
     .-STRESX(I,J)*(AMIN1(P(I,J,K+1)+P(I-1,J,K+1)+1.E3,PSTRES+PSTRES)
     .             -AMIN1(P(I,J,K  )+P(I-1,J,K  )   ,PSTRES+PSTRES))/
     .             (      P(I,J,K+1)+P(I-1,J,K+1)+1.E3
     .                   -P(I,J,K  )-P(I-1,J,K  ))
C
C --- VISCOUS DIFFUSION
     .-DEL2U(I,J)*VISCOS*X*X
     ./AMAX1(.5*(DP(I,J,KM)+DP(I-1,J,KM)),EPS))
C
      IF (INDEX.EQ.0) GO TO 61
C --- EVALUATE TERMS IN KINETIC ENERGY EQUATION
      DO 59 I=2,II1
C
      XCONT(K)=XCONT(K)-U(I,J,KM)*.5*(DP(I,J,KM)+DP(I-1,J,KM))*
     .(MONTG(I,J,K)-MONTG(I-1,J,K))/(G*SCALE)
C
      STRESS(K)=STRESS(K)+U(I,J,KM)*.5*(DP(I,J,KM)+DP(I-1,J,KM))*
     .STRESX(I,J)*(AMIN1(P(I,J,K+1)+P(I-1,J,K+1)+1.E3,PSTRES+PSTRES)
     .    -AMIN1(P(I,J,K  )+P(I-1,J,K  )   ,PSTRES+PSTRES))/
     .    (      P(I,J,K+1)+P(I-1,J,K+1)+1.E3
     .    -P(I,J,K  )-P(I-1,J,K  ))/G
C
      IF (K.EQ.KK) STRESS(K)=STRESS(K)-
     .DRAG*.5*(DP(I,J,KM)+DP(I-1,J,KM))*U(I,J,KM)*U(I,J,KN)/G
C
59    DISVIS(K)=DISVIS(K)-U(I,J,KM)*.5*(DP(I,J,KM)+DP(I-1,J,KM))/G
     .*DEL2U(I,J)*VISCOS*X*X
     ./AMAX1(.5*(DP(I,J,KM)+DP(I-1,J,KM)),EPS)
61    CONTINUE
C
C=======================================================================C
C                       OOOOOOOOOOOOOOOOOOOOO                           C
C=======================================================================C
C                             V EQUATION                                C
C=======================================================================C
C
      DO 76 I=1,II1
      PS(I,1)=DP(I,1,KM)
      PS(I,JJ)=DP(I,JJ1,KM)
      VOLD(I,1,K)=0.
      VOLD(I,JJ,K)=0.
      DO 76 J=2,JJ1
      PS(I,J)=.5*(DP(I,J,KM)+DP(I,J-1,KM))
      VOLD(I,J,K)=V(I,J,KN)
   76 CONTINUE
C
C
      DO 420 I=1,II1
      IA=MAX0(1,I-1)
      IB=MIN0(II1,I+1)
c
c	Set up the free-slip or no-slip boundary conditions
c	(if.ifree.eq.1 ---> free slip boundary condition)
C
             SIG1 = 1.
             SIG2 = 1.
	if(ifree.eq.2) then       ! no-slip boundary condition
             IF(I.EQ.  1) SIG1 = -1.
             IF(I.EQ.II1) SIG2 = -1.
	endif
C
      DO 420 J=2,JJ1
  420 DEL2V(I,J)=
     .((PS(IB,J)+PS(I,J))*(SIG2*VOLD(IB,J,K)-VOLD(I,J,K))-
     . (PS(I,J)+PS(IA,J))*(VOLD(I,J,K)-SIG1*VOLD(IA,J,K))+
     . (PS(I,J+1)+PS(I,J))*(VOLD(I,J+1,K)-VOLD(I,J,K))-
     . (PS(I,J)+PS(I,J-1))*(VOLD(I,J,K)-VOLD(I,J-1,K)))*.5

C======================================================================C
C                 BEGIN INTEGRATION OF V-MOMENTUM-EQUATION             C
C======================================================================C
C
      DO 62 I=1,II1
CDIR$ IVDEP
      DO 7 J=2,JJ1
7     V(I,J,KN)=
C
C --- HORIZONTAL PRESSURE FORCE (Y-DIRECTION)
     .V(I,J,KN)-DELT1*((MONTG(I,J,K)-MONTG(I,J-1,K)
C
C --- GRADIENT OF KINETIC ENERGY
     .+.25*(V(I,J+1,KM)**2+U(I,J  ,KM)**2+U(I+1,J  ,KM)**2
     .     -V(I,J-1,KM)**2-U(I,J-1,KM)**2-U(I+1,J-1,KM)**2))*X
C
C --- ABSOLUTE VORTICITY FLUX
     .+.125*(U(I,J,KM)+U(I+1,J,KM)+U(I,J-1,KM)+U(I+1,J-1,KM))*
     .(ABSVOR(I,J)+ABSVOR(I+1,J))
C
C --- WIND STRESS FORCING
     .-STRESY(I,J)*(AMIN1(P(I,J,K+1)+P(I,J-1,K+1)+1.E3,PSTRES+PSTRES)
     .             -AMIN1(P(I,J,K  )+P(I,J-1,K  )   ,PSTRES+PSTRES))/
     .             (      P(I,J,K+1)+P(I,J-1,K+1)+1.E3
     .                   -P(I,J,K  )-P(I,J-1,K  ))
C
C --- VISCOUS DIFFUSION
     .-DEL2V(I,J)*X*X*VISCOS
     ./AMAX1(.5*(DP(I,J,KM)+DP(I,J-1,KM)),EPS))
      IF (INDEX.EQ.0) GO TO 62
C
C --- EVALUATE TERMS IN KINETIC ENERGY EQUATION
      DO 60 J=2,JJ1
      XCONT(K)=XCONT(K)-V(I,J,KM)*.5*(DP(I,J,KM)+DP(I,J-1,KM))*
     .(MONTG(I,J,K)-MONTG(I,J-1,K))/(G*SCALE)
C
      STRESS(K)=STRESS(K)+V(I,J,KM)*.5*(DP(I,J,KM)+DP(I,J-1,KM))*
     .STRESY(I,J)*(AMIN1(P(I,J,K+1)+P(I,J-1,K+1)+1.E3,PSTRES+PSTRES)
     .    -AMIN1(P(I,J,K  )+P(I,J-1,K  )   ,PSTRES+PSTRES))/
     .    (      P(I,J,K+1)+P(I,J-1,K+1)+1.E3
     .    -P(I,J,K  )-P(I,J-1,K  ))/G
C
      IF (K.EQ.KK) STRESS(K)=STRESS(K)-
     .DRAG*.5*(DP(I,J,KM)+DP(I,J-1,KM))*V(I,J,KM)*V(I,J,KN)/G
C
60    DISVIS(K)=DISVIS(K)-V(I,J,KM)*.5*(DP(I,J,KM)+DP(I,J-1,KM))/G
     .*DEL2V(I,J)*X*X*VISCOS
     ./AMAX1(.5*(DP(I,J,KM)+DP(I,J-1,KM)),EPS)
62    CONTINUE
9     CONTINUE
C
C======================================================================C
C                         BOTTOM DRAG                                  C
C======================================================================C
C
      KN=KK+NN
      DO 18 J=1,JJ1
      DO 18 I=1,II1
      U(I,J,KN)=U(I,J,KN)*(1.-DRAG*DELT1)
18    V(I,J,KN)=V(I,J,KN)*(1.-DRAG*DELT1)
C
C----------------------------------------------------------------------C
C
      DO 850 K=1,KK
      DO 850 I=1,II1
      DO 850 J=1,JJ1
  850 P(I,J,K+1)=P(I,J,K)+DP(I,J,K+NN)
C
C
C --- SUBSTITUTE DEPTH-WEIGHTED AVERAGES FOR (U,V) AT MASSLESS GRID POINTS
C
      DO 771 K=1,KK+1
      DO 771 J=1,JJ1
      DO 771 I=2,II1
  771 PU(I,J,K)=.5*(P(I,J,K)+P(I-1,J,K))
C
      DO 772 K=1,KK+1
      DO 772 J=2,JJ1
      DO 772 I=1,II1
  772 PV(I,J,K)=.5*(P(I,J,K)+P(I,J-1,K))
C
C
      DO 774 K=1,KK
      DO 668 J=2,JJ1
      DO 668 I=1,II1
  668 VLD(I,J,K)=V(I,J,K+NN)*(PV(I,J,K+1)-PV(I,J,K))
C
      DO 773 K1=1,K-1
      DO 773 J=2,JJ1
      DO 773 I=1,II1
  773 VLD(I,J,K)=VLD(I,J,K)+V(I,J,K1+NN)*
     .(AMIN1(PV(I,J,K  ),AMAX1(PV(I,J,K+1)-EPS1,PV(I,J,K1+1)))
     .-AMIN1(PV(I,J,K  ),AMAX1(PV(I,J,K+1)-EPS1,PV(I,J,K1  ))))
C
      DO 774 K1=K+1,KK
      DO 774 J=2,JJ1
      DO 774 I=1,II1
  774 VLD(I,J,K)=VLD(I,J,K)+V(I,J,K1+NN)*
     .(AMAX1(PV(I,J,K+1),AMIN1(PV(I,J,K  )+EPS1,PV(I,J,K1+1)))
     .-AMAX1(PV(I,J,K+1),AMIN1(PV(I,J,K  )+EPS1,PV(I,J,K1  ))))
C
      DO 663 K=1,KK
      DO 663 J=2,JJ1
      DO 663 I=1,II1
  663 V(I,J,K+NN)=VLD(I,J,K)/
     .(AMAX1(PV(I,J,K+1),AMIN1(PV(I,J,K  )+EPS1,PV(I,J,KK+1)))
     .-AMIN1(PV(I,J,K  ),AMAX1(PV(I,J,K+1)-EPS1,PV(I,J,   1))))
C
      DO 863 J=1,JJ1
C
      DO 874 K=1,KK
      DO 888 I=2,II1
  888 ULD(I,J,K)=U(I,J,K+NN)*(PU(I,J,K+1)-PU(I,J,K))
      DO 873 K1=1,K-1
      DO 873 I=2,II1
  873 ULD(I,J,K)=ULD(I,J,K)+U(I,J,K1+NN)*
     .(AMIN1(PU(I,J,K  ),AMAX1(PU(I,J,K+1)-EPS1,PU(I,J,K1+1)))
     .-AMIN1(PU(I,J,K  ),AMAX1(PU(I,J,K+1)-EPS1,PU(I,J,K1  ))))
C
      DO 874 K1=K+1,KK
      DO 874 I=2,II1
  874 ULD(I,J,K)=ULD(I,J,K)+U(I,J,K1+NN)*
     .(AMAX1(PU(I,J,K+1),AMIN1(PU(I,J,K  )+EPS1,PU(I,J,K1+1)))
     .-AMAX1(PU(I,J,K+1),AMIN1(PU(I,J,K  )+EPS1,PU(I,J,K1  ))))
C
            DO 863 K=1,KK
      DO 863 I=2,II1
  863 U(I,J,K+NN)=ULD(I,J,K)/
     .(AMAX1(PU(I,J,K+1),AMIN1(PU(I,J,K  )+EPS1,PU(I,J,KK+1)))
     .-AMIN1(PU(I,J,K  ),AMAX1(PU(I,J,K+1)-EPS1,PU(I,J,1   ))))

C======================================================================C
C REMOVE DIVERGENT COMPONENT FROM MEAN MOTION (RIGID LID APPROXIMAT.)  C
C======================================================================C
C
      DO 36 J=1,JJ1
      DO 36 I=1,II1
        P(I,J,KK+1)=0.
         UTROP(I,J)=0.
36        VTROP(I,J)=0.
      DO 32 K=1,KK
       KN=K+NN
        DO 30 J=1,JJ1
         DO 30 I=1,II1
30        P(I,J,KK+1)=P(I,J,KK+1)+DP(I,J,KN)
      DO 46 J=1,JJ1
      UTROP(  2,J)=UTROP(  2,J)+U(  2,J,KN)*(DP(  2,J,KN)+DP(  1,J,KN))
46    UTROP(II1,J)=UTROP(II1,J)+U(II1,J,KN)*(DP(II2,J,KN)+DP(II1,J,KN))
      DO 31 J=1,JJ1
      DO 31 I=3,II2
   31 UTROP(I,J)=UTROP(I,J)+U(I,J,KN)*(DP(I,J,KN)+DP(I-1,J,KN))
      DO 47 I=1,II1
      VTROP(I,  2)=VTROP(I,  2)+V(I,  2,KN)*(DP(I,  2,KN)+DP(I,  1,KN))
47    VTROP(I,JJ1)=VTROP(I,JJ1)+V(I,JJ1,KN)*(DP(I,JJ2,KN)+DP(I,JJ1,KN))
      DO 32 J=3,JJ2
      DO 32 I=1,II1
   32 VTROP(I,J)=VTROP(I,J)+V(I,J,KN)*(DP(I,J,KN)+DP(I,J-1,KN))
C
C
      DO 34 J=1,JJ1
      DO 34 I=2,II1
34    UTROP(I,J)=UTROP(I,J)/(P(I,J,KK+1)+P(I-1,J,KK+1))
      DO 35 J=2,JJ1
      DO 35 I=1,II1
35    VTROP(I,J)=VTROP(I,J)/(P(I,J,KK+1)+P(I,J-1,KK+1))
      DO 33 J=2,JJ1
      DO 33 I=2,II1
33    VORT(I,J)=(VTROP(I,J)-VTROP(I-1,J)-UTROP(I,J)+UTROP(I,J-1))
C
C=======================================================================C
C --- SOLVE POISSON EQUATION TO DETERMINE ROTATIONAL PART OF MEAN MOTION
C --- FOR TESTING THE FFT ROUTINE, ACTIVATE THE TWO STATEMENTS ..PRINT 110...
C --- AND THE LOOP DO 52.... FOR PBOTTM=CONST., THE RESULTS SHOULD AGREE
C=======================================================================C
C
      IF (INDEX.GT.0) PRINT 110,(VORT(I,I),I=2,13)
110   FORMAT (1X,1P12E10.3)

       CALL POISSON(VORT(2,2),II,II2,JJ2,PBOT,EIG,WSAVE)
C
      DO 52 I=2,13
52    UTIL1(I,I)=(STRMF(I-1,I)+STRMF(I+1,I)
     .         +STRMF(I,I-1)+STRMF(I,I+1)-4.*STRMF(I,I))/PBOTTM
      IF (INDEX.GT.0) PRINT 110,(UTIL1(I,I),I=2,13)
C
C
C
C=======================================================================C
C     COMPUTE THE NONDIVERGENT BAROTROPIC VELOCITY FIELD (UTROP) FROM   C
C     THE  STREMFUNCTION AND SUBTRACT THIS FROM THE TOTAL TO FIND THE   C
C     DIVERGENT PART OF THE BAROTROPIC FLOW.                            C
C=======================================================================C
C
      DO 43 J=1,JJ1
       DO 43 I=2,II1
43    UTROP(I,J)=UTROP(I,J)-(STRMF(I,J)-STRMF(I,J+1))
     ./(.5*(P(I,J,KK+1)+P(I-1,J,KK+1)))
C
      DO 40 J=2,JJ1
       DO 40 I=1,II1
40    VTROP(I,J)=VTROP(I,J)-(STRMF(I+1,J)-STRMF(I,J))
     ./(.5*(P(I,J,KK+1)+P(I,J-1,KK+1)))
C
      DO 41 K=1,KK
        KN=K+NN
         DO 42 J=1,JJ1
          DO 42 I=2,II1
42         U(I,J,KN)=U(I,J,KN)-UTROP(I,J)
            DO 41 J=2,JJ1
             DO 41 I=1,II1
41    V(I,J,KN)=V(I,J,KN)-VTROP(I,J)
C
C=======================================================================C
C                 SMOOTH  U  AND  V  FIELDS IN TIME                     C
C=======================================================================C
C
      DO 22 K=1,KK
      KM=K+MM
      KN=K+NN
      DO 324 J=1,JJ1
      DO 324 I=2,II1
      U(I,J,KM)=U(I,J,KM)*WGT1+(UOLD(I,J,K)+U(I,J,KN))*WGT2
324   CONTINUE

      DO 222 J=2,JJ1
      DO 222 I=1,II1
      V(I,J,KM)=V(I,J,KM)*WGT1+(VOLD(I,J,K)+V(I,J,KN))*WGT2
222	CONTINUE
C
22	CONTINUE
c
C=======================================================================C
C                                                                       C
C                  OUTPUT AND DIAGNOSTIC CALCULATIONS                   C
C                  ==================================                   C
C                                                                       C
C=======================================================================C
C
      IF (INDEX.EQ.0) GO TO 23
      PRINT 100,NSTEP,TIME
100   FORMAT (' T I M E   S T E P'I9,25X'D A Y'F8.1)
C
C --- ENERGY DIAGNOSTICS
C
      PBAR=0.
      SUMWGT=0.
      SUMPOT=0.
      SUMKIN=0.
      SUMXGR=0.
      SUMSTR=0.
      SUMDIS=0.
      SUMEKT=0.
      DO 53 K=1,KK
      KM=K+MM
      EPOT=0.
      EKIN=0.
      WEIGHT=PBOTTM
      DO 51 I=1,II1
      DO 51 J=1,JJ1
      IF (K.EQ.1)
     .EPOT=EPOT+.5*(STRMF(I,J)*CORIO(I,J)*SCALE/P(I,J,KK+1))**2/G
      IF (K.GT.1)
     .EPOT=EPOT+.5*(P(I,J,K)-PBAR)**2*(THETA(K)-THETA(K-1))/G
      EKIN=EKIN+.25*DP(I,J,KM)*(U(I,J,KM)**2+U(I+1,J,KM)**2
     .                         +V(I,J,KM)**2+V(I,J+1,KM)**2)/G
C --- CORRECT KINETIC ENERGY BUDGET FOR REMOVAL OF DIVERGENT PART OF MEAN MOTION
      XCONT(K)=XCONT(K)-.5*DP(I,J,KM)*
     .(U(I  ,J,KM)*UTROP(I  ,J)+V(I,J  ,KM)*VTROP(I,J  )
     .+U(I+1,J,KM)*UTROP(I+1,J)+V(I,J+1,KM)*VTROP(I,J+1))/(G*DELT1)
51    WEIGHT=AMIN1(WEIGHT,DP(I,J,KM))
      EPOT=EPOT/(II1*JJ1)
      EKIN=EKIN/(II1*JJ1)
      DISVIS(K)=-DISVIS(K)/(II1*JJ1)
      XCONT(K)=XCONT(K)/(II1*JJ1)
      STRESS(K)=STRESS(K)/(II1*JJ1)
      EKINT=STRESS(K)+XCONT(K)+DISVIS(K)
      PRINT 101,WEIGHT,EPOT,EKIN,EKINT,XCONT(K),STRESS(K),DISVIS(K),K
101   FORMAT (1P' THKN'E10.2'  EPOT'E10.2'  EKIN'E10.2'  EKINT'E10.2
     .'  XCONT'E10.2'  STRESS'E10.2'  DISSIP'E10.2,I4)
      SUMWGT=SUMWGT+WEIGHT
      SUMKIN=SUMKIN+EKIN
      SUMPOT=SUMPOT+EPOT
      SUMXGR=SUMXGR+XCONT(K)
      SUMSTR=SUMSTR+STRESS(K)
      SUMDIS=SUMDIS+DISVIS(K)
      SUMEKT=SUMEKT+EKINT
53    PBAR=PBAR+DP0(K)
      PRINT 101,SUMWGT,SUMPOT,SUMKIN,SUMEKT,SUMXGR,SUMSTR,SUMDIS
C
C --- OUTPUT TO RESTART FILE
C
      NO=20
      REWIND (NO)
      WRITE (NO) NSTEP,DAY,U
      NO=21
      REWIND (NO)
      WRITE (NO) NSTEP,DAY,V
      NO=22
      REWIND (NO)
      WRITE (NO) NSTEP,DAY,DP
C
C --- OUTPUT TO HISTORY FILE
C
      NO=30
      WRITE (NO) (((U(I,J,K),I=1,II),J=1,JJ),K=1,KK),NSTEP
      NO=31
      WRITE (NO) (((V(I,J,K),I=1,II),J=1,JJ),K=1,KK),NSTEP
      NO=32
      WRITE (NO) (((DP(I,J,K),I=1,II),J=1,JJ),K=1,KK),NSTEP
C
C --- OUTPUT TO AVERAGED FILES
C
C
C
      IREC=IREC+1
      DO 180 K=1,KK
      DO 180 J=1,JJ
      DO 180 I=1,II
      DPM(I,J,K)=DP(I,J,K+NN)+DPM(I,J,K)
      UM(I,J,K)=U(I,J,K+NN)+UM(I,J,K)
 180  VM(I,J,K)=V(I,J,K+NN)+VM(I,J,K)
C
      NO=23
C      REWIND (NO)
C      WRITE (NO) UM,IREC
      NO=24
C      REWIND (NO)
C      WRITE (NO) VM,IREC
      NO=25
C      REWIND (NO)
C      WRITE (NO) DPM,IREC
C
C
23    L=M
      M=N
      N=L
      IF (NSTEP.GE.NSTEP2) STOP '(NORMAL)'
      DELT1=DELT+DELT
      GO TO 15
      END
C=======================================================================C
C                                                                       C
          SUBROUTINE POINIT(M,N,L,PBOT,EIG,WSAVE)
C         =======================================                       C
C    INITIALIZATION ROUTINE FOR FFTPSSN:                                C
C    THIS VERSION OF POINIT PERMITS PBOTTOM TO VARY IN Y DIRECTION      C
C=======================================================================C

          REAL EIG(L,N), WORK(1), PBOT(L)
           PI = 4.*ATAN(1.)
C--- INITIALIZE FFT ROUTINE
           CALL SINTI(M,WSAVE)

C--- EIGENVALUES OF TRIDIAGONAL MATRIX
           DO 1 J=1,M
           DO 1 K=1,N
    1      EIG(J,K) = -1./PBOT(K) - 1./PBOT(K+1)
     .                -8.*SIN(J*PI/2./(M+1))**2/(PBOT(K)+PBOT(K+1))
C--- GAUSSIAN ELIMINATION OF TRI-DIAGONAL SYSTEM - LEFT HAND SIDE
           DO 2 K = 2,N
           DO 2 J = 1,M
    2      EIG(J,K) = EIG(J,K) - 1./(PBOT(K)**2*EIG(J,K-1))
c
           RETURN
           END
c
C=================================================================C
C                                                                 C
       SUBROUTINE POISSON(ZETA,II,M,N,PBOT,EIG,WSAVE)
C      ==============================================             C
C                                                                 C
C                                                                 C
C       This subroutine uses a Fast Sine Transform algorithm      C
C       to solve  the  POISSON  EQUATION:                         C
C                                                                 C
C                      PSI  + PSI  = ZETA                         C
C                         xx     yy                               C
C                                                                 C
C       using  the Dirichlet's boundary  conditions:              C
C                                                                 C
C         PSI(0,y) = PSI(Lx,y) = PSI(x,0) = PSI(x,Ly) = 0         C
C                                                                 C
C       in a rectangular domain  with dimensions Lx, Ly.          C
C                      ---------------------------                C
C       Note that the the array ZETA inputs the right hand        C
C       side of the equation and  returns the solution, PSI.      C
C                                                                 C
C       WSAVE is an working array of dimension int(2.5*MAX+15)    C
C           if II2=JJ2 then WSAVE does not need to be modified    C
C             by calling SINTI again.                             C
C                    ********************                         C
C       THIS SUBROUTINE CALLS SUBROUTINES SINT AND SINTI,  FROM   C
C       NCAR'S PACKAGE: FFTPACK (LINK WITH LIBRARY MYLIBRY.OLB)   C
C=================================================================C

        DIMENSION ZETA(II,*), EIG(II,*), PBOT(*), WSAVE(*)

          PI = 4.*ATAN(1.)
          N1 = N+1
          M1 = M+1
C=================================================================C
C         PART I - COMPUTES TRANSFORM OF ZETA(I,J)                C
C=================================================================C

          DO 60 K = 1,N
          DO 50 J = 1,M
   50     ZETA(J,K) = ZETA(J,K)/(2.*(M1))
C--- FORWARD TRANSFORM:
   60     CALL SINT(M,ZETA(1,K),WSAVE)

C--- GAUSSIAN ELIMINATION - RIGHT HAND SIDE
          DO 2 K=2,N
          DO 2 J=1,M
    2     ZETA(J,K) = ZETA(J,K)-ZETA(J,K-1)/(PBOT(K)*EIG(J,K-1))

          DO 3 J=1,M
    3     ZETA(J,N) = ZETA(J,N)/EIG(J,N)

          DO 4 K=N-1,1,-1
          DO 4 J=1,M
    4     ZETA(J,K)=(ZETA(J,K)-ZETA(J,K+1)/PBOT(K+1))/EIG(J,K)

C--- BACK TRANSFORM:
          DO 6 K=1,N
          CALL SINT(M,ZETA(1,K),WSAVE)
    6     ZETA(M1,K) = 0.

          RETURN
          END
C
c=========================================================================
c=========================================================================
c		INPUT FILE NEEDED WITH PARAMETERS
c=========================================================================
c
c 0,5                         ! nstep1, nstep2
c 1200                        ! delt
c 500.e5,4500.e5              ! dp(1),dp(2)
c 1.0,2                       !  wind stress, 1 --> free slip, 2 --> no-slip
c 5.e6                        !  viscosity in cgs units
c
c=========================================================================


      MODULE MOD_PHOTOCS_M

      contains

      SUBROUTINE PHOTOCS_M(SIGMA,SIGMATH,EDGE,WAVENUM,ALPHA,SEXPO,AGAUNT,LOW,WAVARR,SIGARR,N,NF)

C***  CALCULATES SIGMA(NUE), THE FREQUENCY DEPENDENT PHOTO CROSS SECTION
C***  Returns SIGMA

      USE MOD_CSTABREAD

      implicit none

      REAL*8, intent(out) :: SIGMA
      INTEGER,intent(in) :: N, NF, LOW
      REAL*8,intent(in)  :: SIGMATH,EDGE,WAVENUM
      REAL*8,dimension(N),intent(in) :: ALPHA,SEXPO
      character*8,intent(in) :: agaunt(N)
      REAL*8,dimension(N,NF),intent(in) :: WAVARR, SIGARR

      !local variables
      REAL*8 :: CN, DEN, U, GAUNT, FLAMDA
      REAL*8 :: X, X3, XLAM, X0LN2, X0LN, XLN, XLN2
      INTEGER :: I

C******************************************************************************
C***  CHANGES BY MARGIT HABERREITER, 20 MAY, 2002
CMH  LEVLOW NEEDS TO BE DEFINED, AS IT IS USED AS A KEYWORD TO SELECT THE
CMH  ELEMENT AND LEVEL TO READ THE CONTINUUM OPACITIES FROM AN INPUT TABLE
C      CHARACTER*10 LEVLOW
C******************************************************************************

      REAL*8, PARAMETER :: ONE = 1.D+0

      DIMENSION CN(6)

C***  H- FROM JOHN A&A193,189 (1988)
      DATA CN/152.519d0,49.534d0,-118.858d0,92.536d0,-34.194d0,4.982d0/
C***  THE FOLLOWING DATA ARE FOR MIHALAS' GAUNT FACTOR FIT ( HI AND HE II, N=1)
      REAL*8 :: A0,A1,A2,A3, AM1, AM2
      DATA A0,A1,A2,A3,AM1,AM2 /
     $ 1.2302628d0,  -3.1927214d-2, 8.9105122d-4, -1.1544111d-5,
     $ -0.50812150d0, 0.10631895d0 /

      X = EDGE / WAVENUM

!      print*, 'photocs_m: ', alpha(low), sexpo(low), ' ', agaunt(low)

C***  VARIABLE AGAUNT IS MISUSED TO CARRY THE KEYWORD 'KOESTER' FOR
C***  NEW PHOTOIONIZATION CROSS SECTIONS (KOESTER ET AL. 1985, A+A 149, 423)
C***  FIT COEFFICIENTS FOR THE MODIFIED (!) FORMULA:

      IF (AGAUNT(LOW) .EQ. 'KOESTER') THEN

          XLN=LOG(1.d8/WAVENUM)
          XLN2=XLN*XLN
          X0LN=LOG(1.d8/EDGE)
          X0LN2=X0LN*X0LN
          SIGMA=SIGMATH*X**ALPHA(LOW)*EXP(SEXPO(LOW)*(XLN2-X0LN2))

!          write(*, '(A,1x,2(2x,e15.7),1x,A)'), 'photocs_m koester:', sigma, sigmath, agaunt(low)

C*****************************************************************
C***  changes by Margit Haberreiter
CMH   IN CASE OF TABLE READ CROSS SECTIONS FROM TABLE
CMH   THE VARAIBLE AGAUNT IS MISUSED TO CARRY THE KEYWORD 'TABLE' FOR
CMH   READING THE CONTINUUM CROSS SECTIONS FOR EACH ELEMENT, LEVEL AND WAVENUMBER
CMH  FROM A TABLE
CMH  else if (AGAUNT(LOW) .EQ. 7HTABLE01) THEN
      else if (AGAUNT(LOW) .EQ. 'TABLE') THEN

        call cstabread(SIGMA, WAVENUM, LOW, WAVARR, SIGARR, N, NF)

!        write(*, '(A,1x,2x,e15.7,A,1x,A)'), 'photocs_m table:  ', sigma, '                 ', agaunt(low)

C*****************************************************************
CMH  HIER IST DAS PROBLEM, AGAUNT(LOW) WIRD NICHT ERKANNT ??
      else if (AGAUNT(LOW) .EQ. 'H-MINUS') THEN
c***     source: John 1988 A&A 193,189
c        control table: Wishart 1979, MNRAS 187, 59p
         XLAM=1.d4/WAVENUM
         X3=XLAM*XLAM*XLAM
         X=SQRT((WAVENUM-EDGE)*1.d-4)
         if (wavenum.gt.50000.) then
            FLAMDA=127.84486d0*X
         ELSE
            FLAMDA = 0.d0
            DO I=6,1,-1
               FLAMDA=(FLAMDA+CN(I))*X
            ENDDO
         ENDIF

         SIGMA=FLAMDA*X*X*X3*SIGMATH

!         write(*, '(A,1x,2(2x,e15.7),1x,A)'), 'photocs_m h-minus:', sigma, sigmath, agaunt(low)

      ELSE
C***  OLD VERSION: SEATON / HYDROGENIC

          IF (ALPHA(LOW) .NE. .0) THEN
C***       ALPHA(LOW) DEFINED: SEATON FORMULA
           SIGMA=SIGMATH * X**SEXPO(LOW)*(ALPHA(LOW)+(one-ALPHA(LOW))*X)
           ELSE
C***  ALPHA(LOW) NOT DEFINED: HYDROGENIC EXPONENT NUE**(-3)
           SIGMA=SIGMATH*X*X*X
          ENDIF

!          write(*, '(A,1x,2(2x,e15.7),1x,A)'), 'photocs_m else:   ', sigma, sigmath, agaunt(low)

      ENDIF
C***  BOUND-FREE GAUNT FACTORS ARE CALCULATED DEPENDING ON KEYWORD AGAUNT

C***  POLYNOMIAL FIT FOR GII(N=1) FROM MIHALAS 1967 APJ 149,P187
C***  THIS MIHALAS GAUNT FACTOR IS ONLY VALID FOR GROUND STATE N=1 !
      IF (AGAUNT(LOW) .EQ. 'MIHALAS' ) THEN

            GAUNT=A0+X*(AM1+X*AM2)+(A1+(A2+A3/X)/X)/X
            SIGMA=SIGMA*GAUNT

!            write(*, '(A,1x,2x,e15.7,A,1x,A)'), 'photocs_m mihalas:', sigma, '                 ', agaunt(low)

      ENDIF
C***  GII FIT FROM SEATON (1960), REP. PROG. PHYS. 23, P. 313
C***  THIS FORMULA IS VALID FOR ALL HYDROGENIC LEVELS ( H OR HE II)
C***  VARIABLE SEXPO IS MISUSED TO CARRY THE MAIN QUANTUM NUMBER
      IF (AGAUNT(LOW) .EQ. 'SEATON' ) THEN

            IF (SEXPO(LOW) .LE. .0d0) stop 'ERROR in PHOTOCS_M: MAIN QUANTUM NUMBER UNDEFINED'

            U=one/X - one
            DEN=(X/SEXPO(LOW))**0.666666666666d0
            GAUNT=one + 0.1728d0 * (U-one) * DEN -
     -            0.0496d0 * (U*(U+1.333333333333d0)+one) * DEN * DEN
            SIGMA=SIGMA*GAUNT

!            write(*, '(A,1x,2x,e15.7,A,1x,A)'), 'photocs_m seaton: ', sigma, '                 ', agaunt(low)

      ENDIF

      RETURN

      END SUBROUTINE

      END MODULE


!*==ssbgv.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SSBGV
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSBGV + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
!                         LDZ, WORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBZ, UPLO
!       INTEGER            INFO, KA, KB, LDAB, LDBB, LDZ, N
!       ..
!       .. Array Arguments ..
!       REAL               AB( LDAB, * ), BB( LDBB, * ), W( * ),
!      $                   WORK( * ), Z( LDZ, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SSBGV computes all the eigenvalues, and optionally, the eigenvectors
!> of a real generalized symmetric-definite banded eigenproblem, of
!> the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
!> and banded, and B is also positive definite.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBZ
!> \verbatim
!>          JOBZ is CHARACTER*1
!>          = 'N':  Compute eigenvalues only;
!>          = 'V':  Compute eigenvalues and eigenvectors.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangles of A and B are stored;
!>          = 'L':  Lower triangles of A and B are stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrices A and B.  N >= 0.
!> \endverbatim
!>
!> \param[in] KA
!> \verbatim
!>          KA is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'. KA >= 0.
!> \endverbatim
!>
!> \param[in] KB
!> \verbatim
!>          KB is INTEGER
!>          The number of superdiagonals of the matrix B if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'. KB >= 0.
!> \endverbatim
!>
!> \param[in,out] AB
!> \verbatim
!>          AB is REAL array, dimension (LDAB, N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first ka+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).
!>
!>          On exit, the contents of AB are destroyed.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KA+1.
!> \endverbatim
!>
!> \param[in,out] BB
!> \verbatim
!>          BB is REAL array, dimension (LDBB, N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix B, stored in the first kb+1 rows of the array.  The
!>          j-th column of B is stored in the j-th column of the array BB
!>          as follows:
!>          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
!>          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).
!>
!>          On exit, the factor S from the split Cholesky factorization
!>          B = S**T*S, as returned by SPBSTF.
!> \endverbatim
!>
!> \param[in] LDBB
!> \verbatim
!>          LDBB is INTEGER
!>          The leading dimension of the array BB.  LDBB >= KB+1.
!> \endverbatim
!>
!> \param[out] W
!> \verbatim
!>          W is REAL array, dimension (N)
!>          If INFO = 0, the eigenvalues in ascending order.
!> \endverbatim
!>
!> \param[out] Z
!> \verbatim
!>          Z is REAL array, dimension (LDZ, N)
!>          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
!>          eigenvectors, with the i-th column of Z holding the
!>          eigenvector associated with W(i). The eigenvectors are
!>          normalized so that Z**T*B*Z = I.
!>          If JOBZ = 'N', then Z is not referenced.
!> \endverbatim
!>
!> \param[in] LDZ
!> \verbatim
!>          LDZ is INTEGER
!>          The leading dimension of the array Z.  LDZ >= 1, and if
!>          JOBZ = 'V', LDZ >= N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (3*N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, and i is:
!>             <= N:  the algorithm failed to converge:
!>                    i off-diagonal elements of an intermediate
!>                    tridiagonal form did not converge to zero;
!>             > N:   if INFO = N + i, for 1 <= i <= N, then SPBSTF
!>                    returned INFO = i: B is not positive definite.
!>                    The factorization of B could not be completed and
!>                    no eigenvalues or eigenvectors were computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHEReigen
!
!  =====================================================================
      SUBROUTINE SSBGV(Jobz,Uplo,N,Ka,Kb,Ab,Ldab,Bb,Ldbb,W,Z,Ldz,Work,  &
     &                 Info)
      IMPLICIT NONE
!*--SSBGV181
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobz , Uplo
      INTEGER Info , Ka , Kb , Ldab , Ldbb , Ldz , N
!     ..
!     .. Array Arguments ..
      REAL Ab(Ldab,*) , Bb(Ldbb,*) , W(*) , Work(*) , Z(Ldz,*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL upper , wantz
      CHARACTER vect
      INTEGER iinfo , inde , indwrk
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL SPBSTF , SSBGST , SSBTRD , SSTEQR , SSTERF , XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      wantz = LSAME(Jobz,'V')
      upper = LSAME(Uplo,'U')
!
      Info = 0
      IF ( .NOT.(wantz .OR. LSAME(Jobz,'N')) ) THEN
         Info = -1
      ELSEIF ( .NOT.(upper .OR. LSAME(Uplo,'L')) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Ka<0 ) THEN
         Info = -4
      ELSEIF ( Kb<0 .OR. Kb>Ka ) THEN
         Info = -5
      ELSEIF ( Ldab<Ka+1 ) THEN
         Info = -7
      ELSEIF ( Ldbb<Kb+1 ) THEN
         Info = -9
      ELSEIF ( Ldz<1 .OR. (wantz .AND. Ldz<N) ) THEN
         Info = -12
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSBGV ',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Form a split Cholesky factorization of B.
!
      CALL SPBSTF(Uplo,N,Kb,Bb,Ldbb,Info)
      IF ( Info/=0 ) THEN
         Info = N + Info
         RETURN
      ENDIF
!
!     Transform problem to standard eigenvalue problem.
!
      inde = 1
      indwrk = inde + N
      CALL SSBGST(Jobz,Uplo,N,Ka,Kb,Ab,Ldab,Bb,Ldbb,Z,Ldz,Work(indwrk), &
     &            iinfo)
!
!     Reduce to tridiagonal form.
!
      IF ( wantz ) THEN
         vect = 'U'
      ELSE
         vect = 'N'
      ENDIF
      CALL SSBTRD(vect,Uplo,N,Ka,Ab,Ldab,W,Work(inde),Z,Ldz,Work(indwrk)&
     &            ,iinfo)
!
!     For eigenvalues only, call SSTERF.  For eigenvectors, call SSTEQR.
!
      IF ( .NOT.wantz ) THEN
         CALL SSTERF(N,W,Work(inde),Info)
      ELSE
         CALL SSTEQR(Jobz,N,W,Work(inde),Z,Ldz,Work(indwrk),Info)
      ENDIF
!
!     End of SSBGV
!
      END SUBROUTINE SSBGV


MODULE module_bl_fogdes

  USE module_model_constants
  USE module_bl_mynn, only: qcgmin, gno, gpw

  IMPLICIT NONE

CONTAINS

  SUBROUTINE bl_fogdes(&
               vdfg,qc_curr,dtbl,rho,dz8w,grav_settling,dqc, &
               ids,ide, jds,jde, kds,kde, &
               ims,ime, jms,jme, kms,kme, &
               its,ite, jts,jte, kts,kte &
                                                                   )
   INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme &
                                               ,its,ite,jts,jte,kts,kte &
                                               ,ids,ide,jds,jde,kds,kde
   INTEGER, INTENT(IN) :: grav_settling
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
                                       INTENT(IN),OPTIONAL :: qc_curr
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
                                       INTENT(IN) :: rho
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
                                       INTENT(IN ) :: dz8w
   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN),OPTIONAL :: vdfg
   REAL, INTENT(INOUT),OPTIONAL :: dtbl
   REAL,parameter :: gpw2=0.66666666666667
   REAL :: gfluxp,gfluxm
   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), &
                                       INTENT(INOUT),OPTIONAL :: dqc
   INTEGER :: i,j,k,grav_settling2
  grav_settling2 = MIN(REAL(grav_settling), 1.)
   DO j=jts,jte
     DO i=its,ite
       k=kts
       IF (qc_curr(i,k,j) > qcgmin) THEN
          gfluxm=grav_settling2*qc_curr(i,k,j)*vdfg(i,j)
       ELSE
          gfluxm=0.
       ENDIF
       IF (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)) > qcgmin) THEN
          gfluxp=grav_settling2*gno* &
                & (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)))**gpw
       ELSE
          gfluxp=0.
       ENDIF
       dqc(i,k,j)=(gfluxp - gfluxm)/dz8w(i,kts,j)*dtbl
       DO k=kts+1,kte-1
          IF (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)) > qcgmin) THEN
             gfluxp=grav_settling2*gno* &
                   & (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)))**gpw
          ELSE
             gfluxp=0.
          ENDIF
          IF (.5*(qc_curr(i,k-1,j)+qc_curr(i,k,j)) > qcgmin) THEN
             gfluxm=grav_settling2*gno* &
                   & (.5*(qc_curr(i,k-1,j)+qc_curr(i,k,j)))**gpw
          ELSE
             gfluxm=0.
          ENDIF
          dqc(i,k,j)=(gfluxp - gfluxm)/dz8w(i,kts,j)*dtbl
       ENDDO
       dqc(i,kte,j)=0.
     ENDDO
   ENDDO
  END SUBROUTINE bl_fogdes
END MODULE module_bl_fogdes


      function RD(m_N, tau, taup, term, j_chi, coupling_Array)
      implicit none
      double precision :: RD, m_N, j_chi
      double precision :: coupling_Array(14,2)
      integer :: tau,taup
      integer :: term
      integer :: c, q2
      double precision :: c5, c5p
      double precision :: c8, c8p
c
      c = 0
      q2 = 2
c
      c5 = coupling_Array(4,tau)
      c5p = coupling_Array(4,taup)
      c8 = coupling_Array(7,tau)
      c8p = coupling_Array(7,taup)
c
      if (term.eq.c) then
         RD = (j_chi*(j_chi+1))/3. * c8*c8p
      else if (term.eq.q2) then
         RD = 1/m_N**2 * (j_chi*(j_chi+1))/3. * c5*c5p
      else
         RD = 0.
      end if
c
      end function RD


      INCLUDE 'VICMAIN_FOR'
C
C     MODIFIED FOR VAX CONVERSION BY ALAN S MAZER, 24 AUGUST 1983
C     MODIFIED TO VICAR2 BY RICH WALKER, 28 AUGUST 1985
C     FIXED BUG WHEN TILT > DEFL
C     MODIFIED FOR NON-BYTE DATA
C     CONVERTED TO UNIX VICAR  4/18/91 Ron Alley
C     Modified to handle multichannel (BSQ, BIL) datasets  1/24/97  Ron Alley
C**********************************************************************
      SUBROUTINE MAIN44
      LOGICAL XVPTST
      REAL PI/3.1415927/
      REAL RBUF(8000),OBUFR(32000),FRAC(32000)
      INTEGER ADDR(32000)
      CHARACTER*80 PRT
      CHARACTER*4 FORMAT
      CHARACTER *3 ORG
C
      CALL XVMESSAGE(' C130RECT VERSION 2.1',' ')
C							 OPEN THE INPUT DATA SET
      CALL XVUNIT(INP,'INP',1,ISTAT,' ')
      CALL XVOPEN(INP,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',
     +		      'U_FORMAT','REAL',' ')
      CALL XVGET(INP,ISTAT,'FORMAT',FORMAT,' ')
      CALL XVGET(INP,ISTAT,'ORG',ORG,' ')
      CALL XVSIZE(ISL,ISS,NLO,NS,NLI,NSI)
      CALL XVBANDS(ISB,NB,NBIN)
C
      IF (ORG .EQ. 'BIP') THEN
	 CALL XVMESSAGE(' BIP files are not currently supported',' ')
	 CALL ABEND
      ENDIF
C
      IF(ISS.NE.1) THEN
       CALL XVMESSAGE(' Starting sample must be 1',' ')
       CALL XVMESSAGE(' Resetting starting sample to 1',' ')
       ISS = 1
      ENDIF
      IF(NS.NE.0.AND.NS.NE.NSI) THEN
       CALL XVMESSAGE(' Number of samples must be entire input image',
     +			' ')
       CALL XVMESSAGE(' Resetting number of samples to entire input',
     +			' ')
       NS = NSI
      ENDIF
C
      IEL = ISL + NLO - 1
C
      IF(IEL.GT.NLI) THEN
	 CALL XVMESSAGE(
     +	     ' Size field NL specified overruns file dimensions',' ')
	 CALL ABEND
      ENDIF
C
C						        GET THE PARAMETERS
      CALL XVPARM('DEFL',DEFL,ICNT,IDEF,0)
      CALL XVPARM('TILT',TILT,ICNT,IDEF,0)
      CALL XVPARM('SCALE',SCALE,ICNT,IDEF,0)
C						        VERIFY THE PARAMETERS
      IF(DEFL.GT.85.)  DEFL= 85.
      WRITE (PRT,100) DEFL+0.0001
  100 FORMAT('.... DEFL=',F5.2,' DEG.')
      CALL XVMESSAGE(PRT,' ')
      WRITE (PRT,200) SCALE+0.0001
  200 FORMAT('.... SCALE=',F5.2)
      CALL XVMESSAGE(PRT,' ')
      IF (TILT.NE.0.) THEN
          WRITE (PRT,300) TILT+0.0001
  300     FORMAT('.... TILT=',F5.2,' DEG.')
          CALL XVMESSAGE(PRT,' ')
      END IF
      DEFL= DEFL*PI/180.0
      TILT = TILT*PI/180.0
C
      IF (TILT.NE.0.) THEN
          SMAX = NS
          H = (SMAX/(DEFL*2))*SCALE
          HH = H*COS(TILT)
          XMAX1 = HH*TAN(DEFL+TILT)
          XMAX2 = HH*TAN(DEFL-TILT)
          IMAX1 = XMAX1 + 0.5
          THETA = DEFL+TILT
          XMAX = XMAX1 + XMAX2
          IMAX = XMAX + 0.5
          NSO = XMAX+1.5
      ELSE
          R= NS
          SMAX= (R-1.)/2.
          H = (SMAX/DEFL)*SCALE
          XMAX= H*TAN(DEFL)
          NSO= 2.*XMAX+1.5
      END IF
C
      WRITE (PRT,400) NLO,NSO
  400 FORMAT('.... OUTPUT    NL=',I5,'   NS=',I5)
      CALL XVMESSAGE(PRT,' ')
      IF(NSO.GT.32000) THEN
	 CALL XVMESSAGE(' $$$ TOO MANY OUTPUT SAMPLES $$$',' ')
	 CALL ABEND
      ENDIF
C						        OPEN THE OUTPUT DATA SET
      CALL XVUNIT(OUT,'OUT',1,ISTAT,' ')
      CALL XVOPEN(OUT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA','LAB_ACT',
     +   'SA','U_NL',NLO,'U_NS',NSO,'OP','WRITE','U_FORMAT','REAL',' ')
C					      LOAD THE RESAMPLING ADDRESS BUFFER
      IF (TILT.NE.0) THEN
	  KK = MIN(NSO,IMAX1)
          DO J=1,KK
              R = J - 1
              S = H*ATAN((R+XMAX2-XMAX)/HH)+THETA*H
              IF (S.LT.0) S = 0.
              S = S/SCALE
              ADDR(J) = S
	      FRAC(J) = S - ADDR(J)
              ADDR(J) = ADDR(J) + 1
	  END DO
          KK = MAX(IMAX1+1,1)
          DO J = KK,IMAX
              R=J-1
              S=H*ATAN((R-XMAX1)/HH)+THETA*H
              S = S/SCALE
              IF (S.LT.0) S=0.
              ADDR(J) = S
	      FRAC(J) = S - ADDR(J)
              ADDR(J) = ADDR(J) + 1
 	  END DO
      ELSE
          DO J=1,NSO
              R= J-1
              X= R-XMAX
              THETA= ATAN(X/H)
              S = THETA*H/SCALE+SMAX
              IF(S.LT.0.)  S= 0.
              ADDR(J) = S
	      FRAC(J) = S - ADDR(J)
              ADDR(J) = ADDR(J) + 1
	  END DO
      END IF
C						 DUMP THE RESAMPLING ADDR BUFFER
      IF(XVPTST('DEBUG')) THEN
          CALL XVMESSAGE(' OUTPUT    INPUT',' ')
          DO J=1,NSO
              WRITE (PRT,500) J, ADDR(J)+FRAC(J)
  500         FORMAT(I5,F12.4)
              CALL XVMESSAGE(PRT,' ')
	  END DO
      END IF
C				    RESAMPLE EACH LINE TO CORRECT THE DISTORTION
      IF (ORG .EQ. 'BSQ') THEN
        IF (FORMAT.EQ.'REAL') THEN
          DO IB=1,NB
	    DO ILINE=ISL,IEL
              CALL XVREAD(INP,RBUF,ISTAT,'LINE',ILINE,'BAND',IB,
     +                    'NSAMPS',NS,' ')
              RBUF(NS+1) = RBUF(NS)
              DO I=1,NSO
                OBUFR(I) = (1.0-FRAC(I))*RBUF(ADDR(I)) +
     +                        FRAC(I)*RBUF(ADDR(I)+1)
              END DO
	      CALL XVWRIT(OUT,OBUFR,ISTAT,'NSAMPS',NSO,' ')
            END DO
	  END DO
        ELSE
          DO IB=1,NB
	    DO ILINE=ISL,IEL
              CALL XVREAD(INP,RBUF,ISTAT,'LINE',ILINE,'BAND',IB,
     +                    'NSAMPS',NS,' ')
              RBUF(NS+1) = RBUF(NS)
              DO I=1,NSO
                OBUFR(I) = NINT( (1.0-FRAC(I))*RBUF(ADDR(I))
     +                            + FRAC(I)*RBUF(ADDR(I)+1))
              END DO
	      CALL XVWRIT(OUT,OBUFR,ISTAT,'NSAMPS',NSO,' ')
            END DO
          END DO
	END IF
      ELSE
        IF (FORMAT.EQ.'REAL') THEN
	  DO ILINE=ISL,IEL
            DO IB=1,NB
              CALL XVREAD(INP,RBUF,ISTAT,'LINE',ILINE,'BAND',IB,
     +                    'NSAMPS',NS,' ')
              RBUF(NS+1) = RBUF(NS)
              DO I=1,NSO
                OBUFR(I) = (1.0-FRAC(I))*RBUF(ADDR(I)) +
     +                        FRAC(I)*RBUF(ADDR(I)+1)
              END DO
	      CALL XVWRIT(OUT,OBUFR,ISTAT,'NSAMPS',NSO,' ')
	    END DO
          END DO
        ELSE
	  DO ILINE=ISL,IEL
            DO IB=1,NB
              CALL XVREAD(INP,RBUF,ISTAT,'LINE',ILINE,'BAND',IB,
     +                    'NSAMPS',NS,' ')
              RBUF(NS+1) = RBUF(NS)
              DO I=1,NSO
                OBUFR(I) = NINT( (1.0-FRAC(I))*RBUF(ADDR(I))
     +                            + FRAC(I)*RBUF(ADDR(I)+1))
              END DO
	      CALL XVWRIT(OUT,OBUFR,ISTAT,'NSAMPS',NSO,' ')
	    END DO
          END DO
        END IF
      END IF
      RETURN
      END


      SUBROUTINE PHO_GET4VECTORS(Ipdgs1,Ipdgs2,Sqs,P1,P2)
C*********************************************************************

C     Generates two 4-vectors p1/2 in center of mass frame

C     input:   ipdgs1   PDG particle code side 1
C              ipdgs2   PDG particle code side 2
C              sqs      center of mass energy
C
C     output:  p1       particle 4-vector side 1
C              p2       particle 4-vector side 2

C*********************************************************************
      IMPLICIT NONE

      DOUBLE PRECISION Sqs , s , ee , pcm , P1(4) , P2(4) , pm1 , pm2 ,
     &                 PHO_PMASS
      INTEGER Ipdgs1 , Ipdgs2

      s = Sqs**2
      pm1 = PHO_PMASS(Ipdgs1,1)**2
      pm2 = PHO_PMASS(Ipdgs2,1)**2
      pcm = SQRT(s**2-2.D0*pm1*s-2.D0*pm2*s-2.D0*pm1*pm2+pm1**2+pm2**2)
     &      /(2.D0*Sqs)
      ee = SQRT(pm1+pcm**2)
      P1(1) = 0.0D0
      P1(2) = 0.0D0
      P1(3) = pcm
      P1(4) = ee
      P2(1) = 0.0D0
      P2(2) = 0.0D0
      P2(3) = -pcm
      P2(4) = Sqs - ee

      END SUBROUTINE


C File: arrays-constr-01.f
C This program has a simple 1-D array with the default lower bound of 1.
C It shows the use of an array constructor to initialize the array.

      program main
      implicit none

C     arr is a 1-D array of integers with an implicit lower-bound = 1
C     and an upper bound of 10.
      integer, dimension(10) :: arr
      integer :: i

C     array constructor I -- scalar expression
      arr = (/11,22,33,44,55,66,77,88,99,110/)

      do i = 1, 10
          write (*,10) arr(i)
      end do

 10   format(I5)

      stop
      end program main


!*****************************************************************************
!
! Different implementations of a simple single precision A-X plus Y function
! on a CPU and GPU, to verify this code works.
!
! x = ax + y
! x,y,z: vector
! a: scalar
!*****************************************************************************

!*****************************************************************************
! Kernels
!*****************************************************************************

module saxpy_openmp_kernels_mod
contains

subroutine print_thread_info
   integer :: myid, nthreads
   integer :: OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM

   !$OMP PARALLEL default(none) private(myid) &
   !$OMP shared(nthreads)

   ! Determine number of threads and their id
   myid = OMP_GET_THREAD_NUM()
   nthreads = OMP_GET_NUM_THREADS();

   !$OMP BARRIER

   if (myid == 0) then
      print *,'nthreads=', nthreads
   end if

   !$OMP END PARALLEL
end subroutine print_thread_info

!*****************************************************************************
! CPU parallel (openmp)
!*****************************************************************************
subroutine saxpy_cpu_openmp_kernel(n, a, x, y)
   real :: x(:), y(:), a
   integer :: n, i

!$omp parallel do
   do i=1,n
      y(i) = a*x(i)+y(i)
   end do
!$omp end parallel do

end subroutine saxpy_cpu_openmp_kernel

!*****************************************************************************
! GPU parallel (openmp 4.5)
!*****************************************************************************
subroutine saxpy_gpu_openmp_kernel(n, a, x, y)
   real :: x(:), y(:), a
   integer :: n, i

!$omp target
!$omp parallel do
   do i=1,n
      y(i) = a*x(i)+y(i)
   end do
!$omp end parallel do
!$omp end target

end subroutine saxpy_gpu_openmp_kernel

end module saxpy_openmp_kernels_mod


      SUBROUTINE eclass(nf,n,lista,listb,m)
      INTEGER m,n,lista(m),listb(m),nf(n)
      INTEGER j,k,l
      do 11 k=1,n
        nf(k)=k
11    continue
      do 12 l=1,m
        j=lista(l)
1       if(nf(j).ne.j)then
          j=nf(j)
        goto 1
        endif
        k=listb(l)
2       if(nf(k).ne.k)then
          k=nf(k)
        goto 2
        endif
        if(j.ne.k)nf(j)=k
12    continue
      do 13 j=1,n
3       if(nf(j).ne.nf(nf(j)))then
          nf(j)=nf(nf(j))
        goto 3
        endif
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/eclass.for


program ch0704
    ! Average of Three Sets of Values
    implicit none

    integer, parameter :: n = 3
    integer :: lat, long
    real, dimension(1:n,1:n) :: h1, h2, h3, h4

    do lat = 1, n
        read *, (h1(lat,long), long = 1, n)
    end do
    do lat = 1, n
        read *, (h2(lat,long), long = 1, n)
    end do
    do lat = 1, n
        read *, (h3(lat,long), long = 1, n)
    end do

    do lat = 1, n
        do long = 1, n
            h4(lat,long) = (h1(lat,long)+&
                h2(lat,long)+&
                h3(lat,long))/3
        end do
    end do

    do lat = 1, n
        print *, (h4(lat,long), long = 1, n)
    end do
end program


module formal
use iso_c_binding, only : c_double, c_int
implicit none
	real(c_double), parameter, dimension(4,4) :: identity = reshape((/1.d0,0.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,0.d0,1.d0/), (/4,4/))

contains
! ---------------------------------------------------------
! Performs the formal solution of the RT equation for a plane-parallel magnetized atmosphere
! for a given source function and opacity
! ---------------------------------------------------------
	subroutine c_delopar_source(n, height, opacity, source, boundary, stokesOut) bind(c)
	integer(c_int), intent(in) :: n
	real(c_double), intent(in), dimension(n) :: height
	real(c_double), intent(in), dimension(7,n) :: opacity
	real(c_double), intent(in), dimension(n) :: source
	real(c_double), intent(in), dimension(4) :: boundary
	real(c_double), intent(out), dimension(4) :: stokesOut

	real(c_double) :: formal_sol_polarized(4), Inten(4)
	integer(c_int) :: k, km, kp, k0, kf
	real(c_double) :: chim, chi0, chip, dtp, dtm, exu
	real(c_double) :: psim, psi0, psip, psim_lin, psi0_lin, dm, dp

	integer(c_int) :: i, j
	real(c_double), allocatable :: ab_matrix(:,:,:), source_vector(:,:)
	real(c_double) :: sm(4), s0(4), sp(4), mat1(4,4), mat2(4,4), mat3(4,4)

		allocate(ab_matrix(4,4,n))
		allocate(source_vector(4,n))

		call fill_matrix(opacity,ab_matrix)

! Transform K into K* and then into K'
		do i = 1, 4
			do j = 1, 4
				ab_matrix(i,j,:) = ab_matrix(i,j,:) / opacity(1,:)
			enddo
			ab_matrix(i,i,:) = ab_matrix(i,i,:) - 1.d0
			source_vector(i,:) = opacity(i,:) * source / opacity(1,:)
		enddo

! Boundary condition
		k0 = 2
		kf = n
		Inten = boundary

		do k = k0, kf

! Parabolic short-characteristics
			if (k /= kf) then
				km = k - 1
				kp = k + 1
				chim = opacity(1,km)
				chi0 = opacity(1,k)
				chip = opacity(1,kp)
				sm = source_vector(:,km)
				s0 = source_vector(:,k)
				sp = source_vector(:,kp)
				dm = dabs((height(k) - height(km)))
				dp = dabs((height(kp) - height(k)))
			else
! Linear short-characteristics
				km = k - 1
				chim = opacity(1,km)
				chi0 = opacity(1,k)
				chip = 0.d0
				sm = source_vector(:,km)
				s0 = source_vector(:,k)
				sp = 0.d0
				dm = dabs((height(k) - height(km)))
				dp = 0.d0
			endif

			dtm = 0.5d0 * (chim + chi0) * dm
			dtp = 0.5d0 * (chi0 + chip) * dp

			if (dtm >= 1.d-4) then
				exu = dexp(-dtm)
			else
				exu = 1.d0 - dtm + 0.5d0 * dtm**2.d0
			endif

			call lin_sc(dtm,psim_lin,psi0_lin)
			mat1 = exu * identity - psim_lin*ab_matrix(:,:,km)
			mat2 = identity + psi0_lin * ab_matrix(:,:,k)
			call invert(mat2)

			if (k /= kf) then
				call par_sc(dtm,dtp,psim,psi0,psip)
				Inten = matmul(mat2,matmul(mat1,Inten) + psim*sm + psi0*s0 + psip*sp)
			else
				call lin_sc(dtm,psim,psi0)
				Inten = matmul(mat2,matmul(mat1,Inten) + psim*sm + psi0*s0)
			endif

		enddo

		deallocate(ab_matrix)
		deallocate(source_vector)

		stokesOut = Inten

	end subroutine c_delopar_source

! ---------------------------------------------------------
! Performs the formal solution of the RT equation for a plane-parallel magnetized atmosphere
! for a given source function and opacity
! ---------------------------------------------------------
	subroutine c_delopar(n, height, opacity, emissivity, boundary, stokesOut) bind(c)
	integer(c_int), intent(in) :: n
	real(c_double), intent(in), dimension(n) :: height
	real(c_double), intent(in), dimension(7,n) :: opacity
	real(c_double), intent(in), dimension(4,n) :: emissivity
	real(c_double), intent(in), dimension(4) :: boundary
	real(c_double), intent(out), dimension(4) :: stokesOut

	real(c_double) :: formal_sol_polarized(4), Inten(4)
	integer(c_int) :: k, km, kp, k0, kf
	real(c_double) :: chim, chi0, chip, dtp, dtm, exu
	real(c_double) :: psim, psi0, psip, psim_lin, psi0_lin, dm, dp

	integer(c_int) :: i, j
	real(c_double), allocatable :: ab_matrix(:,:,:), source_vector(:,:)
	real(c_double) :: sm(4), s0(4), sp(4), mat1(4,4), mat2(4,4), mat3(4,4)

		allocate(ab_matrix(4,4,n))
		allocate(source_vector(4,n))

		call fill_matrix(opacity,ab_matrix)

! Transform K into K* and then into K'
		do i = 1, 4
			do j = 1, 4
				ab_matrix(i,j,:) = ab_matrix(i,j,:) / opacity(1,:)
			enddo
			ab_matrix(i,i,:) = ab_matrix(i,i,:) - 1.d0
			source_vector(i,:) = emissivity(i,:) / opacity(1,:)
		enddo

! Boundary condition
		k0 = 2
		kf = n
		Inten = boundary

		do k = k0, kf

! Parabolic short-characteristics
			if (k /= kf) then
				km = k - 1
				kp = k + 1
				chim = opacity(1,km)
				chi0 = opacity(1,k)
				chip = opacity(1,kp)
				sm = source_vector(:,km)
				s0 = source_vector(:,k)
				sp = source_vector(:,kp)
				dm = dabs((height(k) - height(km)))
				dp = dabs((height(kp) - height(k)))
			else
! Linear short-characteristics
				km = k - 1
				chim = opacity(1,km)
				chi0 = opacity(1,k)
				chip = 0.d0
				sm = source_vector(:,km)
				s0 = source_vector(:,k)
				sp = 0.d0
				dm = dabs((height(k) - height(km)))
				dp = 0.d0
			endif

			dtm = 0.5d0 * (chim + chi0) * dm
			dtp = 0.5d0 * (chi0 + chip) * dp

			if (dtm >= 1.d-4) then
				exu = dexp(-dtm)
			else
				exu = 1.d0 - dtm + 0.5d0 * dtm**2.d0
			endif

			call lin_sc(dtm,psim_lin,psi0_lin)
			mat1 = exu * identity - psim_lin*ab_matrix(:,:,km)
			mat2 = identity + psi0_lin * ab_matrix(:,:,k)
			call invert(mat2)

			if (k /= kf) then
				call par_sc(dtm,dtp,psim,psi0,psip)
				Inten = matmul(mat2,matmul(mat1,Inten) + psim*sm + psi0*s0 + psip*sp)
			else
				call lin_sc(dtm,psim,psi0)
				Inten = matmul(mat2,matmul(mat1,Inten) + psim*sm + psi0*s0)
			endif

		enddo

		deallocate(ab_matrix)
		deallocate(source_vector)

		stokesOut = Inten

	end subroutine c_delopar

!--------------------------------------------------------------
! Inversion of a 4x4 matrix
!--------------------------------------------------------------
	subroutine invert(a)
	real(c_double) :: a(4,4)
	real(c_double) :: b(4,4), det, maxim, fabsmax
	! First some tests of singularity
		b = dabs(a)
		maxim = maxval(b)
		fabsmax = 1.d0 / maxim
		if (maxim == 0.d0) then
			print *, 'Singularity in the inversion'
!			stop
		endif

		a = a * fabsmax

   	b(1,1) = a(2,2) * a(3,3) * a(4,4) + a(2,3) * a(3,4) * a(4,2)&
      	+ a(2,4) * a(3,2) * a(4,3) - a(2,2) * a(3,4) * a(4,3)&
	   	- a(2,3) * a(3,2) * a(4,4) - a(2,4) * a(3,3) * a(4,2)
   	b(2,1) = a(2,3) * a(3,1) * a(4,4) + a(2,4) * a(3,3) * a(4,1)&
	   	+ a(2,1) * a(3,4) * a(4,3) - a(2,3) * a(3,4) * a(4,1)&
   		- a(2,4) * a(3,1) * a(4,3) - a(2,1) * a(3,3) * a(4,4)
   	b(3,1) = a(2,4) * a(3,1) * a(4,2) + a(2,1) * a(3,2) * a(4,4)&
	   	+ a(2,2) * a(3,4) * a(4,1) - a(2,4) * a(3,2) * a(4,1)&
   		- a(2,1) * a(3,4) * a(4,2) - a(2,2) * a(3,1) * a(4,4)
   	b(4,1) = a(2,1) * a(3,3) * a(4,2) + a(2,2) * a(3,1) * a(4,3)&
	   	+ a(2,3) * a(3,2) * a(4,1) - a(2,1) * a(3,2) * a(4,3)&
   		- a(2,2) * a(3,3) * a(4,1) - a(2,3) * a(3,1) * a(4,2)
   	b(1,2) = a(3,2) * a(4,4) * a(1,3) + a(3,3) * a(4,2) * a(1,4)&
	   	+ a(3,4) * a(4,3) * a(1,2) - a(3,2) * a(4,3) * a(1,4)&
   		- a(3,3) * a(4,4) * a(1,2) - a(3,4) * a(4,2) * a(1,3)
   	b(2,2) = a(3,3) * a(4,4) * a(1,1) + a(3,4) * a(4,1) * a(1,3)&
	   	+ a(3,1) * a(4,3) * a(1,4) - a(3,3) * a(4,1) * a(1,4)&
   		- a(3,4) * a(4,3) * a(1,1) - a(3,1) * a(4,4) * a(1,3)
   	b(3,2) = a(3,4) * a(4,2) * a(1,1) + a(3,1) * a(4,4) * a(1,2)&
	   	+ a(3,2) * a(4,1) * a(1,4) - a(3,4) * a(4,1) * a(1,2)&
   		- a(3,1) * a(4,2) * a(1,4) - a(3,2) * a(4,4) * a(1,1)
   	b(4,2) = a(3,1) * a(4,2) * a(1,3) + a(3,2) * a(4,3) * a(1,1)&
	   	+ a(3,3) * a(4,1) * a(1,2) - a(3,1) * a(4,3) * a(1,2)&
   		- a(3,2) * a(4,1) * a(1,3) - a(3,3) * a(4,2) * a(1,1)
   	b(1,3) = a(4,2) * a(1,3) * a(2,4) + a(4,3) * a(1,4) * a(2,2)&
   		+ a(4,4) * a(1,2) * a(2,3) - a(4,2) * a(1,4) * a(2,3)&
	   	- a(4,3) * a(1,2) * a(2,4) - a(4,4) * a(1,3) * a(2,2)
   	b(2,3) = a(4,3) * a(1,1) * a(2,4) + a(4,4) * a(1,3) * a(2,1)&
	   	+ a(4,1) * a(1,4) * a(2,3) - a(4,3) * a(1,4) * a(2,1)&
   		- a(4,4) * a(1,1) * a(2,3) - a(4,1) * a(1,3) * a(2,4)
   	b(3,3) = a(4,4) * a(1,1) * a(2,2) + a(4,1) * a(1,2) * a(2,4)&
	   	+ a(4,2) * a(1,4) * a(2,1) - a(4,4) * a(1,2) * a(2,1)&
   		- a(4,1) * a(1,4) * a(2,2) - a(4,2) * a(1,1) * a(2,4)
   	b(4,3) = a(4,1) * a(1,3) * a(2,2) + a(4,2) * a(1,1) * a(2,3)&
	   	+ a(4,3) * a(1,2) * a(2,1) - a(4,1) * a(1,2) * a(2,3)&
   		- a(4,2) * a(1,3) * a(2,1) - a(4,3) * a(1,1) * a(2,2)
   	b(1,4) = a(1,2) * a(2,4) * a(3,3) + a(1,3) * a(2,2) * a(3,4)&
	   	+ a(1,4) * a(2,3) * a(3,2) - a(1,2) * a(2,3) * a(3,4)&
   		- a(1,3) * a(2,4) * a(3,2) - a(1,4) * a(2,2) * a(3,3)
   	b(2,4) = a(1,3) * a(2,4) * a(3,1) + a(1,4) * a(2,1) * a(3,3)&
	   	+ a(1,1) * a(2,3) * a(3,4) - a(1,3) * a(2,1) * a(3,4)&
   		- a(1,4) * a(2,3) * a(3,1) - a(1,1) * a(2,4) * a(3,3)
   	b(3,4) = a(1,4) * a(2,2) * a(3,1) + a(1,1) * a(2,4) * a(3,2)&
	   	+ a(1,2) * a(2,1) * a(3,4) - a(1,4) * a(2,1) * a(3,2)&
   		- a(1,1) * a(2,2) * a(3,4) - a(1,2) * a(2,4) * a(3,1)
   	b(4,4) = a(1,1) * a(2,2) * a(3,3) + a(1,2) * a(2,3) * a(3,1)&
	   	+ a(1,3) * a(2,1) * a(3,2) - a(1,1) * a(2,3) * a(3,2)&
   		- a(1,2) * a(2,1) * a(3,3) - a(1,3) * a(2,2) * a(3,1)

		det = a(1,1) * b(1,1) + a(1,2) * b(2,1) + a(1,3) * b(3,1) + a(1,4) * b(4,1)

		a = b * (fabsmax / det)

	end subroutine invert

!----------------------------------------------------------------
! Given the values of the Zeeman opacities, fill the absorption matrix
! for each depth point
!----------------------------------------------------------------
		subroutine fill_matrix(opacity,ab_matrix)
		real(c_double) :: opacity(:,:), ab_matrix(:,:,:)

			ab_matrix(1,1,:) = opacity(1,:)   !eta_I
			ab_matrix(2,2,:) = opacity(1,:)   !eta_I
			ab_matrix(3,3,:) = opacity(1,:)   !eta_I
			ab_matrix(4,4,:) = opacity(1,:)   !eta_I
			ab_matrix(1,2,:) = opacity(2,:)   !eta_Q
			ab_matrix(2,1,:) = opacity(2,:)   !eta_Q
			ab_matrix(1,3,:) = opacity(3,:)   !eta_U
			ab_matrix(3,1,:) = opacity(3,:)   !eta_U
			ab_matrix(1,4,:) = opacity(4,:)   !eta_V
			ab_matrix(4,1,:) = opacity(4,:)   !eta_V
			ab_matrix(2,3,:) = opacity(7,:)   !rho_V
			ab_matrix(3,2,:) = -opacity(7,:)  !-rho_V
			ab_matrix(2,4,:) = -opacity(6,:)  !-rho_U
			ab_matrix(4,2,:) = opacity(6,:)   !rho_U
			ab_matrix(3,4,:) = opacity(5,:)   !rho_Q
			ab_matrix(4,3,:) = -opacity(5,:)  !-rho_Q

		end subroutine fill_matrix

! ---------------------------------------------------------
! Solves RTE using short-characteristics. Source function is supposed to vary parabolically
! between points M, O and P and RTE is integrated analitically, resulting in
!            I(O)=I(M)*exp(-tau(MO))+psi(M)*S(M)+psi(O)*S(O)+psi(P)*S(P)
! where psi are functions of the optical distance tau(MO) and tau(OP)
! It returns the value of the three psi coefficients
! ---------------------------------------------------------
   subroutine par_sc(dtm, dtp, psim, psi0, psip)
   real(c_double) :: short_car_parab
   real(c_double), INTENT(IN) :: dtm, dtp
	real(c_double), INTENT(INOUT) :: psim, psi0, psip
   real(c_double) :: exu, u0, u1 ,u2, d2, d3, d4

         if (dtm.ge.1.d-4) then
            exu=dexp(-dtm)
            u0=1.d0-exu
            u1=dtm-1.d0+exu
            u2=dtm**2-2.d0*dtm+2.d0-2.d0*exu
         else
            d2=dtm**2
            d3=dtm**3
            d4=dtm**4
            u0=dtm-(d2/2.d0)
            u1=(d2/2.d0)-(d3/6.d0)
            u2=(d3/3.d0)-(d4/12.d0)
        endif

        if (dtm * dtp /= 0.d0 .and. dtm**2 /= 0.d0 .and. dtp**2 /= 0.d0) then
			  psim=(u2-u1*(dtp+2.d0*dtm))/(dtm*(dtm+dtp))+u0
      	  psi0=(u1*(dtm+dtp)-u2)/(dtm*dtp)
      	  psip=(u2-dtm*u1)/(dtp*(dtm+dtp))
	 	  else
		  	  psim = 0.d0
			  psi0 = 0.d0
			  psip = 0.d0
		  endif

   end subroutine par_sc

  ! ---------------------------------------------------------
! Solves RTE using short-characteristics. Source function is supposed to vary linearly
! between points M and O and RTE is integrated analitically, resulting in
!            I(O)=I(M)*exp(-tau(MO))+psi(M)*S(M)+psi(O)*S(O)
! where psi are functions of the optical distance tau(MO)
! It returns the value of the two psi coefficients
! ---------------------------------------------------------
   subroutine lin_sc(dtm, psim, psi0)
   real(c_double) :: short_car_linea
   real(c_double), INTENT(IN) :: dtm
	real(c_double), INTENT(INOUT) :: psim, psi0
   real(c_double) :: exu, u0, u1, c0, cm, d2

      if (dtm.ge.1.d-4) then
         exu=dexp(-dtm)
         u0=1.d0-exu
         u1=dtm-1.d0+exu

         c0=u1/dtm
         cm=u0-c0
      else
         d2=dtm**2.d0
         c0=(dtm/2.d0)-(d2/6.d0)
         cm=(dtm/2.d0)-(d2/3.d0)
      endif
		psi0 = c0
		psim = cm

   end subroutine lin_sc

end module formal


module vd1d_mms_mod_table
    !====================================================================
    ! This module made for Moin problem1 like vd1d_mms_mod,
    ! but for table values: u, rho, viscZmix are in files
    ! It should be read interpolated
    ! via linear interpolation OR spline method
    !
    ! use moin analitical function is file is not set
    !
    !====================================================================
    use two_column_file_with_x_and_y

    implicit none

    type(file), private :: EOS_of_Zmix
    type(file), private :: Visc_Dyn_of_Zmix
    type(file), private :: Zmix_SRC_of_Zmix
    type(file), private :: rho
    type(file), private :: velocity
    type(file), private :: Zmix
    type(file), private :: VISc_Dyn
    type(file), private :: press

    ! moin 1 problem analitycal parameters
    real, parameter     :: pi = 3.1415926535897932
    integer, private    :: Moin_Problem_ID
    real, private       :: rho0, rho1, k1, k2, w0, D, r01, k12, k21
    real, private       :: k, w, mu, uf

    !functions
    public :: vd1d_mms_init
    public :: moin_table_EOS
    public :: vd2d_mms_u
    public :: vd2d_mms_rho
    public :: vd2d_mms_z
    public :: moin_table_visc_dyn_of_x
    public :: moin_table_visc_dyn_of_Z
    public :: vd2d_mms_z_src
    public :: vd2d_mms_v
    public :: vd2d_mms_p
    public :: vd2d_mms_u_src
    public :: vd2d_mms_v_src
!————————————————————————————————————————————————————————————————————————————————————————
contains
!————————————————————————————————————————————————————————————————————————————————————————
    subroutine vd1d_mms_init ( &
        Moin_Problem_ID_in, &      ! MoinProblemID
        rho_0, &                ! rho_0
        rho_1, &                ! rho_1
        VIS, &                  ! diff
        VISZmix, &              ! visc
        ! candera tables
        EOS_of_Zmix_in, &       ! rho = EOS(Z)
        Visc_Dyn_of_Zmix_in, &  ! visc_dyn(Z)
        Zmix_SRC_of_Zmix_in, &  ! Z_Source(Z)
        ! initial field files
        vel_init_in, &          ! initial u(x)
        rho_init_in, &          ! initial rho(x)
        Zmix_init_in, &         ! initial Z(x)
        Visc_dyn_init_in, &     ! initial VISc_Dyn(x)
        pressure_init_in &     ! initial pressure(x)
        )

        use par_mod
        implicit none

        integer :: Moin_Problem_ID_in
        real    :: rho_0, rho_1, VIS, VISZmix
        character (*), optional, intent (in) :: EOS_of_Zmix_in, Visc_Dyn_of_Zmix_in, Zmix_SRC_of_Zmix_in
        character (*), optional, intent (in) :: vel_init_in, rho_init_in, Zmix_init_in, Visc_dyn_init_in, pressure_init_in

225     format (" # Moin problem table mod: Initialization: ", A)

        Moin_Problem_ID = Moin_Problem_ID_in

        ! init parameters like in Moin paper
        select case( Moin_Problem_ID )
        case (10)
            k1 = 4.0
            k2 = 2.0
            k12 = k1-k2
            k21 = k2-k1
            rho0 = rho_0
            rho1 = rho_1
            r01 = rho0-rho1
            w0 = 50.0
            D = VIS
        case (30)
            k = 2.0
            w = 2.0
            uf = 0.5
            rho0 = rho_0
            rho1 = rho_1
            mu = VIS
            D = VIS
        end select

        !—————————— EOS_of_Zmix_in
        if ( present(EOS_of_Zmix_in) ) then
            call set_filename(EOS_of_Zmix, EOS_of_Zmix_in)

            if ( (this < 2) .and. file_is_set(EOS_of_Zmix) ) then
                write(*,225) "custom EOS is set by file"
                !call print_info(EOS_of_Zmix)
            end if
        end if

        !—————————— Visc_Dyn_of_Zmix_in
        if ( present(Visc_Dyn_of_Zmix_in) ) then
            call set_filename(Visc_Dyn_of_Zmix, Visc_Dyn_of_Zmix_in)

            if ( (this < 2) .and. file_is_set(Visc_Dyn_of_Zmix) ) then
                write(*,225) "custom molecular viscosity of Zmix is set by file"
                !call print_info(Visc_Dyn_of_Zmix)
            end if
        end if

        !—————————— Zmix_SRC_of_Zmix_in
        if ( present(Zmix_SRC_of_Zmix_in) ) then
            call set_filename(Zmix_SRC_of_Zmix, Zmix_SRC_of_Zmix_in)

            if ( (this < 2) .and. file_is_set(Zmix_SRC_of_Zmix) ) then
                write(*,225) "custom Zmix source is set by file"
                !call print_info(Zmix_SRC_of_Zmix)
            end if
        end if

        !——————————Initial velocity
        if ( present(vel_init_in) ) then
            call set_filename(velocity, vel_init_in)

            if ( (this < 2) .and. file_is_set(velocity) ) then
                write(*,225) "custom initial velocity is set by file"
                !call print_info(velocity)
            end if
        end if

        !——————————Initial density
        if ( present(rho_init_in) ) then
            call set_filename(rho, rho_init_in)

            if ( (this < 2) .and. file_is_set(Visc_Dyn_of_Zmix) ) then
                write(*,225) "custom initial density is rho by file"
                !call print_info(rho)
            end if
        end if

        !——————————Initial Zmix
        if ( present(Zmix_init_in) ) then
            call set_filename(Zmix, Zmix_init_in)

            if ( (this < 2) .and. file_is_set(Zmix) ) then
                write(*,225) "custom initial Zmix is set by file"
                !call print_info(Zmix)
            end if
        end if

        !——————————Initial VISc_Dyn
        if ( present(Visc_dyn_init_in) ) then
            call set_filename(VISc_Dyn, Visc_dyn_init_in)

            if ( (this < 2) .and. file_is_set(VISc_Dyn) ) then
                write(*,225) "custom initial dinamic viscosity is set by file"
                !call print_info(VISc_Dyn)
            end if
        end if

        !——————————Initial Pressure
        if ( present(pressure_init_in) ) then
            call set_filename(press, pressure_init_in)

            if ( (this < 2) .and. file_is_set(press) ) then
                write(*,225) "custom initial pressure is set by file"
                !call print_info(press)
            end if
        end if

    end subroutine vd1d_mms_init
    !————————————————————————————————————————————————————————————————————————————————————————
    function moin_table_EOS (Z)
        implicit none
        real, intent (in) :: Z
        real              :: moin_table_EOS

        if ( file_is_set(EOS_of_Zmix) ) then
            moin_table_EOS = linear_interp(EOS_of_Zmix, Z)
        else
            moin_table_EOS = 1.0 / ( (Z /rho1) + (1.0-Z)/rho0 )
        end if

    end function moin_table_EOS
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_u (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_u
        real              :: u1
        real  :: xt,yt

        if ( file_is_set(velocity) ) then
            vd2d_mms_u = linear_interp(velocity, x) + y*0.0 + t*0.0
        else
            select case( Moin_Problem_ID )
            case(10)
                u1 = exp(w0 * exp (-k2 * t) * abs(x)) + 0.0*y
                vd2d_mms_u = (2.0 * k2 * abs(x) * r01 * exp(- k1 * t) * u1/(u1**2 + 1.0)+r01 * k12 * &
                    exp(-k12 * t)/w0 * (2.0 * atan(u1) - pi/2.0)) / vd2d_mms_rho(x,y,t)
            case(30)
                xt = x - uf*t
                yt = y - uf*t
                vd2d_mms_u=-w/k/4.0 * cos (k * pi * xt) * sin (k * pi * yt) * sin (w * pi * t)&
                    * (rho1-rho0)/vd2d_mms_rho (x,y,t)
            end select
        end if

    end function vd2d_mms_u
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_rho (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_rho
        real              :: z

        if ( file_is_set(rho) ) then
          vd2d_mms_rho = linear_interp(rho, x) + y*0.0 + t*0.0
        else
            select case( Moin_Problem_ID )
            case (10)
                z = vd2d_mms_z (abs(x),y,t) + 0.0*y
                vd2d_mms_rho = 1.0/(z/rho1+(1.0-z)/rho0)

            case (30)
                vd2d_mms_rho = 1.0/(vd2d_mms_z (x,y,t)/rho1+(1.0-vd2d_mms_z (x,y,t))/rho0)
            end select
        end if

    end function vd2d_mms_rho
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_z
        real              :: z1,z2
        real  :: xt,yt

        if ( file_is_set(Zmix) ) then
            vd2d_mms_z = linear_interp(Zmix, x) + y*0.0 + t*0.0
        else
            select case( Moin_Problem_ID )
            case(10)
                z1 = exp (-k1 * t) + 0.0*y
                z2 = cosh (w0 * exp (-k2 * t) * abs(x))
                vd2d_mms_z=(z1-z2)/(z1 * (1.0-rho0/rho1)-z2)
            case(30)
                xt = x - uf*t
                yt = y - uf*t

        vd2d_mms_z = &
            (1.0 + sin (k * pi * xt) * sin (k * pi * yt) * cos (w * pi * t))/ &
            (1.0 + rho0/rho1+(1.0-rho0/rho1)&
            * sin (k * pi * xt) * sin (k * pi * yt) * cos (w * pi * t))
            end select
        end if

    end function vd2d_mms_z
    !————————————————————————————————————————————————————————————————————————————————————————
    function moin_table_visc_dyn_of_x (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: moin_table_visc_dyn_of_x

        moin_table_visc_dyn_of_x = linear_interp(VISc_Dyn, x) + y*0.0 + t*0.0
    end function moin_table_visc_dyn_of_x
    !————————————————————————————————————————————————————————————————————————————————————————
    function moin_table_visc_dyn_of_Z (Z)
        implicit none
        real, intent (in) :: Z
        real              :: moin_table_visc_dyn_of_Z

        moin_table_visc_dyn_of_Z = linear_interp(Visc_Dyn_of_Zmix, Z)
    end function moin_table_visc_dyn_of_Z
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_z_src
        real :: s0,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10, &
            s11,s12,s13,s14,s15,s16,s17,s18,s19,s20

        if ( file_is_set(Zmix_SRC_of_Zmix) ) then
            vd2d_mms_z_src = linear_interp(Zmix_SRC_of_Zmix, x) + y*0.0 + t*0.0
        else
            select case( Moin_Problem_ID )
            case(10)
                s0 = exp (-k1 * t) + 0.0*y
                s1 = exp (-k2 * t)
                s2 = sech (w0 * s1 * abs(x))
                s3 = tanh (w0 * s1 * abs(x))
                s4 = exp (w0 * s1 * abs(x))
                s5 = s0/s1
                s6 = s0 * s2
                s7 = rho1 + r01 * s6! rho
                s8 = 2.0 * atan (s4)-1.0/2.0 * pi
                s9 = s6 * s3 * w0
                s10=-s9 * s1 * rho1 + s9 * s1 * rho0
                s11 = 1.0-s3 ** 2
                s12 = s4 ** 2 + 1.0
                s13=-1.0 + s6
                s14=-k1 * s6 + s9 * k2 * s1 * abs(x)
                s15 = s6 * s3 ** 2 * w0 ** 2 * s1 ** 2
                s16 = 2.0 * k2 * r01 * s0 * s4/s12
                s17 = s6 * s11 * w0 ** 2 * s1 ** 2
                s18 = s16 * abs(x) + r01 * k12 * s5/w0 * s8
                s19 = s9 * s1 * s7-s13 * s10
                s20 = 2.0 * s4 * s1 * (s16 * abs(x) * s4 * w0-r01 * k12 * s5)/s12
                vd2d_mms_z_src = &
                    -s14 * rho1-(s16 + s16 * abs(x) * w0 * s1-s20) * s13 * rho1/s7 + s18 * rho1 * s19/s7 ** 2 &
                    -D * rho1 * (-s15 * s7 ** 2 + s17 * s7 ** 2 + 2.0 * s9 * s1 * s10 * s7-2.0 * s13 * s10 ** 2 &
                    -s13 * r01 * s7 * s17 + s13 * r01 * s7 * s15)/s7 ** 3
            case(30)
                s0 = cos (w * pi * t)
                s1 = sin (w * pi * t)
                s2 = cos (k * pi * x)
                s3 = sin (k * pi * x)
                s4 = cos (k * pi * y)
                s5 = sin (k * pi * y)
                s6 = rho1-rho0
                s7 = 1.0 + s3 * s5 * s0
                s8 = (0.5 + 0.5 * s3 * s5 * s0) * s6 + rho0! rho
                s9 = rho1 * s3 * s5 * s0 + rho1-s3 * s5 * s0 * rho0 + rho0
                s10 = rho1 * s2 * k * pi * s5 * s0-s2 * k * pi * s5 * s0 * rho0
                s11 = rho1 * s3 * s4 * k * pi * s0-s3 * s4 * k * pi * s0 * rho0
                s12 = rho0 * s3 * s5 * s1 * w * pi-s3 * s5 * s1 * w * pi * rho1
                s13 = s3 * k ** 2 * pi ** 2 * s5 * s0 * rho0-rho1 * s3 * k ** 2 * pi ** 2 * s5 * s0
                s14 = 1.0/4.0
                s15 = 2.0 * D
                s16 = s15 * pi * pi
                vd2d_mms_z_src=&
                    -rho1 * (s8 * s3 * s5 * s1 * w * pi * s9 ** 2 * k + s8 * s7 * s12 * s9 * k + s14 * s2 ** 2 * pi * s5 ** 2 &
                    * s0 * s1 * w * s6 * s9 ** 2 * k-s14 * s7 * s5 * s1 * w * s6 * s2 * s10 * s9 + s14 * s3 ** 2 * s4 ** 2 * pi &
                    * s0 * s1 * w * s6 * s9 ** 2 * k-s14 * s7 * s3 * s1 * w * s6 * s4 * s11 * s9-s16 * k ** 3 * s3 * s5 * s0 &
                    * s9 ** 2-s15 * k ** 2 * s2 * pi * s5 * s0 * s10 * s9 + s15 * k * s7 * s10 ** 2-s15 * k * s7 * s13 * s9 &
                    -s15 * k ** 2 * s3 * s4 * pi * s0 * s11 * s9 + s15 * k * s7 * s11 ** 2)/s9 ** 3/k
            end select

        end if
    end function vd2d_mms_z_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_v

        select case( Moin_Problem_ID )
        case(30)
            vd2d_mms_v = vd2d_mms_u (y,x,t)
            !! NOTE: v obtained from u by transposing x <–> y
        case default
            vd2d_mms_v=x*0.0 + y*0.0 + t*0.0
        end select

    end function vd2d_mms_v
    !!————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_p (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_p

        if ( file_is_set(press) ) then
            vd2d_mms_p = linear_interp(press, x) + y*0.0 + t*0.0
        else
            select case( Moin_Problem_ID )
            case (30)
                vd2d_mms_p = vd2d_mms_rho (x,y,t) * vd2d_mms_u (x,y,t) * vd2d_mms_v (x,y,t)/2.0
                !! NOTE: pressure can vary by a constant and still satisfy the mms
            case default
                vd2d_mms_p = x*0.0 + y*0.0 + t*0.0
            end select

        end if

    end function vd2d_mms_p
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_u_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_u_src
        real  :: s0,s1,s2,s3,s4,s5,s6,s7,s8,&
            s9,s10,s11,s12,s13,s14,s15

        select case( Moin_Problem_ID )
        case (30)
            s0 = cos (w * pi * t)
            s1 = sin (w * pi * t)
            s2 = cos (k * pi * x)
            s3 = sin (k * pi * x)
            s4 = cos (k * pi * y)
            s5 = sin (k * pi * y)
            s6 = rho1-rho0
            s7=(0.5 + 0.5 * s3 * s5 * s0) * s6 + rho0! rho
            s8 = 1.0/64.0
            s9 = s8 * 2.0
            s10 = s9 * 2.0
            s11 = s10 * 3.0
            s12 = s10 * 4.0
            s13 = pi * pi/6.0
            s14 = s13 * 2.0
            s15 = s14 * 2.0
            vd2d_mms_u_src=&
                w * s6 * (-s12 * s5 * s0 * w * pi * s2 * s7 ** 3-s11 * s5 ** 2 * s1 ** 2 * w * s6 * s2 * s3 * pi * s7 ** 2 &
                -s9 * s5 ** 3 * s1 ** 2 * w * s6 ** 2 * s2 ** 3 * pi * s0 * s7 + s10 * s4 ** 2 * pi * s1 ** 2 * w * s6 * s2 * s3 &
                * s7 ** 2-s9 * s5 * s1 ** 2 * w * s6 ** 2 * s2 * s3 ** 2 * s4 ** 2 * pi * s0 * s7-s15 * mu * s1 * s2 * k ** 2 &
                * s5 * s7 ** 2 + s15 * mu * s1 * s2 * k ** 2 * s5 ** 2 * s6 * s3 * s0 * s7 + s13 * mu * s1 * s2 ** 3 * k ** 2 &
                * s5 ** 3 * s6 ** 2 * s0 ** 2-s14 * mu * s1 * s2 * k ** 2 * s3 * s6 * s4 ** 2 * s0 * s7 + s13 * mu * s1 * s2 &
                * k ** 2 * s3 ** 2 * s6 ** 2 * s4 ** 2 * s0 ** 2 * s5-s9 * s5 * s1 ** 2 * w * s6 * s3 ** 2 * pi * s4 * s7 ** 2 &
                + s9 * s5 * s1 ** 2 * w * s6 * s2 ** 2 * pi * s4 * s7 ** 2-s8 * s5 ** 2 * s1 ** 2 * w * s6 ** 2 * s2 ** 2 * s3 &
                * s4 * pi * s0 * s7)/k/s7 ** 3
        case default
            vd2d_mms_u_src = x*0.0 + y*0.0 + t*0.0
        end select

    end function vd2d_mms_u_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real              :: vd2d_mms_v_src

        select case( Moin_Problem_ID )
        case(30)
            vd2d_mms_v_src = vd2d_mms_u_src (y,x,t)
            !! NOTE: v obtained from u by transposing x <–> y
        case default
            vd2d_mms_v_src = x*0.0 + y*0.0 + t*0.0
        end select
    end function vd2d_mms_v_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function sech (x)
        implicit none
        real,intent (in) :: x
        real :: sech

        sech = 1.0/cosh (abs(x))
    end function sech
    !————————————————————————————————————————————————————————————————————————————————————————
end module vd1d_mms_mod_table