diff --git a/BB86/bb86 b/BB86/bb86
new file mode 100755
index 0000000..801262e
Binary files /dev/null and b/BB86/bb86 differ
diff --git a/BB86/bb86.exe b/BB86/bb86.exe
new file mode 100755
index 0000000..23a2593
Binary files /dev/null and b/BB86/bb86.exe differ
diff --git a/BB86/bb86.f b/BB86/bb86.f
new file mode 100755
index 0000000..906734b
--- /dev/null
+++ b/BB86/bb86.f
@@ -0,0 +1,1108 @@
+ 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=========================================================================
diff --git a/BB86/compil.csh b/BB86/compil.csh
new file mode 100755
index 0000000..97c7c8a
--- /dev/null
+++ b/BB86/compil.csh
@@ -0,0 +1,9 @@
+#!/bin/csh
+
+## Compilation
+ifort -c fft.f bb86.f
+ifort -o bb86 -i8 -r8 fft.o bb86.o
+
+\rm *.o
+echo 'Compilation done !'
+
diff --git a/BB86/fft.f b/BB86/fft.f
new file mode 100755
index 0000000..88c692f
--- /dev/null
+++ b/BB86/fft.f
@@ -0,0 +1,704 @@
+C
+C
+C FFT PACKAGE FOR BB86 - AN ALTERNATIVE IS TO USE FFT99.F
+C
+C
+C
+C **********************************************************************
+C FFTPACK.FOR C
+C Contains the Fortran codes for FFT subroutines in C
+C Library FFTPACK.LIB C
+c c
+c This is a reduced version of what is contained in sint.stuff, c
+c so that only those subroutines that are being used in the c
+c POINIT were kept. c
+C======================================================================C
+
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE SINTI (N,WSAVE)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION WSAVE(*)
+C LOGICAL Q8Q4
+C SAVE Q8Q4
+ DATA PI /3.14159265358979/
+C DATA Q8Q4 /.TRUE./
+C IF (Q8Q4) THEN
+C CALL Q8QST4 ('LOCLIB', 'FFTPACK', 'SINTI', 'VERSION 4')
+C Q8Q4 = .FALSE.
+C ENDIF
+ IF (N .LE. 1) RETURN
+ NS2 = N/2
+ NP1 = N+1
+ DT = PI/FLOAT(NP1)
+ DO 101 K=1,NS2
+ WSAVE(K) = 2.*SIN(K*DT)
+ 101 CONTINUE
+ CALL RFFTI (NP1,WSAVE(NS2+1))
+ RETURN
+ END
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE SINT (N,X,WSAVE)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION X(*) ,WSAVE(*)
+C LOGICAL Q8Q4
+C SAVE Q8Q4
+C DATA Q8Q4 /.TRUE./
+C IF (Q8Q4) THEN
+C CALL Q8QST4 ('LOCLIB', 'FFTPACK', 'SINT', 'VERSION 4')
+C Q8Q4 = .FALSE.
+C ENDIF
+ NP1 = N+1
+ IW1 = N/2+1
+ IW2 = IW1+NP1
+ IW3 = IW2+NP1
+ CALL SINT1(N,X,WSAVE,WSAVE(IW1),WSAVE(IW2),WSAVE(IW3))
+ RETURN
+ END
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE SINT1(N,WAR,WAS,XH,X,IFAC)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION WAR(*),WAS(*),X(*),XH(*),IFAC(*)
+ DATA SQRT3 /1.73205080756888/
+ DO 100 I=1,N
+ XH(I) = WAR(I)
+ WAR(I) = X(I)
+ 100 CONTINUE
+ IF (N-2 .LT. 0) THEN
+ GOTO 101
+ ELSE IF (N-2 .EQ. 0) THEN
+ GOTO 102
+ ELSE
+ GOTO 103
+ END IF
+ 101 XH(1) = XH(1)+XH(1)
+ GO TO 106
+ 102 XHOLD = SQRT3*(XH(1)+XH(2))
+ XH(2) = SQRT3*(XH(1)-XH(2))
+ XH(1) = XHOLD
+ GO TO 106
+ 103 NP1 = N+1
+ NS2 = N/2
+ X(1) = 0.
+ DO 104 K=1,NS2
+ KC = NP1-K
+ T1 = XH(K)-XH(KC)
+ T2 = WAS(K)*(XH(K)+XH(KC))
+ X(K+1) = T1+T2
+ X(KC+1) = T2-T1
+ 104 CONTINUE
+ MODN = MOD(N,2)
+ IF (MODN .NE. 0) X(NS2+2) = 4.*XH(NS2+1)
+ CALL RFFTF1 (NP1,X,XH,WAR,IFAC)
+ XH(1) = .5*X(1)
+ DO 105 I=3,N,2
+ XH(I-1) = -X(I)
+ XH(I) = XH(I-2)+X(I-1)
+ 105 CONTINUE
+ IF (MODN .NE. 0) GO TO 106
+ XH(N) = -X(N+1)
+ 106 DO 107 I=1,N
+ X(I) = WAR(I)
+ WAR(I) = XH(I)
+ 107 CONTINUE
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RFFTI (N,WSAVE)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION WSAVE(*)
+C LOGICAL Q8Q4
+C SAVE Q8Q4
+C DATA Q8Q4 /.TRUE./
+C IF (Q8Q4) THEN
+C CALL Q8QST4 ('LOCLIB', 'FFTPACK', 'RFFTI', 'VERSION 4')
+C Q8Q4 = .FALSE.
+C ENDIF
+ IF (N .EQ. 1) RETURN
+ CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RFFTI1 (N,WA,IFAC)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION WA(*) ,IFAC(*) ,NTRYH(4)
+ DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
+ NL = N
+ NF = 0
+ J = 0
+ 101 J = J+1
+ IF (J-4 .lt. 0) THEN
+ GOTO 102
+ ELSE IF (J-4 .eq. 0) THEN
+ GOTO 102
+ ELSE
+ GOTO 103
+ END IF
+ 102 NTRY = NTRYH(J)
+ GO TO 104
+ 103 NTRY = NTRY+2
+ 104 NQ = NL/NTRY
+ NR = NL-NTRY*NQ
+ IF (NR .lt. 0) THEN
+ GOTO 101
+ ELSE IF (NR .eq. 0) THEN
+ GOTO 105
+ ELSE
+ GOTO 101
+ END IF
+ 105 NF = NF+1
+ IFAC(NF+2) = NTRY
+ NL = NQ
+ IF (NTRY .NE. 2) GO TO 107
+ IF (NF .EQ. 1) GO TO 107
+ DO 106 I=2,NF
+ IB = NF-I+2
+ IFAC(IB+2) = IFAC(IB+1)
+ 106 CONTINUE
+ IFAC(3) = 2
+ 107 IF (NL .NE. 1) GO TO 104
+ IFAC(1) = N
+ IFAC(2) = NF
+ TPI = 6.28318530717959
+ ARGH = TPI/FLOAT(N)
+ IS = 0
+ NFM1 = NF-1
+ L1 = 1
+ IF (NFM1 .EQ. 0) RETURN
+ DO 110 K1=1,NFM1
+ IP = IFAC(K1+2)
+ LD = 0
+ L2 = L1*IP
+ IDO = N/L2
+ IPM = IP-1
+ DO 109 J=1,IPM
+ LD = LD+L1
+ I = IS
+ ARGLD = FLOAT(LD)*ARGH
+ FI = 0.
+ DO 108 II=3,IDO,2
+ I = I+2
+ FI = FI+1.
+ ARG = FI*ARGLD
+ WA(I-1) = COS(ARG)
+ WA(I) = SIN(ARG)
+ 108 CONTINUE
+ IS = IS+IDO
+ 109 CONTINUE
+ L1 = L2
+ 110 CONTINUE
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RFFTF (N,R,WSAVE)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION R(*) ,WSAVE(*)
+C LOGICAL Q8Q4
+C SAVE Q8Q4
+C DATA Q8Q4 /.TRUE./
+C IF (Q8Q4) THEN
+C CALL Q8QST4 ('LOCLIB', 'FFTPACK', 'RFFTF', 'VERSION 4')
+C Q8Q4 = .FALSE.
+C ENDIF
+ IF (N .EQ. 1) RETURN
+ CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*)
+ NF = IFAC(2)
+ NA = 1
+ L2 = N
+ IW = N
+ DO 111 K1=1,NF
+ KH = NF-K1
+ IP = IFAC(KH+3)
+ L1 = L2/IP
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IW = IW-(IP-1)*IDO
+ NA = 1-NA
+ IF (IP .NE. 4) GO TO 102
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA .NE. 0) GO TO 101
+ CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 102 IF (IP .NE. 2) GO TO 104
+ IF (NA .NE. 0) GO TO 103
+ CALL RADF2 (IDO,L1,C,CH,WA(IW))
+ GO TO 110
+ 103 CALL RADF2 (IDO,L1,CH,C,WA(IW))
+ GO TO 110
+ 104 IF (IP .NE. 3) GO TO 106
+ IX2 = IW+IDO
+ IF (NA .NE. 0) GO TO 105
+ CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 110
+ 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ GO TO 110
+ 106 IF (IP .NE. 5) GO TO 108
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA .NE. 0) GO TO 107
+ CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 108 IF (IDO .EQ. 1) NA = 1-NA
+ IF (NA .NE. 0) GO TO 109
+ CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ NA = 1
+ GO TO 110
+ 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ NA = 0
+ 110 L2 = L1
+ 111 CONTINUE
+ IF (NA .EQ. 1) RETURN
+ DO 112 I=1,N
+ C(I) = CH(I)
+ 112 CONTINUE
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) ,
+ 1 WA1(*)
+ DO 101 K=1,L1
+ CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2 .lt. 0) THEN
+ GOTO 107
+ ELSE IF (IDO-2 .eq. 0) THEN
+ GOTO 105
+ ELSE
+ GOTO 102
+ END IF
+ 102 IDP2 = IDO+2
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CH(I,1,K) = CC(I,K,1)+TI2
+ CH(IC,2,K) = TI2-CC(I,K,1)
+ CH(I-1,1,K) = CC(I-1,K,1)+TR2
+ CH(IC-1,2,K) = CC(I-1,K,1)-TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(1,2,K) = -CC(IDO,K,2)
+ CH(IDO,1,K) = CC(IDO,K,1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) ,
+ 1 WA1(*) ,WA2(*)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,2)+CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2
+ CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
+ CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR2 = DR2+DR3
+ CI2 = DI2+DI3
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2
+ CH(I,1,K) = CC(I,K,1)+CI2
+ TR2 = CC(I-1,K,1)+TAUR*CR2
+ TI2 = CC(I,K,1)+TAUR*CI2
+ TR3 = TAUI*(DI2-DI3)
+ TI3 = TAUI*(DR3-DR2)
+ CH(I-1,3,K) = TR2+TR3
+ CH(IC-1,2,K) = TR2-TR3
+ CH(I,3,K) = TI2+TI3
+ CH(IC,2,K) = TI3-TI2
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) ,
+ 1 WA1(*) ,WA2(*) ,WA3(*)
+ DATA HSQT2 /.7071067811865475/
+ DO 101 K=1,L1
+ TR1 = CC(1,K,2)+CC(1,K,4)
+ TR2 = CC(1,K,1)+CC(1,K,3)
+ CH(1,1,K) = TR1+TR2
+ CH(IDO,4,K) = TR2-TR1
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
+ CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2 .le. 0) THEN
+ GOTO 107
+ ELSE IF (IDO-2 .eq. 0) THEN
+ GOTO 105
+ ELSE
+ GOTO 102
+ END IF
+ 102 IDP2 = IDO+2
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ TR1 = CR2+CR4
+ TR4 = CR4-CR2
+ TI1 = CI2+CI4
+ TI4 = CI2-CI4
+ TI2 = CC(I,K,1)+CI3
+ TI3 = CC(I,K,1)-CI3
+ TR2 = CC(I-1,K,1)+CR3
+ TR3 = CC(I-1,K,1)-CR3
+ CH(I-1,1,K) = TR1+TR2
+ CH(IC-1,4,K) = TR2-TR1
+ CH(I,1,K) = TI1+TI2
+ CH(IC,4,K) = TI1-TI2
+ CH(I-1,3,K) = TI4+TR3
+ CH(IC-1,2,K) = TR3-TI4
+ CH(I,3,K) = TR4+TI3
+ CH(IC,2,K) = TR4-TI3
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) .EQ. 1) RETURN
+ 105 CONTINUE
+ DO 106 K=1,L1
+ TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
+ TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
+ CH(IDO,1,K) = TR1+CC(IDO,K,1)
+ CH(IDO,3,K) = CC(IDO,K,1)-TR1
+ CH(1,2,K) = TI1-CC(IDO,K,3)
+ CH(1,4,K) = TI1+CC(IDO,K,3)
+ 106 CONTINUE
+ 107 RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) ,
+ 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154,
+ 1-.809016994374947,.587785252292473/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,5)+CC(1,K,2)
+ CI5 = CC(1,K,5)-CC(1,K,2)
+ CR3 = CC(1,K,4)+CC(1,K,3)
+ CI4 = CC(1,K,4)-CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2+CR3
+ CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
+ CH(1,3,K) = TI11*CI5+TI12*CI4
+ CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
+ CH(1,5,K) = TI12*CI5-TI11*CI4
+ 101 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
+ DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
+ CR2 = DR2+DR5
+ CI5 = DR5-DR2
+ CR5 = DI2-DI5
+ CI2 = DI2+DI5
+ CR3 = DR3+DR4
+ CI4 = DR4-DR3
+ CR4 = DI3-DI4
+ CI3 = DI3+DI4
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
+ CH(I,1,K) = CC(I,K,1)+CI2+CI3
+ TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
+ TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
+ TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
+ TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
+ TR5 = TI11*CR5+TI12*CR4
+ TI5 = TI11*CI5+TI12*CI4
+ TR4 = TI12*CR5-TI11*CR4
+ TI4 = TI12*CI5-TI11*CI4
+ CH(I-1,3,K) = TR2+TR5
+ CH(IC-1,2,K) = TR2-TR5
+ CH(I,3,K) = TI2+TI5
+ CH(IC,2,K) = TI5-TI2
+ CH(I-1,5,K) = TR3+TR4
+ CH(IC-1,4,K) = TR3-TR4
+ CH(I,5,K) = TI3+TI4
+ CH(IC,4,K) = TI4-TI3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+c
+c
+c
+c
+c==========================================================c
+c==========================================================c
+ SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+c==========================================================c
+c==========================================================c
+c
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) ,
+ 1 C1(IDO,L1,IP) ,C2(IDL1,IP),
+ 2 CH2(IDL1,IP) ,WA(*)
+ DATA TPI/6.28318530717959/
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IPPH = (IP+1)/2
+ IPP2 = IP+2
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IF (IDO .EQ. 1) GO TO 119
+ DO 101 IK=1,IDL1
+ CH2(IK,1) = C2(IK,1)
+ 101 CONTINUE
+ DO 103 J=2,IP
+ DO 102 K=1,L1
+ CH(1,K,J) = C1(1,K,J)
+ 102 CONTINUE
+ 103 CONTINUE
+ IF (NBD .GT. L1) GO TO 107
+ IS = -IDO
+ DO 106 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 105 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 104 K=1,L1
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 104 CONTINUE
+ 105 CONTINUE
+ 106 CONTINUE
+ GO TO 111
+ 107 IS = -IDO
+ DO 110 J=2,IP
+ IS = IS+IDO
+ DO 109 K=1,L1
+ IDIJ = IS
+ DO 108 I=3,IDO,2
+ IDIJ = IDIJ+2
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (NBD .LT. L1) GO TO 115
+ DO 114 J=2,IPPH
+ JC = IPP2-J
+ DO 113 K=1,L1
+ DO 112 I=3,IDO,2
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 112 CONTINUE
+ 113 CONTINUE
+ 114 CONTINUE
+ GO TO 121
+ 115 DO 118 J=2,IPPH
+ JC = IPP2-J
+ DO 117 I=3,IDO,2
+ DO 116 K=1,L1
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 116 CONTINUE
+ 117 CONTINUE
+ 118 CONTINUE
+ GO TO 121
+ 119 DO 120 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 120 CONTINUE
+ 121 DO 123 J=2,IPPH
+ JC = IPP2-J
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
+ C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+C
+ AR1 = 1.
+ AI1 = 0.
+ DO 127 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 124 IK=1,IDL1
+ CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
+ CH2(IK,LC) = AI1*C2(IK,IP)
+ 124 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+ DO 126 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 125 IK=1,IDL1
+ CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
+ CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ DO 129 J=2,IPPH
+ DO 128 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+C2(IK,J)
+ 128 CONTINUE
+ 129 CONTINUE
+C
+ IF (IDO .LT. L1) GO TO 132
+ DO 131 K=1,L1
+ DO 130 I=1,IDO
+ CC(I,1,K) = CH(I,K,1)
+ 130 CONTINUE
+ 131 CONTINUE
+ GO TO 135
+ 132 DO 134 I=1,IDO
+ DO 133 K=1,L1
+ CC(I,1,K) = CH(I,K,1)
+ 133 CONTINUE
+ 134 CONTINUE
+ 135 DO 137 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 136 K=1,L1
+ CC(IDO,J2-2,K) = CH(1,K,J)
+ CC(1,J2-1,K) = CH(1,K,JC)
+ 136 CONTINUE
+ 137 CONTINUE
+ IF (IDO .EQ. 1) RETURN
+ IF (NBD .LT. L1) GO TO 141
+ DO 140 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 139 K=1,L1
+ DO 138 I=3,IDO,2
+ IC = IDP2-I
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 138 CONTINUE
+ 139 CONTINUE
+ 140 CONTINUE
+ RETURN
+ 141 DO 144 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 143 I=3,IDO,2
+ IC = IDP2-I
+ DO 142 K=1,L1
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 142 CONTINUE
+ 143 CONTINUE
+ 144 CONTINUE
+ RETURN
+ END
diff --git a/BB86/fort.20 b/BB86/fort.20
new file mode 100755
index 0000000..595307d
Binary files /dev/null and b/BB86/fort.20 differ
diff --git a/BB86/fort.21 b/BB86/fort.21
new file mode 100755
index 0000000..a4cfc43
Binary files /dev/null and b/BB86/fort.21 differ
diff --git a/BB86/fort.22 b/BB86/fort.22
new file mode 100755
index 0000000..f1491f9
Binary files /dev/null and b/BB86/fort.22 differ
diff --git a/BB86/fort.30 b/BB86/fort.30
new file mode 100755
index 0000000..b4eda79
Binary files /dev/null and b/BB86/fort.30 differ
diff --git a/BB86/fort.31 b/BB86/fort.31
new file mode 100755
index 0000000..0951536
Binary files /dev/null and b/BB86/fort.31 differ
diff --git a/BB86/fort.32 b/BB86/fort.32
new file mode 100755
index 0000000..141d0eb
Binary files /dev/null and b/BB86/fort.32 differ
diff --git a/BB86/input b/BB86/input
new file mode 100755
index 0000000..7aa8e56
--- /dev/null
+++ b/BB86/input
@@ -0,0 +1,4 @@
+0,360
+1200
+500.e5,4500.e5
+-1.0,2
diff --git a/IDL/UTILITIES/closeps.pro b/IDL/UTILITIES/closeps.pro
new file mode 100755
index 0000000..bb0d793
--- /dev/null
+++ b/IDL/UTILITIES/closeps.pro
@@ -0,0 +1,115 @@
+;+
+;
+; @file_comments
+; Close the Postscript mode
+;
+; when archive_ps ne 0, we add the name and the date at the bottom left corner
+; of the postscript page.
+; If the postscript is called idl.ps we change its name to number.ps
+; (number automatically found to be 1 larger that any of the existing ps file)
+;
+; @keyword INFOWIDGET {type=long integer}
+; id of the information widget (created by openps)
+; that we have to destroy at the end of closeps (when the postscript is done).
+;
+; @uses
+; cm_4ps
+;
+; @history
+; Sebastien Masson (smasson\@lodyc.jussieu.fr)
+; 21/12/98
+; June 2005: Sebastien Masson, english version with new commons
+;
+; @version
+; $Id: closeps.pro 371 2008-08-07 09:32:02Z pinsard $
+;
+;-
+PRO closeps, INFOWIDGET=infowidget
+;
+compile_opt idl2, strictarrsubs
+;
+IF lmgr(/demo) EQ 1 THEN return
+;
+;@cm_4ps
+ IF NOT keyword_set(key_forgetold) THEN BEGIN
+;@updatenew
+ ENDIF
+;
+ IF !d.name NE 'PS' THEN GOTO, last_part
+;------------------------------------------------------------
+; if archive_ps /= 0 we will add its name and the date at the bottom
+; left corner of the page (in case if the postscript will be archived
+; in printps
+;------------------------------------------------------------
+ IF keyword_set(archive_ps) THEN BEGIN
+;------------------------------------------------------------
+; we get the name of the latest created postscript.
+;------------------------------------------------------------
+ psdir = isadirectory(psdir, title = 'Select psdir')
+ nameps = file_search(psdir+'*.ps' $
+ , /test_regular, /test_write, /nosort)
+ dates = (file_info(nameps)).mtime
+ lastdate = (reverse(sort(temporary(dates))))[0]
+ nameps = nameps[lastdate]
+ nameps = file_basename(nameps, '.ps')
+; If this name is idl.ps then we change it to the number.ps
+ IF nameps EQ 'idl' then BEGIN
+; get the name of all the *.ps or *.ps.gz files available in psdir
+ allps = file_search(psdir+'*[.ps|.ps.gz|.pdf]', /test_regular, /nosort)
+ allps = file_basename(file_basename(allps,'.gz'),'.ps')
+ allps = file_basename(allps,'.pdf')
+; find which of these names corresponds to numbers...
+; get ascii codes of the names
+ testnumb = byte(allps)
+; longest name
+ maxstrlen = (size(testnumb, /dimensions))[0]
+; ascii codes can be 0 or between byte('0') and byte('9')
+ testnumb = testnumb EQ 0 OR $
+ (testnumb GE (byte('0'))[0] AND testnumb LE (byte('9'))[0])
+ testnumb = where(total(testnumb, 1) EQ maxstrlen, count)
+ IF count NE 0 THEN BEGIN
+; get the largest number
+ psnumber = fix(allps[testnumb])
+ psnumber = (psnumber[reverse(sort(psnumber))])[0] + 1
+ ENDIF ELSE psnumber = 0
+ nameps = strtrim(psnumber, 2)
+ ENDIF
+;------------------------------------------------------------
+; we annotate the postscript
+;------------------------------------------------------------
+ date = byte(systime(0)) ; we get the date
+ xyouts, !d.x_px_cm, !d.y_px_cm $
+ , nameps+') '+string(date[4:10])+string(date[20:23]) $
+ , /device, charsize = .75
+ ENDIF
+;------------------------------------------------------------
+; close the postscript mode
+ device, /close
+;
+last_part:
+;
+ thisOS = strupcase(strmid(!version.os_family, 0, 3))
+ CASE thisOS of
+ 'MAC': SET_PLOT, thisOS
+ 'WIN': SET_PLOT, thisOS
+ ELSE: SET_PLOT, 'X'
+ ENDCASE
+; def_myuniquetmpdir
+; colorfile = myuniquetmpdir + 'original_colors.dat'
+; IF file_test(colorfile, /regular) THEN BEGIN
+; restore, colorfile
+; file_delete, colorfile, /quiet
+; ; reload the original colors
+; tvlct, red, green, blue
+; ENDIF
+ !p.font = -1
+; force background color to the last color (white)
+ ; !p.BACKGROUND=(!d.n_colors-1) < 255
+ ; !p.color=0
+ ; if !d.n_colors gt 256 then !p.background='ffffff'x
+;------------------------------------------------------------
+ if keyword_set(infowidget) then $
+ widget_control, long(infowidget), bad_id = toto, /destroy
+;------------------------------------------------------------
+ return
+end
diff --git a/IDL/UTILITIES/colorbar2.pro b/IDL/UTILITIES/colorbar2.pro
new file mode 100755
index 0000000..3a6a16f
--- /dev/null
+++ b/IDL/UTILITIES/colorbar2.pro
@@ -0,0 +1,467 @@
+;+
+; NAME:
+; COLORBAR
+;
+; PURPOSE:
+;
+; The purpose of this routine is to add a color bar to the current
+; graphics window.
+;
+; AUTHOR:
+;
+; FANNING SOFTWARE CONSULTING
+; David Fanning, Ph.D.
+; 1645 Sheely Drive
+; Fort Collins, CO 80526 USA
+; Phone: 970-221-0438
+; E-mail: davidf@dfanning.com
+; Coyote's Guide to IDL Programming: http://www.dfanning.com/
+;
+; CATEGORY:
+;
+; Graphics, Widgets.
+;
+; CALLING SEQUENCE:
+;
+; COLORBAR
+;
+; INPUTS:
+;
+; None.
+;
+; KEYWORD PARAMETERS:
+;
+; ANNOTATECOLOR: The name of the "annotation color" to use. The names are those for
+; FSC_COLOR, and using the keyword implies that FSC_COLOR is also in
+; your !PATH. If this keyword is used, the annotation color is loaded
+; *after* the color bar is displayed. The color will be represented
+; as theColor = FSC_COLOR(ANNOTATECOLOR, COLOR). This keyword is provide
+; to maintain backward compatibility, but also to solve the problem of
+; and extra line in the color bar when this kind of syntax is used in
+; conjunction with the indexed (DEVICE, DECOMPOSED=0) model is used:
+;
+; LoadCT, 33
+; TVImage, image
+; Colorbar, Color=FSC_Color('firebrick')
+;
+; The proper syntax for device-independent color is like this:
+;
+; LoadCT, 33
+; TVImage, image
+; Colorbar, AnnotateColor='firebrick', Color=255
+;
+; BOTTOM: The lowest color index of the colors to be loaded in
+; the bar.
+;
+; CHARSIZE: The character size of the color bar annotations. Default is 1.0.
+;
+; COLOR: The color index of the bar outline and characters. Default
+; is !P.Color..
+;
+; DIVISIONS: The number of divisions to divide the bar into. There will
+; be (divisions + 1) annotations. The default is 6.
+;
+; FONT: Sets the font of the annotation. Hershey: -1, Hardware:0, True-Type: 1.
+;
+; FORMAT: The format of the bar annotations. Default is '(I0)'.
+;
+; INVERTCOLORS: Setting this keyword inverts the colors in the color bar.
+;
+; MAXRANGE: The maximum data value for the bar annotation. Default is
+; NCOLORS.
+;
+; MINRANGE: The minimum data value for the bar annotation. Default is 0.
+;
+; MINOR: The number of minor tick divisions. Default is 2.
+;
+; NCOLORS: This is the number of colors in the color bar.
+;
+; NODISPLAY: COLORBAR uses FSC_COLOR to specify some of it colors. Normally,
+; FSC_COLOR loads "system" colors as part of its palette of colors.
+; In order to do so, it has to create an IDL widget, which in turn
+; has to make a connection to the windowing system. If your program
+; is being run without a window connection, then this program will
+; fail. If you can live without the system colors (and most people
+; don't even know they are there, to tell you the truth), then setting
+; this keyword will keep them from being loaded, and you can run
+; COLORBAR without a display.
+;
+; POSITION: A four-element array of normalized coordinates in the same
+; form as the POSITION keyword on a plot. Default is
+; [0.88, 0.10, 0.95, 0.90] for a vertical bar and
+; [0.10, 0.88, 0.90, 0.95] for a horizontal bar.
+;
+; RANGE: A two-element vector of the form [min, max]. Provides an
+; alternative way of setting the MINRANGE and MAXRANGE keywords.
+;
+; REVERSE: Setting this keyword reverses the colors in the colorbar.
+;
+; RIGHT: This puts the labels on the right-hand side of a vertical
+; color bar. It applies only to vertical color bars.
+;
+; TICKNAMES: A string array of names or values for the tick marks.
+;
+; TITLE: This is title for the color bar. The default is to have
+; no title.
+;
+; TOP: This puts the labels on top of the bar rather than under it.
+; The keyword only applies if a horizontal color bar is rendered.
+;
+; VERTICAL: Setting this keyword give a vertical color bar. The default
+; is a horizontal color bar.
+;
+; COMMON BLOCKS:
+;
+; None.
+;
+; SIDE EFFECTS:
+;
+; Color bar is drawn in the current graphics window.
+;
+; RESTRICTIONS:
+;
+; The number of colors available on the graphics display device (not the
+; PostScript device) is used unless the NCOLORS keyword is used.
+;
+; Requires the FSC_COLOR program from the Coyote Library:
+;
+; http://www.dfanning.com/programs/fsc_color.pro
+;
+; EXAMPLE:
+;
+; To display a horizontal color bar above a contour plot, type:
+;
+; LOADCT, 5, NCOLORS=100
+; CONTOUR, DIST(31,41), POSITION=[0.15, 0.15, 0.95, 0.75], $
+; C_COLORS=INDGEN(25)*4, NLEVELS=25
+; COLORBAR, NCOLORS=100, POSITION=[0.15, 0.85, 0.95, 0.90]
+;
+; MODIFICATION HISTORY:
+;
+; Written by: David W. Fanning, 10 JUNE 96.
+; 10/27/96: Added the ability to send output to PostScript. DWF
+; 11/4/96: Substantially rewritten to go to screen or PostScript
+; file without having to know much about the PostScript device
+; or even what the current graphics device is. DWF
+; 1/27/97: Added the RIGHT and TOP keywords. Also modified the
+; way the TITLE keyword works. DWF
+; 7/15/97: Fixed a problem some machines have with plots that have
+; no valid data range in them. DWF
+; 12/5/98: Fixed a problem in how the colorbar image is created that
+; seemed to tickle a bug in some versions of IDL. DWF.
+; 1/12/99: Fixed a problem caused by RSI fixing a bug in IDL 5.2. Sigh... DWF.
+; 3/30/99: Modified a few of the defaults. DWF.
+; 3/30/99: Used NORMAL rather than DEVICE coords for positioning bar. DWF.
+; 3/30/99: Added the RANGE keyword. DWF.
+; 3/30/99: Added FONT keyword. DWF
+; 5/6/99: Many modifications to defaults. DWF.
+; 5/6/99: Removed PSCOLOR keyword. DWF.
+; 5/6/99: Improved error handling on position coordinates. DWF.
+; 5/6/99. Added MINOR keyword. DWF.
+; 5/6/99: Set Device, Decomposed=0 if necessary. DWF.
+; 2/9/99: Fixed a problem caused by setting BOTTOM keyword, but not NCOLORS. DWF.
+; 8/17/99. Fixed a problem with ambiguous MIN and MINOR keywords. DWF
+; 8/25/99. I think I *finally* got the BOTTOM/NCOLORS thing sorted out. :-( DWF.
+; 10/10/99. Modified the program so that current plot and map coordinates are
+; saved and restored after the colorbar is drawn. DWF.
+; 3/18/00. Moved a block of code to prevent a problem with color decomposition. DWF.
+; 4/28/00. Made !P.Font default value for FONT keyword. DWF.
+; 9/26/00. Made the code more general for scalable pixel devices. DWF.
+; 1/16/01. Added INVERTCOLORS keyword. DWF.
+; 5/11/04. Added TICKNAME keyword. DWF.
+; 9/29/05. Added REVERSE keywords, which does the *exact* same thing as
+; INVERTCOLORS, but I can never remember the latter keyword name. DWF.
+; 1/2/07. Added ANNOTATECOLOR keyword. DWF.
+; 4/14/07. Changed the default FORMAT to I0. DWF.
+; 5/1/07. Unexpected consequence of default format change is colorbar annotations
+; no longer match contour plot levels. Changed to explicit formating of
+; colorbar axis labels before PLOT command. DWF.
+; 5/25/07. Previous change has unanticipated effect on color bars using
+; logarithmic scaling, which is not really supported, but I have an
+; article on my web page describing how to do it: http://www.dfanning.com/graphics_tips/logcb.html.
+; Thus, I've fixed the program to accommodate log scaling, while still not OFFICIALLY
+; supporting it. DWF.
+; 10/3/07. Method used to calculate TICKNAMES produces incorrect values in certain cases when
+; the min and max range values are integers. Now force range values to be floats. DWF.
+; 10/17/07. Accidentaly use of INTERP keyword in CONGRID results in wrong bar values for
+; low NCOLORS numbers when INVERTCOLORS or REVERSE keyword is used. Removed INTERP keyword. DWF.
+; 11/10/07. Finished fixing program to accommodate log scaling in ALL possible permutations. DWF.
+; 8 Feb 2008. Added CRONJOB keyword and decided to use month names when I write the date. DWF.
+; 8 Feb 2008. Renamed CRONJOB to NODISPLAY to better reflect its purpose. DWF.
+;-
+;
+;###########################################################################
+;
+; LICENSE
+;
+; This software is OSI Certified Open Source Software.
+; OSI Certified is a certification mark of the Open Source Initiative.
+;
+; Copyright 2000-2008 Fanning Software Consulting.
+;
+; This software is provided "as-is", without any express or
+; implied warranty. In no event will the authors be held liable
+; for any damages arising from the use of this software.
+;
+; Permission is granted to anyone to use this software for any
+; purpose, including commercial applications, and to alter it and
+; redistribute it freely, subject to the following restrictions:
+;
+; 1. The origin of this software must not be misrepresented; you must
+; not claim you wrote the original software. If you use this software
+; in a product, an acknowledgment in the product documentation
+; would be appreciated, but is not required.
+;
+; 2. Altered source versions must be plainly marked as such, and must
+; not be misrepresented as being the original software.
+;
+; 3. This notice may not be removed or altered from any source distribution.
+;
+; For more information on Open Source Software, visit the Open Source
+; web site: http://www.opensource.org.
+;
+;###########################################################################
+
+
+PRO COLORBAR2, BOTTOM=bottom, CHARSIZE=charsize, COLOR=color, DIVISIONS=divisions, $
+ FORMAT=format, POSITION=position, MAXRANGE=maxrange, MINRANGE=minrange, NCOLORS=ncolors, $
+ TITLE=title, VERTICAL=vertical, TOP=top, RIGHT=right, MINOR=minor, $
+ RANGE=range, FONT=font, TICKLEN=ticklen, _EXTRA=extra, INVERTCOLORS=invertcolors, $
+ TICKNAMES=ticknames, REVERSE=reverse, ANNOTATECOLOR=annotatecolor, XLOG=xlog, YLOG=ylog, $
+ NODISPLAY=nodisplay
+
+ compile_opt idl2
+
+ ; Return to caller on error.
+ On_Error, 2
+
+ ; Save the current plot state.
+ bang_p = !P
+ bang_x = !X
+ bang_Y = !Y
+ bang_Z = !Z
+ bang_Map = !Map
+
+ ; Are scalable pixels available on the device?
+ IF (!D.Flags AND 1) NE 0 THEN scalablePixels = 1 ELSE scalablePixels = 0
+
+ ; Which release of IDL is this?
+ thisRelease = Float(!Version.Release)
+
+ ; Check and define keywords.
+ IF N_ELEMENTS(ncolors) EQ 0 THEN BEGIN
+
+ ; Most display devices to not use the 256 colors available to
+ ; the PostScript device. This presents a problem when writing
+ ; general-purpose programs that can be output to the display or
+ ; to the PostScript device. This problem is especially bothersome
+ ; if you don't specify the number of colors you are using in the
+ ; program. One way to work around this problem is to make the
+ ; default number of colors the same for the display device and for
+ ; the PostScript device. Then, the colors you see in PostScript are
+ ; identical to the colors you see on your display. Here is one way to
+ ; do it.
+
+ IF scalablePixels THEN BEGIN
+ oldDevice = !D.NAME
+
+ ; What kind of computer are we using? SET_PLOT to appropriate
+ ; display device.
+
+ thisOS = !VERSION.OS_FAMILY
+ thisOS = STRMID(thisOS, 0, 3)
+ thisOS = STRUPCASE(thisOS)
+ CASE thisOS of
+ 'MAC': SET_PLOT, thisOS
+ 'WIN': SET_PLOT, thisOS
+ ELSE: SET_PLOT, 'X'
+ ENDCASE
+
+ ; Here is how many colors we should use.
+ ncolors = !D.TABLE_SIZE
+ SET_PLOT, oldDevice
+ ENDIF ELSE ncolors = !D.TABLE_SIZE
+ ENDIF
+ IF N_ELEMENTS(bottom) EQ 0 THEN bottom = 0B
+ IF N_ELEMENTS(charsize) EQ 0 THEN charsize = 1.0
+ IF N_ELEMENTS(format) EQ 0 THEN format = '(I0)'
+ IF N_ELEMENTS(color) EQ 0 THEN color = !P.Color
+ minrange = (N_ELEMENTS(minrange) EQ 0) ? 0. : Float(minrange)
+ maxrange = (N_ELEMENTS(maxrange) EQ 0) ? Float(ncolors) : Float(maxrange)
+ IF N_ELEMENTS(ticklen) EQ 0 THEN ticklen = 0.2
+ IF N_ELEMENTS(minor) EQ 0 THEN minor = 2
+ IF N_ELEMENTS(range) NE 0 THEN BEGIN
+ minrange = Float(range[0])
+ maxrange = Float(range[1])
+ ENDIF
+ IF N_ELEMENTS(divisions) EQ 0 THEN divisions = 6
+ IF N_ELEMENTS(font) EQ 0 THEN font = !P.Font
+ IF N_ELEMENTS(title) EQ 0 THEN title = ''
+ xlog = Keyword_Set(xlog)
+ ylog = Keyword_Set(ylog)
+
+ ; You can't have a format set *and* use ticknames.
+ IF N_ELEMENTS(ticknames) NE 0 THEN format = ""
+
+ ; If the format is NOT null, then format the ticknames yourself.
+ IF (xlog XOR ylog) EQ 0 THEN BEGIN
+ IF format NE "" THEN BEGIN
+ step = (maxrange - minrange) / divisions
+ levels = minrange > (Indgen(divisions+1) * step + minrange) < maxrange
+ IF StrPos(StrLowCase(format), 'i') NE -1 THEN levels = Round(levels)
+ ticknames = String(levels, Format=format)
+ format = "" ; No formats allowed in PLOT call now that we have ticknames.
+ ENDIF
+ ENDIF
+
+ IF KEYWORD_SET(vertical) THEN BEGIN
+ bar = REPLICATE(1B,20) # BINDGEN(ncolors)
+ IF Keyword_Set(invertcolors) THEN bar = Reverse(bar, 2)
+ IF N_ELEMENTS(position) EQ 0 THEN BEGIN
+ position = [0.88, 0.1, 0.95, 0.9]
+ ENDIF ELSE BEGIN
+ IF position[2]-position[0] GT position[3]-position[1] THEN BEGIN
+ position = [position[1], position[0], position[3], position[2]]
+ ENDIF
+ IF position[0] GE position[2] THEN Message, "Position coordinates can't be reconciled."
+ IF position[1] GE position[3] THEN Message, "Position coordinates can't be reconciled."
+ ENDELSE
+ ENDIF ELSE BEGIN
+ bar = BINDGEN(ncolors) # REPLICATE(1B, 20)
+ IF Keyword_Set(invertcolors) THEN bar = Reverse(bar, 1)
+ IF N_ELEMENTS(position) EQ 0 THEN BEGIN
+ position = [0.1, 0.88, 0.9, 0.95]
+ ENDIF ELSE BEGIN
+ IF position[3]-position[1] GT position[2]-position[0] THEN BEGIN
+ position = [position[1], position[0], position[3], position[2]]
+ ENDIF
+ IF position[0] GE position[2] THEN Message, "Position coordinates can't be reconciled."
+ IF position[1] GE position[3] THEN Message, "Position coordinates can't be reconciled."
+ ENDELSE
+ ENDELSE
+
+ ; Scale the color bar.
+ bar = BYTSCL(bar, TOP=(ncolors-1) < (255-bottom)) + bottom
+
+ IF Keyword_Set(reverse) THEN BEGIN
+ IF Keyword_Set(vertical) THEN bar = Reverse(bar,2) ELSE bar = Reverse(bar,1)
+ ENDIF
+
+ ; Get starting locations in NORMAL coordinates.
+ xstart = position[0]
+ ystart = position[1]
+
+ ; Get the size of the bar in NORMAL coordinates.
+ xsize = (position[2] - position[0])
+ ysize = (position[3] - position[1])
+
+ ; Display the color bar in the window. Sizing is
+ ; different for PostScript and regular display.
+ IF scalablePixels THEN BEGIN
+
+ TV, bar, xstart, ystart, XSIZE=xsize, YSIZE=ysize, /Normal
+
+ ENDIF ELSE BEGIN
+
+ bar = CONGRID(bar, CEIL(xsize*!D.X_VSize), CEIL(ysize*!D.Y_VSize))
+
+ ; Decomposed color off if device supports it.
+ CASE StrUpCase(!D.NAME) OF
+ 'X': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Get_Decomposed=thisDecomposed
+ Device, Decomposed=0
+ ENDCASE
+ 'WIN': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Get_Decomposed=thisDecomposed
+ Device, Decomposed=0
+ ENDCASE
+ 'MAC': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Get_Decomposed=thisDecomposed
+ Device, Decomposed=0
+ ENDCASE
+ ELSE:
+ ENDCASE
+
+ TV, bar, xstart, ystart, /Normal
+
+ ; Restore Decomposed state if necessary.
+ CASE StrUpCase(!D.NAME) OF
+ 'X': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Decomposed=thisDecomposed
+ ENDCASE
+ 'WIN': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Decomposed=thisDecomposed
+ ENDCASE
+ 'MAC': BEGIN
+ IF thisRelease GE 5.2 THEN Device, Decomposed=thisDecomposed
+ ENDCASE
+ ELSE:
+ ENDCASE
+
+ ENDELSE
+
+ ; Annotate the color bar.
+ IF N_Elements(annotateColor) NE 0 THEN $
+ color = FSC_Color(annotateColor, color, NODISPLAY=Keyword_Set(nodisplay))
+
+ IF KEYWORD_SET(vertical) THEN BEGIN
+
+ IF KEYWORD_SET(right) THEN BEGIN
+
+ PLOT, [minrange,maxrange], [minrange,maxrange], /NODATA, XTICKS=1, $
+ YTICKS=divisions, XSTYLE=1, YSTYLE=9, $
+ POSITION=position, COLOR=color, CHARSIZE=charsize, /NOERASE, $
+ XTICKFORMAT='(A1)', YTICKFORMAT='(A1)', YMINOR=minor, _EXTRA=extra, $
+ YTICKNAME=ticknames, FONT=font, YLOG=ylog
+
+ AXIS, YAXIS=1, YRANGE=[minrange, maxrange], YTICKFORMAT=format, YTICKS=divisions, $
+ YTICKLEN=ticklen, YSTYLE=1, COLOR=color, CHARSIZE=charsize, $
+ FONT=font, YTITLE=title, _EXTRA=extra, YMINOR=minor, YTICKNAME=ticknames, YLOG=ylog
+
+ ENDIF ELSE BEGIN
+
+ PLOT, [minrange,maxrange], [minrange,maxrange], /NODATA, XTICKS=1, $
+ YTICKS=divisions, YSTYLE=1, XSTYLE=1, TITLE=title, $
+ POSITION=position, COLOR=color, CHARSIZE=charsize, /NOERASE, $
+ XTICKFORMAT='(A1)', YTICKFORMAT=format, YMinor=minor, _EXTRA=extra, $
+ YTICKNAME=ticknames, YLOG=ylog, YTICKLEN=ticklen
+
+ ENDELSE
+
+ ENDIF ELSE BEGIN
+
+ IF KEYWORD_SET(top) THEN BEGIN
+
+ PLOT, [minrange,maxrange], [minrange,maxrange], /NODATA, XTICKS=divisions, $
+ YTICKS=1, XSTYLE=9, YSTYLE=1, $
+ POSITION=position, COLOR=color, CHARSIZE=charsize, /NOERASE, $
+ YTICKFORMAT='(A1)', XTICKFORMAT='(A1)', XTICKLEN=ticklen, $
+ XRANGE=[minrange, maxrange], FONT=font, XMINOR=minor,_EXTRA=extra, $
+ XTICKNAME=ticknames, XLOG=xlog
+
+ AXIS, XTICKS=divisions, XSTYLE=1, COLOR=color, CHARSIZE=charsize, $
+ XTICKFORMAT=format, XTICKLEN=ticklen, XRANGE=[minrange, maxrange], XAXIS=1, $
+ FONT=font, XTITLE=title, _EXTRA=extra, XCHARSIZE=charsize, XMINOR=minor, $
+ XTICKNAME=ticknames, XLOG=xlog
+
+ ENDIF ELSE BEGIN
+
+ PLOT, [minrange,maxrange], [minrange,maxrange], /NODATA, XTICKS=divisions, $
+ YTICKS=1, XSTYLE=1, YSTYLE=1, TITLE=title, $
+ POSITION=position, COLOR=color, CHARSIZE=charsize, /NOERASE, $
+ YTICKFORMAT='(A1)', XTICKFORMAT=format, XTICKLEN=ticklen, $
+ XRANGE=[minrange, maxrange], FONT=font, XMinor=minor, _EXTRA=extra, $
+ XTICKNAME=ticknames, XLOG=xlog
+
+ ENDELSE
+
+ ENDELSE
+
+ ; Restore the previous plot and map system variables.
+ !P = bang_p
+ !X = bang_x
+ !Y = bang_y
+ !Z = bang_z
+ !Map = bang_map
+
+END
diff --git a/IDL/UTILITIES/openps.pro b/IDL/UTILITIES/openps.pro
new file mode 100755
index 0000000..45de1bf
--- /dev/null
+++ b/IDL/UTILITIES/openps.pro
@@ -0,0 +1,130 @@
+;+
+;
+; @file_comments
+; switch to postscript mode and define it
+;
+; @param namepsin {in}{optional}
+; name of the postscript file.
+; Extension '.ps' is added if missing. It will be stored in the psdir directory.
+;
+; @keyword FILENAME
+; to define the name of the postscript file through a keyword rather than with
+; namepsin input argument (in this case the keyword can be pass through
+; different routines via _EXTRA keyword).
+;
+; @keyword INFOWIDGET
+; If INFOWIDGET is present, it specifies a named variable into which the id of
+; the widget giving information about the postscript creation is stored as a
+; long integer.
+; This id is needed by closeps to kill the information widget.
+;
+; @keyword KEEP_PFONT
+; activate to suppress the modification of !p.font
+; (by default we force !p.font = 0 to make smaller postscripts)
+;
+; @keyword PORTRAIT
+;
+; @keyword LANDSCAPE
+;
+; @keyword KEEPPFONT
+; same as keep_pfont
+;
+; @keyword LIGHTNESS
+; a scalar used to change the Lightness of the color palette to be able to
+; adjust according to the printer we use, the media (paper or slide)...
+; > 1 to get darker colors
+;
+; @keyword _EXTRA
+; Used to pass keywords to DEVICE.
+;
+; @uses
+; cm_4ps
+;
+; @history
+; Sebastien Masson (smasson\@lodyc.jussieu.fr)
+; 21/12/98
+; 1/2/98: ajout de nameps en input
+; 1/9/1999: ajout du mot cle FILENAME et du widget
+; June 2005: Sebastien Masson, cleaning, english version with new commons
+;
+; @version
+; $Id: openps.pro 371 2008-08-07 09:32:02Z pinsard $
+;
+;-
+PRO openps, namepsin, FILENAME=filename, PAGE_SIZE=page_size $
+ , KEEPPFONT=keeppfont, KEEP_PFONT=keep_pfont $
+ , PORTRAIT=key_portrait, LANDSCAPE=landscape $
+ , LIGHTNESS=Lightness, _EXTRA=ex
+;
+;
+ compile_opt idl2, strictarrsubs
+;
+ IF lmgr(/demo) EQ 1 THEN BEGIN
+ dummy = report('impossible to create a PS in demo mode')
+ return
+ ENDIF
+;
+;@cm_4ps
+IF NOT keyword_set(key_forgetold) THEN BEGIN
+;@updatenew
+ENDIF
+;------------------------------------------------------------
+; close the postscript device if we are already in postscript mode
+ IF !d.name EQ 'PS' THEN device, /close
+; switch to postscript mode
+ set_plot,'ps'
+;------------------------------------------------------------
+; if we use keyword Lightness
+; save the actual color palette in a temporary file
+; (to be restored when calling closeps
+;------------------------------------------------------------
+ IF n_elements(Lightness) NE 0 THEN BEGIN
+ IF Lightness NE 1 THEN BEGIN
+ tvlct, red, green, blue, /get
+ def_myuniquetmpdir
+ save, red, green, blue, filename = myuniquetmpdir + 'original_colors.dat'
+ palit, Lightness, red, green, blue
+ ENDIF
+ ENDIF
+;------------------------------------------------------------
+; we define the name of the file
+;------------------------------------------------------------
+ CASE 1 OF
+ n_params() EQ 1:nameps = namepsin
+ keyword_set(filename): nameps = filename
+ ELSE:nameps = xquestion('Name of the postscript file?', 'idl.ps', /chkwid)
+ ENDCASE
+; make sure that nameps ends with '.ps'
+ nameps = file_dirname(nameps, /mark_directory) + $
+ file_basename(nameps, '.ps') + '.ps'
+; add path (psdir) and check that nameps is ok
+; nameps = isafile(nameps, iodir = psdir, /new)
+;------------------------------------------------------------
+; we define xsize, ysize, xoffset and yoffset
+;------------------------------------------------------------
+ IF n_elements(portrait) NE 0 OR n_elements(landscape) NE 0 THEN $
+ key_portrait = keyword_set(portrait) * (1 - keyword_set(landscape))
+
+ if key_portrait EQ 1 then begin
+ xs = min(page_size)
+ ys = max(page_size)
+ xoff = 0.
+ yoff = 0.
+ ENDIF ELSE BEGIN
+ xs = max(page_size)
+ ys = min(page_size)
+ xoff = 0.
+ yoff = max(page_size)
+ ENDELSE
+;------------------------------------------------------------
+; We define the device of the postscript mode
+;------------------------------------------------------------
+ device, /color, /Helvetica, filename = strcompress(nameps, /remove_all) $
+ , LANDSCAPE = 1 - key_portrait, PORTRAIT = key_portrait $
+ , xsize = xs, ysize = ys, xoffset = xoff, yoffset = yoff $
+ , bits_per_pixel = 8, language_level = 2, _EXTRA = ex
+; to make smaller postcripts
+ IF NOT (keyword_set(keeppfont) OR keyword_set(keep_pfont)) $
+ THEN !p.font = 0
+ RETURN
+END
diff --git a/IDL/UTILITIES/read_depth_hycom.pro b/IDL/UTILITIES/read_depth_hycom.pro
new file mode 100755
index 0000000..a955fc0
--- /dev/null
+++ b/IDL/UTILITIES/read_depth_hycom.pro
@@ -0,0 +1,35 @@
+PRO read_depth_hycom, im, jm, file, bathy
+
+ ;; Script to read the HYCOM bathymetry file
+ ;; A. Bozec Aug, 2011
+
+ close,/all
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(idm)
+ ijdm = idm1*jdm
+
+
+ ;; NPAD size and Tabs definition
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ toto = fltarr(npad)
+ bathy = fltarr(idm, jdm)
+
+
+ ;; Grid Directory and file
+ file1 = file
+
+ ;; READING the file
+ openu, 1, file1, /swap_endian
+ readu, 1, rr2
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO bathy(i, j) = rr2(j*idm1+i)
+ ENDFOR
+ close, 1
+
+ ;; Mask the bathymetry
+ bathy(where(bathy GT 1e20)) = !values.f_nan
+
+END
diff --git a/IDL/UTILITIES/read_grid_hycom.pro b/IDL/UTILITIES/read_grid_hycom.pro
new file mode 100755
index 0000000..7df8243
--- /dev/null
+++ b/IDL/UTILITIES/read_grid_hycom.pro
@@ -0,0 +1,95 @@
+PRO read_grid_hycom, im, jm, io, file, plon, plat, ulon, ulat, vlon, vlat, qlon, qlat, pang, pscx, pscy, qscx, qscy, uscx, uscy, vscx, vscy, cori, pasp
+
+ ;; Script to read the HYCOM grid file
+ ;; A. Bozec Aug, 2011
+
+ close,/all
+
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(im)
+ ijdm = idm1*jdm
+
+ tt = fltarr(idm, jdm, 19)
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ if (npad NE 4096) then toto = fltarr(npad)
+
+ ;; Grid Directory and file
+ iodir = io
+ plon = fltarr(idm, jdm)
+ plat = fltarr(idm, jdm)
+
+ qlon = fltarr(idm, jdm)
+ qlat = fltarr(idm, jdm)
+
+ ulon = fltarr(idm, jdm)
+ ulat = fltarr(idm, jdm)
+
+ vlon = fltarr(idm, jdm)
+ vlat = fltarr(idm, jdm)
+
+ pang= fltarr(idm, jdm)
+ pscx = fltarr(idm, jdm)
+ pscy = fltarr(idm, jdm)
+
+ qscx = fltarr(idm, jdm)
+ qscy = fltarr(idm, jdm)
+
+ uscx = fltarr(idm, jdm)
+ uscy = fltarr(idm, jdm)
+
+ vscx = fltarr(idm, jdm)
+ vscy = fltarr(idm, jdm)
+
+ cori = fltarr(idm, jdm)
+ pasp = fltarr(idm, jdm)
+
+ openu, 1, iodir+file, /swap_endian
+ FOR jk = 0, 18 DO BEGIN
+ if (npad NE 4096) then begin
+ readu, 1, rr2, toto
+ endif else begin
+ readu, 1, rr2
+ endelse
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO tt(i, j, jk) = rr2(j*idm1+i)
+ ENDFOR
+ ENDFOR
+
+ plon(*, *) = tt(*, *, 0)
+ plat(*, *) = tt(*, *, 1)
+
+ qlon(*, *) = tt(*, *, 2)
+ qlat(*, *) = tt(*, *, 3)
+
+ ulon(*, *) = tt(*, *, 4)
+ ulat(*, *) = tt(*, *, 5)
+
+ vlon(*, *) = tt(*, *, 6)
+ vlat(*, *) = tt(*, *, 7)
+
+ pang(*, *) = tt(*, *, 8)
+
+ pscx(*, *) = tt(*, *, 9)
+ pscy(*, *) = tt(*, *, 10)
+
+ qscx(*, *) = tt(*, *, 11)
+ qscy(*, *) = tt(*, *, 12)
+
+ uscx(*, *) = tt(*, *, 13)
+ uscy(*, *) = tt(*, *, 14)
+
+ vscx(*, *) = tt(*, *, 15)
+ vscy(*, *) = tt(*, *, 16)
+
+ cori(*, *) = tt(*, *, 17)
+ pasp(*, *) = tt(*, *, 18)
+
+ close, 1
+
+
+END
diff --git a/IDL/UTILITIES/sigma0_hycom.pro b/IDL/UTILITIES/sigma0_hycom.pro
new file mode 100755
index 0000000..652a44b
--- /dev/null
+++ b/IDL/UTILITIES/sigma0_hycom.pro
@@ -0,0 +1,15 @@
+FUNCTION sigma0_hycom, T, S
+
+
+;;
+;; --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1= -1.36471E-01 & C2= 4.68181E-02
+ C3= 8.07004E-01 & C4=-7.45353E-03
+ C5= -2.94418E-03 & C6= 3.43570E-05
+ C7= 3.48658E-05
+
+;; --- sigma-theta as a function of temp (deg c) and salinity (mil)
+ SIG=(C1+C3*S+T*(C2+C5*S+T*(C4+C7*S+C6*T)))
+
+return,SIG
+end
diff --git a/IDL/UTILITIES/sigma2_hycom.pro b/IDL/UTILITIES/sigma2_hycom.pro
new file mode 100755
index 0000000..a785680
--- /dev/null
+++ b/IDL/UTILITIES/sigma2_hycom.pro
@@ -0,0 +1,15 @@
+FUNCTION sigma2_hycom, T, S
+
+
+;;
+;; --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00 & C2=-2.26493E-02
+ C3= 7.89879E-01 & C4=-6.43205E-03
+ C5=-2.62983E-03 & C6= 2.75835E-05
+ C7= 3.15235E-05
+
+;; --- sigma-theta as a function of temp (deg c) and salinity (mil)
+ SIG=(C1+C3*S+T*(C2+C5*S+T*(C4+C7*S+C6*T)))
+
+return,SIG
+end
diff --git a/IDL/UTILITIES/sofsig.pro b/IDL/UTILITIES/sofsig.pro
new file mode 100755
index 0000000..bc2c440
--- /dev/null
+++ b/IDL/UTILITIES/sofsig.pro
@@ -0,0 +1,23 @@
+FUNCTION sofsig, T, R, sig
+
+ IF (sig EQ 2) THEN BEGIN
+;; --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00 & C2=-2.26493E-02
+ C3= 7.89879E-01 & C4=-6.43205E-03
+ C5=-2.62983E-03 & C6= 2.75835E-05
+ C7= 3.15235E-05
+ ENDIF
+
+ IF (sig EQ 0) THEN BEGIN
+;; --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1=-1.36471E-01 & C2= 4.68181E-02
+ C3= 8.07004E-01 & C4=-7.45353E-03
+ C5=-2.94418E-03 & C6= 3.43570E-05
+ C7= 3.48658E-05
+ ENDIF
+;
+; --- salinity (mil) as a function of sigma and temperature (deg c)
+ sof=(R-C1-T*(C2+T*(C4+C6*T)))/(C3+T*(C5+C7*T))
+
+return,sof
+end
diff --git a/IDL/UTILITIES/spherdist.pro b/IDL/UTILITIES/spherdist.pro
new file mode 100755
index 0000000..aeee9eb
--- /dev/null
+++ b/IDL/UTILITIES/spherdist.pro
@@ -0,0 +1,81 @@
+FUNCTION spherdist, lon1, lat1, lon2, lat2
+
+;;
+;; --- ------------------------------------------------
+;; --- Computes the distance between geo. pos.
+;; --- lon1,lat1 and lon2,lat2.
+;; --- input is in degrees.
+;;
+;; --- output is real*4 for better global consistancy,
+;; --- by truncating double precision roundoff errors.
+;; --- real*4 is not in f90, but is widely supported.
+;;
+;; --- Based on m_spherdist.F90 from Geir Evanson.
+;; --- ------------------------------------------------
+;;
+ invradian=double(0.017453292)
+ rearth=double(6371001.0) ; Radius of earth
+ deg360 = double(360.)
+ deg0 = double(0.)
+ deg90 = double(90.)
+ one = double(1.)
+;;
+;;
+;; ensure that spherdist(ax,ay,bx,by) == spherdist(bx,by,ax,ay)
+;;
+ dlon1 = double(lon1)
+ dlon1 = dlon1 MOD deg360
+ IF (dlon1 LT deg0) THEN dlon1 = dlon1 + deg360
+ lat1 = double(lat1)
+
+ dlon2 = double(lon2)
+ dlon2 = dlon2 MOD deg360
+ IF(dlon2 LT deg0) THEN dlon2 = dlon2 + deg360
+ lat2 = double(lat2)
+
+ CASE 1 OF
+ (lat1 LT lat2) : BEGIN
+ rlon1=dlon1*invradian ;lon1 in rad
+ rlat1=(deg90-lat1)*invradian ;90-lat1 in rad
+ rlon2=dlon2*invradian ;lon2 in rad
+ rlat2=(deg90-lat2)*invradian ;90-lat2 in rad
+ END
+ (lat1 EQ lat2) AND (dlon1 LE dlon2) : BEGIN
+ rlon1=dlon1*invradian ;lon1 in rad
+ rlat1=(deg90-lat1)*invradian ;90-lat1 in rad
+ rlon2=dlon2*invradian ;lon2 in rad
+ rlat2=(deg90-lat2)*invradian ;90-lat2 in rad
+ END
+ ELSE : BEGIN
+ rlon2=dlon1*invradian ;lon1 in rad
+ rlat2=(deg90-lat1)*invradian ;90-lat1 in rad
+ rlon1=dlon2*invradian ;lon2 in rad
+ rlat1=(deg90-lat2)*invradian ;90-lat2 in rad
+ END
+ ENDCASE
+
+
+
+;;;
+ x1= sin(rlat1)*cos(rlon1) ;x,y,z of pos 1.
+ y1= sin(rlat1)*sin(rlon1)
+ z1= cos(rlat1)
+;;
+ x2= sin(rlat2)*cos(rlon2) ;x,y,z of pos 2.
+ y2= sin(rlat2)*sin(rlon2)
+ z2= cos(rlat2)
+;;
+ dr=acos(min([one,x1*x2+y1*y2+z1*z2])) ; Arc length
+;;
+ spher=dr*rearth
+ spher = float(spher)
+;;
+return, spher
+
+
+
+; lon1 = -60.08
+; lon2 = -60.00
+; lat1 = 35.08
+; lat2 = 35.08
+END
diff --git a/IDL/UTILITIES/sub_var2.pro b/IDL/UTILITIES/sub_var2.pro
new file mode 100755
index 0000000..c047470
--- /dev/null
+++ b/IDL/UTILITIES/sub_var2.pro
@@ -0,0 +1,56 @@
+PRO sub_var2, im, jm, fName, num2, ivar, var
+
+
+ ;; Script to read a 2-D variable from hycom archive file
+ ;;----------------------------------------------------------------------
+ ;; Input:
+ ;; fName : file name '.a'
+ ;; im, jm : dimension for full domain
+ ;; num2 : number of 2d variables -- .b
+ ;; ivar : index of the 2d variable
+ ;;----------------------------------------------------------------------
+ ;;
+ ;; A. Bozec May, 2013
+
+ close,/all
+
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(im)
+ ijdm = idm1*jdm
+
+ tt = fltarr(idm, jdm, num2)
+
+ si_2d = num2
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ toto = fltarr(npad)
+
+ ;; Directory and file
+ iodir = fName
+
+ ;; Tab Declaration
+ var = fltarr(idm, jdm)
+
+ ;; Open file
+ openr, 1, iodir, /swap_endian
+
+ ;; Read 2D fields
+ FOR jk = 0, si_2d-1 DO BEGIN
+ readu, 1, rr2, toto
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO tt(i, j, jk) = rr2(j*idm1+i)
+ ENDFOR
+ ENDFOR
+ var(*, *) = tt(*, *, ivar-1)
+
+ close, 1
+
+ ;; Put nan on missing values
+ var(where(var GT 1e20)) = !values.f_nan
+
+END
+
diff --git a/IDL/UTILITIES/sub_var3.pro b/IDL/UTILITIES/sub_var3.pro
new file mode 100755
index 0000000..770406f
--- /dev/null
+++ b/IDL/UTILITIES/sub_var3.pro
@@ -0,0 +1,68 @@
+PRO sub_var3, im, jm, km, fName, num2, num3, ivar, var
+
+
+ ;; Script to read a 3-D variable from hycom archive file
+ ;;----------------------------------------------------------------------
+ ;; Input:
+ ;; fName : file name '.a'
+ ;; im, jm, km : dimension for full domain
+ ;; num2/3 : number of 2d/3d variables -- .b
+ ;; ivar : index of the 3d variable (starting from 1st num3)
+ ;;----------------------------------------------------------------------
+ ;;
+ ;; A. Bozec May, 2013
+
+ close,/all
+
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(im)
+ ijdm = idm1*jdm
+ kdm = km
+
+ tt = fltarr(idm, jdm, num2)
+ tt1 = fltarr(idm, jdm, num3)
+
+ si_2d = num2
+ si_3d = num3
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ toto = fltarr(npad)
+
+ ;; Directory and file
+ iodir = fName
+
+ ;; Tab Declaration
+ var = fltarr(idm, jdm, kdm)
+
+ ;; Open file
+ openr, 1, iodir, /swap_endian
+
+ ;; Read 2D fields
+ FOR jk = 0, si_2d-1 DO BEGIN
+ readu, 1, rr2, toto
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO tt(i, j, jk) = rr2(j*idm1+i)
+ ENDFOR
+ ENDFOR
+
+ ;; Read 3D fields
+ FOR ll = 0, kdm-1 DO BEGIN
+ FOR jk = 0, si_3d-1 DO BEGIN
+ readu, 1, rr2, toto
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO tt1(i, j, jk) = rr2(j*idm1+i)
+ ENDFOR
+ ENDFOR
+ var(*, *, ll) = tt1(*, *, ivar-1)
+ ENDFOR
+ close, 1
+ ;; Put nan on missing values
+ var(where(var GT 1e20)) = !values.f_nan
+
+
+END
+
diff --git a/IDL/UTILITIES/tofsig.pro b/IDL/UTILITIES/tofsig.pro
new file mode 100755
index 0000000..a3930f1
--- /dev/null
+++ b/IDL/UTILITIES/tofsig.pro
@@ -0,0 +1,42 @@
+FUNCTION tofsig, S, R, sig
+
+ IF (sig EQ 2.) THEN BEGIN
+;; --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00 & C2=-2.26493E-02
+ C3= 7.89879E-01 & C4=-6.43205E-03
+ C5=-2.62983E-03 & C6= 2.75835E-05
+ C7= 3.15235E-05
+ ENDIF
+ IF (sig EQ 0.) THEN BEGIN
+;; --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1=-1.36471E-01 & C2= 4.68181E-02
+ C3= 8.07004E-01 & C4=-7.45353E-03
+ C5=-2.94418E-03 & C6= 3.43570E-05
+ C7= 3.48658E-05
+ ENDIF
+
+
+ AZERO =0.d
+ AHALF =1/2.d
+ ATHIRD =1/3.d
+ A1P5 =3.0/2d
+;; --- auxiliary statements for finding root of 3rd degree polynomial
+ A0=(C1+C3*S -R)/C6
+ A1=(C2+C5*S)/C6
+ A2=(C4+C7*S)/C6
+ CUBQ=ATHIRD*A1-(ATHIRD*A2)^2
+ CUBR=ATHIRD*(AHALF*A1*A2-A1P5*A0) -(ATHIRD*A2)^3
+;; --- if q**3+r**2>0, water is too dense to yield real root at given
+;; --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+;; --- lowering sigma until a double real root is obtained.
+ CUBAN=ATHIRD*ATAN(SQRT(MAX([AZERO,-(CUBQ^3+CUBR^2)])),CUBR)
+ CUBRL=SQRT(-CUBQ)*COS(CUBAN)
+ CUBIM=SQRT(-CUBQ)*SIN(CUBAN)
+
+; --- temp (deg c) as a function of sigma and salinity (mil)
+ TOF=-CUBRL+SQRT(3.)*CUBIM-ATHIRD*A2
+
+
+
+return,TOF
+end
diff --git a/IDL/UTILITIES/write_depth_hycom.pro b/IDL/UTILITIES/write_depth_hycom.pro
new file mode 100755
index 0000000..75dd1e4
--- /dev/null
+++ b/IDL/UTILITIES/write_depth_hycom.pro
@@ -0,0 +1,47 @@
+PRO write_depth_hycom, im, jm, file, bathy
+
+
+ close,/all
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(idm)
+ ijdm = idm1*jdm
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ toto = fltarr(npad)
+
+ ;; mask for min max
+ tt = bathy
+ ind = where(tt GT 1e20)
+ IF (ind NE [-1] ) THEN tt(ind) = !values.f_nan
+
+ file1 = file
+
+ ;; READING the file
+ openw, 1, file+'.a', /swap_endian
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO rr2(j*idm1+i) = bathy(i, j)
+ ENDFOR
+ writeu, 1, rr2, toto
+ close, 1
+
+ ;; REWRITE .B
+
+ openw,1,file+'.b'
+ printf, 1, format = '(A10)', 'Bathymetry'
+ printf, 1, format = '(A5,1x,i4,1x,i3)', 'i/jdm ', idm, jdm
+ printf, 1, format = '(A1)', ' '
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A18,1x,f8.3,2x,f8.3)','min,max depth = ', min(tt, /nan), max(tt, /nan)
+
+ close,1
+
+
+
+
+
+END
diff --git a/IDL/UTILITIES/write_grid_hycom.pro b/IDL/UTILITIES/write_grid_hycom.pro
new file mode 100755
index 0000000..d7dd7fd
--- /dev/null
+++ b/IDL/UTILITIES/write_grid_hycom.pro
@@ -0,0 +1,100 @@
+PRO write_grid_hycom, im, jm, io, file, plon, plat, ulon, ulat, vlon, vlat, qlon, qlat, pang, pscx, pscy, qscx, qscy, uscx, uscy, vscx, vscy, cori, pasp
+
+
+ close,/all
+
+; im = 271 & jm = 193
+; im = 541 & jm = 385
+; io = '/Users/abozec/IDL/IDL_DATA/GOMl0.08/topo/'
+; file = 'regional.grid.a'
+; file = 'regional.grid.GOMl0.04.a'
+
+ ;; Dimensions of the domain
+ idm = im
+ jdm = jm
+ idm1 = float(im)
+ ijdm = idm1*jdm
+
+ tt2 = fltarr(idm, jdm, 19)
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ if (npad NE 4096) then toto = fltarr(npad)
+
+ ;; Grid Directory and file
+ iodir = io
+; file = 'regional.grid.a'
+
+ tt2(*, *, 0) = plon(*, *)
+ tt2(*, *, 1) = plat(*, *)
+
+ tt2(*, *, 2) = qlon(*, *)
+ tt2(*, *, 3) = qlat(*, *)
+
+ tt2(*, *, 4) = ulon(*, *)
+ tt2(*, *, 5) = ulat(*, *)
+
+ tt2(*, *, 6) = vlon(*, *)
+ tt2(*, *, 7) = vlat(*, *)
+
+ tt2(*, *, 8) = pang(*, *)
+
+ tt2(*, *, 9) = pscx(*, *)
+ tt2(*, *, 10) = pscy(*, *)
+
+ tt2(*, *, 11) = qscx(*, *)
+ tt2(*, *, 12) = qscy(*, *)
+
+ tt2(*, *, 13) = uscx(*, *)
+ tt2(*, *, 14) = uscy(*, *)
+
+ tt2(*, *, 15) = vscx(*, *)
+ tt2(*, *, 16) = vscy(*, *)
+
+ tt2(*, *, 17) = cori(*, *)
+ tt2(*, *, 18) = pasp(*, *)
+
+ openw, 1, io+file+'.a', /swap_endian
+ FOR jk = 0, 18 DO BEGIN
+ FOR j = 0, jm-1 DO BEGIN
+ FOR i = 0, im-1 DO rr2(j*idm1+i) =tt2(i, j, jk)
+ ENDFOR
+ if (npad NE 4096) then begin
+ writeu, 1, rr2, toto
+ endif else begin
+ writeu, 1, rr2
+ endelse
+ ENDFOR
+ close, 1
+
+
+ ;; Writing .b file
+ openw,1,io+file+'.b'
+ printf, 1, format = '(i8,1x,A33)', im, '''idm '' = longitudinal array size'
+ printf, 1, format = '(i8,1x,A32)', jm, '''jdm '' = latitudinal array size'
+ printf, 1, format = '(i8,1x,A53)', 0, '''mapflg'' = map flag (0=mercator,10=panam,12=ulon-panam)'
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','plon: min,max = ', min(tt2(*,*,0)), max(tt2(*,*,0))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','plat: min,max = ', min(tt2(*,*,1)), max(tt2(*,*,1))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','qlon: min,max = ', min(tt2(*,*,2)), max(tt2(*,*,2))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','qlat: min,max = ', min(tt2(*,*,3)), max(tt2(*,*,3))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','ulon: min,max = ', min(tt2(*,*,4)), max(tt2(*,*,4))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','ulat: min,max = ', min(tt2(*,*,5)), max(tt2(*,*,5))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','vlon: min,max = ', min(tt2(*,*,6)), max(tt2(*,*,6))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','vlat: min,max = ', min(tt2(*,*,7)), max(tt2(*,*,7))
+ printf, 1, format = '(A18,1x,E14.5,1x,E14.5)','pang: min,max = ', min(tt2(*,*,8)), max(tt2(*,*,8))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','pscx: min,max = ', min(tt2(*,*,9)), max(tt2(*,*,9))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','pscy: min,max = ', min(tt2(*,*,10)), max(tt2(*,*,10))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','qscx: min,max = ', min(tt2(*,*,11)), max(tt2(*,*,11))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','qscy: min,max = ', min(tt2(*,*,12)), max(tt2(*,*,12))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','uscx: min,max = ', min(tt2(*,*,13)), max(tt2(*,*,13))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','uscy: min,max = ', min(tt2(*,*,14)), max(tt2(*,*,14))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','vscx: min,max = ', min(tt2(*,*,15)), max(tt2(*,*,15))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','vscy: min,max = ', min(tt2(*,*,16)), max(tt2(*,*,16))
+ printf, 1, format = '(A18,1x,E14.5,1x,E14.5)','cori: min,max = ', min(tt2(*,*,17)), max(tt2(*,*,17))
+ printf, 1, format = '(A18,1x,f14.5,1x,f14.5)','pasp: min,max = ', min(tt2(*,*,18)), max(tt2(*,*,18))
+ close,1
+
+
+END
+
diff --git a/IDL/UTILITIES/write_relax_hycom.pro b/IDL/UTILITIES/write_relax_hycom.pro
new file mode 100755
index 0000000..2641ea9
--- /dev/null
+++ b/IDL/UTILITIES/write_relax_hycom.pro
@@ -0,0 +1,93 @@
+PRO write_relax_hycom, im, jm, km, io, file, field, d, res
+
+
+ ;; field='intf'
+ ;; field='temp'
+ ;; field='saln'
+ ;; d(kdm); target density
+
+ CASE (field) OF
+ 'intf': BEGIN
+ long_name = 'Interface Depths'
+ short_name = 'int'
+ END
+ 'temp': BEGIN
+ long_name = 'Potential Temperature'
+ short_name = 'tem'
+ END
+ 'saln': BEGIN
+ long_name = 'Salinity'
+ short_name = 'sal'
+ END
+
+ ENDCASE
+
+ close,/all
+
+ ;; Dimensions of the domain
+ kdm = km
+ idm = im
+ jdm = jm
+ idm1 = float(idm)
+ ijdm = idm1*jdm
+
+ ;; NPAD size
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ if (npad NE 4096) then toto = fltarr(npad)
+
+ ;; Grid Directory and file
+ file1 = io+file
+
+ ;; WRITING .a binary file
+ openw, 1, file1+'.a', /swap_endian
+ For t=0,11 do begin
+ FOR k = 0, kdm-1 DO BEGIN
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO rr2(j*idm1+i) = res(i, j, k, t)
+ ENDFOR
+ if (npad NE 4096) then begin
+ writeu, 1, rr2, toto
+ endif else begin
+ writeu, 1, rr2
+ endelse
+ ENDFOR
+ ENDFOR
+ close, 1
+
+
+ ;; WRITING .b text file
+ mo = findgen(12)+1
+ months = string(mo, format ='(i2.2)')
+ l = findgen(kdm)+1
+ layer = string(l, format ='(i2.2)')
+ density = d
+
+ ;; mask the field by nan
+ index = where(res GT 1e20)
+ IF (index NE [-1]) THEN res(index) = !values.f_nan
+
+ openw,1,file1+'.b'
+ printf, 1, format = '(A)', ''+long_name
+ printf, 1, format = '(A)', ''
+ printf, 1, format = '(A)', ''
+ printf, 1, format = '(A)', ''
+ printf, 1, format = '(A5,1x,i3,1x,i3)', 'i/jdm ', idm, jdm
+
+
+ FOR m = 0, 11 DO BEGIN
+ FOR k = 0, kdm-1 DO BEGIN
+ printf, 1, format = '(A,1x,i2.2,1x,i2.2,2x,f6.3,2x,E14.7,2x,E14.7)',' '+short_name+': month,layer,dens,range =', m+1, k+1, density(k), min(res(*, *, k), /nan), max(res(*, *, k), /nan)
+
+ ENDFOR
+ ENDFOR
+ close,1
+
+
+
+
+
+END
+
+
+
diff --git a/IDL/plot_res_bb86.pro b/IDL/plot_res_bb86.pro
new file mode 100755
index 0000000..8bbf1dd
--- /dev/null
+++ b/IDL/plot_res_bb86.pro
@@ -0,0 +1,256 @@
+PRO plot_res_bb86
+
+ close, /all
+ ;; include the Utilities function
+ iodir = '/Net/yucatan/abozec/BB86_PACKAGE/IDL/' ;; where you are
+ !path=expand_path('+/'+iodir+'UTILITIES')+':'+expand_path('+'+!dir)
+
+ ;; PATH
+ io = '/Net/yucatan/abozec/BB86_PACKAGE/'
+ ;; domain
+ idm = 101 & jdm = 101 ;; size of the domain
+ kdm = 2 ;; number of vertical layer in BB86
+ tdm = 1800 ;; number of time-stamp in bb86
+ dp0 = 500. ;; thickness of the 1st layer (m)
+ eps = 0.0001 ;; epsilon to avoid dividing by 0.
+ tplot1 = 1800 & tplot2 = 1800 ;; time-stamp to plot (starts from 1.)
+
+ ;; postscript parameters
+ PS = 1 ;; save as postscript
+ key_portrait = 0
+ page_size = [21.5900, 27.9400] ;; letter size
+ file_ps = '../PS/uv_dp_d'+string(tplot2, format = '(i4.4)')+'_bb86-hycom.ps'
+
+ ;; constants
+ rho = 1000. ;; reference density
+ g = 9.806 ;; gravity
+
+
+ ;; Read grid
+ file_grid = 'regional.grid.BB86.a'
+ read_grid_hycom, idm, jdm, io+'topo/', file_grid, plon, plat
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; READ the HYCOM files
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ io_hycom = io+'expt_01.0/data/output/'
+
+ uhyc = fltarr(idm, jdm, kdm+1, tdm) ;; 1 more layer for the hybrid!!
+ vhyc = fltarr(idm, jdm, kdm+1, tdm)
+ dphyc = fltarr(idm, jdm, kdm+1, tdm)
+
+ FOR t = tplot1, tplot2 DO BEGIN
+ CASE 1 OF
+ (t LE 344): BEGIN
+ year = '0001'
+ day = string(t+16, format = '(i3.3)') ;; 16 u and v == 0. so we start at day 17.
+ END
+ (t GT 344) AND (t LE 704) : BEGIN
+ year = '0002'
+ day = string(t-344, format = '(i3.3)')
+ END
+ (t GT 704) AND (t LE 1064) : BEGIN
+ year = '0003'
+ day = string(t-704, format = '(i3.3)')
+ END
+ (t GT 1064) AND (t LE 1424) : BEGIN
+ year = '0004'
+ day = string(t-1064, format = '(i3.3)')
+ END
+ (t GT 1424) AND (t LE 1784) : BEGIN
+ year = '0005'
+ day = string(t-1424, format = '(i3.3)')
+ END
+ (t GT 1784) AND (t LE 2144) : BEGIN
+ year = '0006'
+ day = string(t-1784, format = '(i3.3)')
+ END
+ ENDCASE
+ file = 'archv.'+year+'_'+day+'_00.a'
+ print, file, t
+
+ ;; archive files 2D variable units (see archv.*.b for the list of available var.)
+ ;; montg1 : *1./g to get in m
+ ;; srfhgt : *1./g to get in m
+ ;; surflx : W/m2
+ ;; salflx : kg/m2/s
+ ;; bl_dpth : *1./(rho*g) to get in m
+ ;; mix_dpth: *1./(rho*g) to get in m
+ ;; u_btrop : m/s
+ ;; v_btrop : m/s
+
+ ;; extract barotropic velocities (ubarot & vbarot)
+ num2 = 8 ;; number of 2D variables in the archive file
+ ivar_ub = 7 ;; index of ubaro (7th 2D variable)
+ ivar_vb = 8 ;; index of vbaro (8th 2D variable)
+ sub_var2, idm, jdm, io_hycom+file, num2, ivar_ub, ubaro
+ sub_var2, idm, jdm, io_hycom+file, num2, ivar_vb, vbaro
+
+
+ ;; archive files 3D variable units (see archv.*.b for the list of available var.)
+ ;; u-vel. : m/s
+ ;; v-vel. : m/s
+ ;; thknss : *1./(rho*g) to get in m
+ ;; temp : C
+ ;; salin : psu
+
+ ;; extract velocities (ubaroc & vbaroc)
+ num3 = 5 ;; number of 3D variables in the archive file
+ ivar_u = 1 ;; index of u baroclinic
+ ivar_v = 2 ;; index of v baroclinic
+ sub_var3, idm, jdm, kdm+1, io_hycom+file, num2, num3, ivar_u, ubac
+ sub_var3, idm, jdm, kdm+1, io_hycom+file, num2, num3, ivar_v, vbac
+
+ ;; Get utot & vtot
+ FOR k = 0, kdm DO uhyc(*, *, k, t-1) = ubaro(*, *)+ubac(*, *, k)
+ FOR k = 0, kdm DO vhyc(*, *, k, t-1) = vbaro(*, *)+vbac(*, *, k)
+
+
+ ;; extract the layer thickness
+ ivar_dp = 3
+ sub_var3, idm, jdm, kdm+1, io_hycom+file, num2, num3, ivar_dp, dp
+ dphyc(*, *, *, t-1) = dp/(rho*g)
+
+
+ ;; put the u on the p-grid
+
+ ;; get the umask
+ index = where(finite(uhyc) EQ 0.)
+ maskt = fltarr(idm, jdm, kdm+1, tdm)+1
+ if (index NE [-1]) then maskt(index) = 0.
+ maxval = maskt+shift(maskt, -1, 0, 0, 0)
+ maxval(where(maxval EQ 0.)) = !values.f_nan
+
+ ;; get the average value of u at the p-point
+ uthyc = (uhyc+shift(uhyc, -1, 0, 0, 0))/maxval
+ uthyc(idm-1, *, *, *) = uthyc(idm-2, *, *, *)
+
+ ;; put the v on the p-grid
+
+ ;; get the vmask
+ index = where(finite(vhyc) EQ 0.)
+ maskt = fltarr(idm, jdm, kdm+1, tdm)+1
+ if (index NE [-1]) then maskt(index) = 0.
+ maxval = maskt+shift(maskt, 0, -1, 0, 0)
+ maxval(where(maxval EQ 0.)) = !values.f_nan
+
+ ;; get the average value of v at the p-point
+ vthyc = (vhyc+shift(vhyc, 0, -1, 0, 0))/maxval
+ vthyc(*, jdm-1, *, *) = vthyc(*, jdm-2, *, *)
+
+
+ ENDFOR
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; plot
+ for t = tplot1, tplot2 do begin
+
+ ;; norme, min and max of the plots
+ normeref_hyc = 0.05 ;; vector norm of HYCOM-BB86 (in m)
+ onevectout = 2 ;; plot one vector out of 'onevectorout'
+ min_dp = -450. & max_dp = 450. ;; layer thickness anomaly in m (min and max)
+
+
+ device, true_color = 24, decomposed = 0
+ IF (PS EQ 0 ) THEN BEGIN
+ dimensions = get_screen_size(RESOLUTION=resolution)
+ coef = floor(1./resolution[0])
+ windowsize_scale = 1.
+ coef = windowsize_scale * coef
+
+ mipgsz = min(page_size, max = mapgsz)
+
+ xsize = coef * (mipgsz*key_portrait + mapgsz*(1-key_portrait))
+ ysize = coef * (mipgsz*(1-key_portrait) + mapgsz*key_portrait)
+
+ window, 1, xsize = xsize, ysize = ysize
+ foreground = !P.Background & background = !P.Color
+ char = 1.
+ ENDIF
+ IF (PS EQ 1 ) THEN BEGIN
+ IF !d.name EQ 'PS' then device,/close
+ set_plot,'ps'
+ device, /color, /helvetica, filename = file_ps $
+ , LANDSCAPE = 1 - key_portrait, PORTRAIT = key_portrait $
+ , xsize = max(page_size), ysize = min(page_size), xoffset = 0., yoffset = max(page_size) $
+ , bits_per_pixel = 8
+ foreground = !P.Color & background = !P.Background
+ char = 0.75
+ ENDIF
+
+
+
+
+ loadct, 39 ;; color palette
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; HYCOM-BB86
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; get a blank plot
+ contour, reform(uthyc(*, *, 1, 0)), plon, plat, xstyle = 1, ystyle = 1, $
+ Color = foreground, Background = background, position = [0.1, 0.6, 0.45, 0.90], $
+ title = 'HYCOM-BB86 Velocity field day = '+string(t, format = '(i4.4)'), /nodata, $
+ xtitle = 'Longitude (E)', ytitle = 'Latitude (N)', charsize = char
+
+ ;; add the velocities vectors
+ ;; definition of ref vector (legend)
+ uref = fltarr(2, 2) & vref =fltarr(2, 2)
+ uref(0, 0) = 1
+
+ ;; get the vectors to plot
+ uu = reform(uthyc(0:idm-1:onevectout, 0:jdm-1:onevectout, 1, t-1))
+ vv = reform(vthyc(0:idm-1:onevectout, 0:jdm-1:onevectout, 1, t-1))
+ lon = reform(plon(0:idm-1:onevectout, 0))
+ lat = reform(plat(0, 0:jdm-1:onevectout))
+
+ ;; we normalize the vectors
+ normeref = normeref_hyc ;; in m
+ norme =sqrt(uu^2.+vv^2.)
+ normemax = max(norme, /nan)/normeref
+
+ ;; plotting
+ velovect, uu, vv, lon, lat, /overplot, color = 0., length = 3*normemax ;; ref vector over 3*dx
+
+ ;; add the ref vector in the legend take 3*dx (= 1.2º) as reference
+ velovect, uref, vref, [lon(3, 0), lon(4, 0)], [-1.2, 0.], /overplot, color = 0, length = 3
+ xyouts, 1.2, -2.5, string(normeref, format = '(f4.2)')+' m', color = 0
+
+
+
+ ;; plot the dp's
+ ;; defined colors
+ levels = 40
+ Minss = min_dp & Maxss = max_dp
+ step = (Maxss - Minss) / levels
+ num_level = IndGen(levels) * step + Minss
+ loadct, 33, ncolors = levels, bottom = 1
+
+ ;; get anomaly dp
+ diff_dp = reform(dphyc(*, *, 1, t-1)) -(dp0-1.)
+ diff_dp(where(finite(diff_dp) EQ 0)) = 0.
+ contour, diff_dp, plon, plat, xstyle = 1, ystyle = 1, levels = num_level, c_colors = indgen(levels), /fill, $
+ Color = foreground, Background = background, /follow, position = [0.5, 0.6, 0.85, 0.90], $
+ title = 'HYCOM-BB86 thickness ano. day = '+string(t, format = '(i4.4)'), $
+ xtitle = 'Longitude (E)', ytitle = 'Latitude (N)', /noerase, charsize = char
+ contour, diff_dp, plon, plat,levels = num_level, /overplot, color = 0
+
+ colorbar2, ncolors = levels, divisions = levels/4. , color = 0, range = [Minss, Maxss], $
+ position = [0.89, 0.60, 0.92, 0.9], format = '(f7.1)', /vertical, charsize = char
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ IF (PS EQ 1 ) THEN BEGIN
+ device, /close
+ set_plot, 'x'
+ ENDIF
+
+ device, decomposed = 1
+ endfor
+ stop
+
+END
diff --git a/IDL/write_depth_bb86.pro b/IDL/write_depth_bb86.pro
new file mode 100755
index 0000000..d830473
--- /dev/null
+++ b/IDL/write_depth_bb86.pro
@@ -0,0 +1,84 @@
+PRO write_depth_bb86
+
+ ;; include the Utilities functions
+ iodir = '/Net/yucatan/abozec/BB86_PACKAGE/IDL/' ;; where you are
+ !path=expand_path('+/'+iodir+'UTILITIES')+':'+expand_path('+'+!dir)
+
+ close, /all
+ ;; PATH
+ io = iodir+'/../topo/'
+ file_bat_new = 'depth_BB86_01' ;; !! without .a or .b !!
+ pl = 0 ;; 1 or 0 for plot or not
+
+ ;; size of the domain
+ idm = 101
+ jdm = 101
+
+ ;; definition of the bathymetry
+ depth = 5000. ;; constant bathy everywhere
+
+ ;; closed boundary (latbdy=0) or open boundaries (latbdy=1) or cyclic (latbdy =2)
+ latbdy = 0
+
+ ;;;;;;; END of the USER inputs ;;;;;;;;;;;;;;;
+
+ idm_hd = idm
+ jdm_hd = jdm
+ vmiss = 2.^100 ;; HYCOM missing values
+
+ ;; get the Depth
+ bathy_hd = fltarr(idm, jdm)
+ bathy_hd(*, *) = depth
+ print, 'Depth Ok'
+
+ ;; Plot
+ IF (pl EQ 1) THEN BEGIN
+ device, decomposed = 0
+
+ ;; defined colors
+ levels = 12
+ Minss = 4000. & Maxss = 6000.
+ step = (Maxss - Minss) / levels
+ num_level = IndGen(levels) * step + Minss
+ loadct, 33, ncolors = levels
+
+ ;; let's make a plot
+ window, 1, xsize = 800, ysize = 800
+ contour, bathy_hd, xstyle = 1, ystyle = 1, levels = num_level, c_colors = indgen(levels), /fill, $
+ Color = !P.Background, Background = !P.color, /follow, position = [0.15, 0.15, 0.85, 0.85]
+ colorbar2, ncolors = levels, divisions = levels, color = 0, range = [Minss, Maxss], $
+ position = [0.17, 0.08, 0.83, 0.10], format = '(f7.1)'
+
+ device, decomposed = 1
+ ENDIF
+
+ ;; Mask by missing values if any
+ ind = where(bathy_hd EQ 0.)
+ IF (ind NE [-1]) THEN bathy_hd (ind) = vmiss
+
+
+ ;; Get the edge of the domain right
+ CASE (latbdy) OF
+ 0: BEGIN
+ bathy_hd(*, jdm_hd-1) = vmiss
+ bathy_hd(idm_hd-1, *) = vmiss
+ bathy_hd(*, 0) = vmiss
+ bathy_hd(0, *) = vmiss
+ END
+ 1: BEGIN
+ bathy_hd(*, jdm_hd-1) = vmiss
+ bathy_hd(idm_hd-1, *) = vmiss
+ END
+ 2: BEGIN
+ bathy_hd(*, jdm_hd-1) = vmiss
+ bathy_hd(*, 0) = vmiss
+ END
+ ENDCASE
+
+
+ ;; write the file
+ write_depth_hycom, idm_hd, jdm_hd, io+file_bat_new, bathy_hd
+ print, 'Writing depth file done '
+
+ stop
+END
diff --git a/IDL/write_grid_bb86.pro b/IDL/write_grid_bb86.pro
new file mode 100755
index 0000000..253f1c5
--- /dev/null
+++ b/IDL/write_grid_bb86.pro
@@ -0,0 +1,134 @@
+PRO write_grid_bb86
+
+ ;; include the Utilities functions
+ iodir = '/Net/yucatan/abozec/BB86_PACKAGE/IDL/' ;; where you are
+ !path=expand_path('+/'+iodir+'UTILITIES')+':'+expand_path('+'+!dir)
+
+ close, /all
+ ;; PATH
+ io = iodir+'/../topo/'
+ file_grid_new = 'regional.grid.BB86' ;; !! without .a or .b !!
+
+ ;; size of the domain
+ idm = 101
+ jdm = 101
+
+ ;; longitude/latitude starting point + resolution (in degrees) (NB: those
+ ;; variables are not used in HYCOM)
+ ini_lon = 0.
+ ini_lat = 0.
+ res = 0.20
+
+ ;; scale dx and dy (in m) (used in HYCOM)
+ dx = 20e3
+ dy = dx
+
+
+ ;;;;;;; END of the USER inputs ;;;;;;;;;;;;;;;
+
+ ;; missing value in HYCOM
+ vmiss = 2.^100
+
+ ;; Get the p-point the grid
+ plon = fltarr(idm, jdm)
+ plat = fltarr(idm, jdm)
+
+ ;; Longitude
+ plon(0, *) = ini_lon
+ FOR i = 1, idm-1 DO plon(i, *) = plon(i-1, *) + res
+ ;; Latitude
+ plat(*, 0) = ini_lat
+ FOR j = 1, jdm-1 DO plat(*, j) = plat(*, j-1) + res
+
+ print, 'p-points grid OK'
+
+
+ ;; Declaration of the grid tabs
+ idm_hd = idm
+ jdm_hd = jdm
+
+ plon_hd = plon
+ plat_hd = plat
+
+ qlon_hd = fltarr(idm_hd, jdm_hd)
+ qlat_hd = fltarr(idm_hd, jdm_hd)
+ ulon_hd = fltarr(idm_hd, jdm_hd)
+ ulat_hd = fltarr(idm_hd, jdm_hd)
+ vlon_hd = fltarr(idm_hd, jdm_hd)
+ vlat_hd = fltarr(idm_hd, jdm_hd)
+
+ pang_hd = fltarr(idm_hd, jdm_hd)
+
+ pscx_hd = fltarr(idm_hd, jdm_hd)
+ pscy_hd = fltarr(idm_hd, jdm_hd)
+
+ qscx_hd = fltarr(idm_hd, jdm_hd)
+ qscy_hd = fltarr(idm_hd, jdm_hd)
+
+ uscx_hd = fltarr(idm_hd, jdm_hd)
+ uscy_hd = fltarr(idm_hd, jdm_hd)
+
+ vscx_hd = fltarr(idm_hd, jdm_hd)
+ vscy_hd = fltarr(idm_hd, jdm_hd)
+
+ cori_hd = fltarr(idm_hd, jdm_hd)
+ pasp_hd = fltarr(idm_hd, jdm_hd)
+
+
+ ;; Longitude/Latitude for each point
+ ;; longitude
+ vlon_hd = plon_hd
+ FOR i = 1, idm-1 DO BEGIN
+ qlon_hd(i, *) = 0.5*(plon_hd(i, *)+plon_hd(i-1, *))
+ ENDFOR
+ diff = plon_hd(2, 0)-plon_hd(1, 0)
+ qlon_hd(0, *) = plon_hd(0, *)-0.5*diff
+ ulon_hd = qlon_hd
+
+ ;; latitude
+ ulat_hd = plat_hd
+ FOR j = 1, jdm-1 DO BEGIN
+ qlat_hd(*, j) = 0.5*(plat_hd(*, j)+plat_hd(*, j-1))
+ ENDFOR
+ diff = plat_hd(0, 2)-plat_hd(0, 1)
+ qlat_hd(*, 0) = plat_hd(*, 0)-0.5*diff
+ vlat_hd = qlat_hd
+
+ ;; simplified grid with prescribed dx and dy
+ pscx_hd(*, *) = dx & pscy_hd(*, *) = dy
+ uscx_hd(*, *) = dx & uscy_hd(*, *) = dy
+ vscx_hd(*, *) = dx & vscy_hd(*, *) = dy
+ qscx_hd(*, *) = dx & qscy_hd(*, *) = dy
+
+ ;; Coriolis
+ beta = 2.E-11
+ FOR j= 0,jdm_hd-1 DO BEGIN
+ FOR i= 0,idm_hd-1 DO BEGIN
+ cori_hd(i, j)=.93e-4+float(j-(jdm_hd-2)/2)*dx*beta
+ ENDFOR
+ ENDFOR
+
+
+ ;; pang ( p-angle for rotated grid)
+ ;; here uniform or mercator so pang = 0.
+
+
+ ;; pasp= paspect: pscx/pscy
+
+ FOR j= 0,jdm_hd-1 DO BEGIN
+ FOR i= 0,idm_hd-1 DO BEGIN
+ pasp_hd(i,j) = pscx_hd(i,j)/pscy_hd(i,j)
+ ENDFOR
+ ENDFOR
+
+
+ ;; Writing new grid file
+ write_grid_hycom, idm_hd, jdm_hd, io, file_grid_new, plon_hd, plat_hd, ulon_hd, ulat_hd, vlon_hd, vlat_hd, qlon_hd, qlat_hd, pang_hd,pscx_hd, pscy_hd, qscx_hd, qscy_hd, uscx_hd, uscy_hd, vscx_hd, vscy_hd, cori_hd, pasp_hd
+
+ print, 'Writing grid file done '
+
+
+
+ stop
+
+END
diff --git a/IDL/write_relax_bb86.pro b/IDL/write_relax_bb86.pro
new file mode 100755
index 0000000..2ed4454
--- /dev/null
+++ b/IDL/write_relax_bb86.pro
@@ -0,0 +1,136 @@
+Forward_FUNCTION tofsig
+
+PRO write_relax_bb86
+
+ ;; include the Utilities functions
+ iodir = '/Net/yucatan/abozec/BB86_PACKAGE/IDL/' ;; where you are
+ !path=expand_path('+'+!dir)+':'+expand_path('+/'+iodir+'UTILITIES')
+
+ close, /all
+ ;; PATH
+ io = iodir+'../relax/010/'
+ file_topo = 'depth_BB86_01.a'
+ file_int_new = 'relax_int_BB86' ;; !! without .a or .b !!
+ file_tem_new = 'relax_tem_BB86'
+ file_sal_new = 'relax_sal_BB86'
+ pl = 0 ;; 1 or 0 for plot or not
+
+ ;; size of the domain
+ idm = 101
+ jdm = 101
+ kdm = 3 ;; number of layers (first layer very thin)
+ tdm = 12 ;; 12 month climatology
+
+ ;; interface depth
+ id = fltarr(kdm)
+ id = [0., 1.0, 500.] ;; first interface depth always 0.
+
+
+ ;; target density
+ ;; from bb86: rho=27.01037, rho=27.22136
+ d = fltarr(kdm)
+ d = [27.0100, 27.01037,27.22136]
+
+ ;; salinity profile
+ sa = fltarr(kdm)
+ sa = [37., 37., 37.]
+
+ ;;;;;;; END of the USER inputs ;;;;;;;;;;;;;;;
+
+ ;; constants
+ rho = 1000.
+ g = 9.806
+ vmiss = 2.^100
+
+ ;; temperature profile for sigma0
+ sigma = 0
+ te = fltarr(kdm)
+ FOR k = 0, kdm-1 DO te(k) = tofsig(sa(k), d(k), sigma)
+ print, te
+
+
+ ;; read bathy for mask
+ read_depth_hycom, idm, jdm, io+'../../topo/'+file_topo, bathy
+ ind = where(bathy GT 1e20)
+ IF (ind NE [-1]) THEN bathy(ind) = 0.
+ ;; create mask
+ mask2d = fltarr(idm, jdm)+1
+ mask2d(ind) = 0.
+ mask = fltarr(idm, jdm, kdm, tdm)
+ FOR t = 0, tdm-1 DO BEGIN
+ FOR k = 0, kdm-1 DO mask(*, *, k, t) = mask2d
+ ENDFOR
+
+ ;; interface depth files (first layer always the surface i.e. 0.)
+ int = fltarr(idm, jdm, kdm, tdm)
+ FOR k= 1, kdm-1 DO int(*, *, k, *) = rho*g * id(k) ;; 1st layer tiny to fake a two layer config
+
+ ;; make sure that the interface depths are not lower than the bathy
+ FOR t = 0, tdm-1 DO BEGIN
+ FOR k = 0, kdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO BEGIN
+ FOR j = 0, jdm-1 DO BEGIN
+ IF (int(i, j, k, t)/9806. GT bathy(i, j)) THEN int(i, j, k, t) = bathy(i,j)*9806.
+ ENDFOR
+ ENDFOR
+ ENDFOR
+ ENDFOR
+
+ ;; mask
+ ind3d = where(mask EQ 0.)
+ IF (ind3d NE [-1]) THEN int(ind3d) = vmiss
+
+ ;; write the field in relax file
+ write_relax_hycom, idm, jdm, kdm, io, file_int_new, 'intf', d, int
+ print, 'Interface depth OK'
+
+ ;; Temperature
+ tem = fltarr(idm, jdm, kdm, tdm)
+ FOR k = 0, kdm-1 DO tem(*, *, k, *) = te(k)
+
+ ;; mask
+ IF (ind3d NE [-1]) THEN tem(ind3d) = vmiss
+
+ ;; write the field in relax file
+ write_relax_hycom, idm, jdm, kdm, io, file_tem_new, 'temp', d, tem
+ print, 'Temperature OK'
+
+ ;; Salinity
+ sal = fltarr(idm, jdm, kdm, tdm)
+ FOR k = 0, kdm-1 DO sal(*, *, k, *) = sa(k)
+
+ ;; mask
+ IF (ind3d NE [-1]) THEN sal(ind3d) = vmiss
+
+ ;; write the field in relax file
+ write_relax_hycom, idm, jdm, kdm, io, file_sal_new, 'saln', d, sal
+ print, 'Salinity OK'
+
+
+
+ ;; Plot
+ IF (pl EQ 1) THEN BEGIN
+
+
+ device, decomposed = 0
+
+ ;; defined colors
+ levels = 15
+ Minss = 15. & Maxss = 18.
+ step = (Maxss - Minss) / levels
+ num_level = IndGen(levels) * step + Minss
+ loadct, 33, ncolors = levels
+
+ ;; let's make a plot
+ window, 1, xsize = 800, ysize = 800
+ contour, reform(tem(*, *, 1, 0)), xstyle = 1, ystyle = 1, levels = num_level, c_colors = indgen(levels), /fill, $
+ Color = !P.Background, Background = !P.color, /follow, position = [0.15, 0.15, 0.85, 0.85], title = 'Temperature 2st layer'
+ colorbar2, ncolors = levels, divisions = levels, color = 0, range = [Minss, Maxss], $
+ position = [0.17, 0.08, 0.83, 0.10], format = '(f7.1)'
+
+ device, decomposed = 1
+ ENDIF
+
+ stop
+
+END
diff --git a/IDL/write_windstress_bb86.pro b/IDL/write_windstress_bb86.pro
new file mode 100755
index 0000000..548f31f
--- /dev/null
+++ b/IDL/write_windstress_bb86.pro
@@ -0,0 +1,121 @@
+PRO write_windstress_bb86
+
+ ;; include the Utilities function
+ iodir = '/Net/yucatan/abozec/BB86_PACKAGE/IDL/' ;; where you are
+ !path=expand_path('+/'+iodir+'UTILITIES')+':'+expand_path('+'+!dir)
+
+ close, /all
+ ;; PATH
+ io = iodir+'/../force/'
+ file_grid = 'regional.grid.BB86.a'
+
+ ;; domain
+ idm = 101 & jdm = 101
+ tdm = 12 ;; monthly files
+
+ ;; name the new files
+ file_E = 'forcing.tauewd.BB86' ;; !! without .a or .b !!
+ file_N = 'forcing.taunwd.BB86'
+
+
+ ;; Read grid
+ read_grid_hycom, idm, jdm, io+'../topo/', file_grid, plon, plat
+
+ ;; Calculation of the analytical wind-stress (N/m2)
+ ustress = fltarr(jdm)
+ ustressb = fltarr(jdm)
+ stressa = -1.
+ sconv = 1.e-1 ;; scale factor form dyn/cm2 to N/m2
+
+ ;; BB86 formulation
+ FOR j = 0, jdm-1 DO ustress(j) = stressa*cos(float(j)/float(jdm-1)*6.28318530718)*sconv
+
+
+ ;; plot the stress
+ device, decomposed = 0
+ zeros = fltarr(jdm)
+ window, 1, xsize = 800, ysize = 800
+ plot, ustress, reform(plat(0, *)), xstyle = 1, ystyle = 1, ytitle = 'Latitude (N) ', xrange = [-0.2, 0.2], xtitle = 'Taux (N/m2)', $
+ Color = !P.Background, Background = !P.color
+ oplot, zeros, reform(plat(0, *)), linestyle = 1, color = 0
+
+
+ device, decomposed = 1
+
+
+ ;; Write the wind-stress files
+ tte = fltarr(idm, jdm, tdm)
+ ttn = fltarr(idm, jdm, tdm)
+
+ ijdm = float(idm)*jdm
+ idm1 = float(idm)
+ npad=4096. - ijdm MOD 4096
+ rr2 = fltarr(ijdm)
+ toto = fltarr(npad)
+
+ ;; we apply a taux , no tauy
+ FOR j = 0, jdm-1 DO tte(*, j, *) = ustress(j)
+
+ ;; Taux
+ openw, 1, io+file_E+'.a', /swap_endian
+
+ FOR ll = 0, tdm-1 DO BEGIN
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO rr2(j*idm1+i) = tte(i, j, ll)
+ ENDFOR
+ writeu, 1, rr2, toto
+ print, 'll= ', ll
+ ENDFOR
+ close, 1
+
+ ;; Tauy
+ openw, 1, io+file_N+'.a', /swap_endian
+ FOR ll = 0, tdm-1 DO BEGIN
+ FOR j = 0, jdm-1 DO BEGIN
+ FOR i = 0, idm-1 DO rr2(j*idm1+i) = ttn(i, j, ll)
+ ENDFOR
+ writeu, 1, rr2, toto
+ print, 'll= ', ll
+ ENDFOR
+ close, 1
+
+
+ ;; create .b file
+ mo = findgen(12)+1
+ months = string(mo, format ='(i2.2)')
+ time = findgen(12)+1
+ span = 0.250
+
+
+; openw,1,io+'tauewd_agul05_42S.b'
+ openw,1,io+file_E+'.b'
+ printf, 1, format = '(A22)', 'Analytical Wind-stress'
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A5,1x,i3,1x,i3)', 'i/jdm ', idm, jdm
+ FOR m = 0, tdm-1 DO BEGIN
+ printf,1,format = '(A23,1x,i2.2,1x,E14.7,2x,E14.7)',' tauewd: month,range =', time(m), min(tte(*, *, m)), max(tte(*, *, m))
+
+ ENDFOR
+;; tau_nwd: month,range = 01 -1.5917161E-01 1.5640029E-01
+
+ close,1
+
+ openw,1,io+file_N+'.b'
+ printf, 1, format = '(A22)', 'Analytical Wind-stress'
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A1)', ''
+ printf, 1, format = '(A5,1x,i3,1x,i3)', 'i/jdm ', idm, jdm
+ FOR m = 0, tdm-1 DO BEGIN
+ printf,1,format = '(A23,1x,i2.2,1x,E14.7,2x,E14.7)',' taunwd: month,range =', time(m), min(ttn(*, *, m)), max(ttn(*, *, m))
+
+ ENDFOR
+
+ close,1
+
+
+stop
+
+END
diff --git a/MATLAB/UTILITIES/draw_arrowF.m b/MATLAB/UTILITIES/draw_arrowF.m
new file mode 100755
index 0000000..2f76e9a
--- /dev/null
+++ b/MATLAB/UTILITIES/draw_arrowF.m
@@ -0,0 +1,47 @@
+ function draw_arrowF(x1,x2,y1,y2,cf,beta,v_col,lwd);
+% ----------------------------------
+% draw_arrowF(x1,x2,y1,y2,cf,beta,v_col,lwd);
+%
+% draws arrow with filled "head"
+% Note: first X-coordinates x1, x2, then Y-coordinates, Y1,y2, ...
+% Draws an arrow between pnt (x1,y1) and pnt (x2,y2)
+% cf - scaling coefficient of the arrowhead (0 to 1)
+% beta - angle between vector and arrow head beams (degrees)
+% v_col - color ([R G B]) % default color is black
+% lwd - line width, default = 1
+%
+ if (isempty(v_col)); v_col=[0,0,0]; end; % default color is black
+ if (isempty(lwd)); lwd=1.; end; % default line width
+
+ hold on
+ uu=x2-x1;
+ vv=y2-y1;
+ sp=sqrt(uu.*uu+vv.*vv);
+ alfa=atan2(uu,vv); % vector angle from Y
+ beta=beta*pi/180;
+ var=cf*sp; % scaling of the arrow head
+ dX2=var.*sin(alfa-beta); % arrow head coordinates
+ dX3=var.*sin(alfa+beta); %
+ dY2=var.*cos(alfa-beta);
+ dY3=var.*cos(alfa+beta);
+ ax2=x2-dX2;
+ ax3=x2-dX3;
+ ay2=y2-dY2;
+ ay3=y2-dY3;
+%keyboard
+ x2v=x1+(1-cf)*uu;
+ y2v=y1+(1-cf)*vv;
+ p1=plot([x1 x2v],[y1 y2v],'Color',v_col); %vector
+% p2=plot([x2 ax2],[y2 ay2],'Color',v_col); % arrow head
+% p3=plot([x2 ax3],[y2 ay3],'Color',v_col);
+
+ set(p1,'linewidth',lwd);
+% set([p2,p3],'linewidth',0.5);
+
+ X=[x2,ax2,ax3,x2];
+ Y=[y2,ay2,ay3,y2];
+ H=fill(X,Y,v_col);
+ set(H,'edgecolor',v_col);
+
+
+% hold off
diff --git a/MATLAB/UTILITIES/read_depth_hycom.m b/MATLAB/UTILITIES/read_depth_hycom.m
new file mode 100755
index 0000000..de30143
--- /dev/null
+++ b/MATLAB/UTILITIES/read_depth_hycom.m
@@ -0,0 +1,29 @@
+function bathy=read_depth_hycom(im,jm,file)
+
+ %% Script to read the HYCOM bathymetry file
+ %% A. Bozec & D. Dukhovskoy Aug, 2011
+
+ %% Get the id of the bathymetry file
+ depth_fid=fopen(file,'r');
+ IDM=im;
+ JDM=jm;
+ IJDM=IDM*JDM;
+ npad=4096-mod(IJDM,4096);
+
+ %% Read bathymetry
+ [bathy,count]=fread(depth_fid,IJDM,'float32','ieee-be');
+
+ %% Mask bathymetry
+ y=find(bathy>1e20);
+ bathy(y)=NaN;
+ bathy=reshape(bathy,IDM,JDM)';
+
+ fclose(depth_fid);
+
+
+
+
+
+
+
+
diff --git a/MATLAB/UTILITIES/read_grid_hycom.m b/MATLAB/UTILITIES/read_grid_hycom.m
new file mode 100755
index 0000000..3737a44
--- /dev/null
+++ b/MATLAB/UTILITIES/read_grid_hycom.m
@@ -0,0 +1,96 @@
+function [plon, plat, ulon, ulat, vlon, vlat, qlon, qlat, pang, ...
+ pscx, pscy, qscx, qscy, uscx, uscy, vscx, vscy, cori, pasp]=read_grid_hycom(im, jm, io, file)
+
+ %% Script to read the HYCOM grid file
+ %% A. Bozec & D. Dukhovskoy Aug, 2011
+
+ %% Get the id of the grid file
+ flgr=[io,file];
+ grid_fid=fopen(flgr,'r');
+ IDM=im;
+ JDM=jm;
+ IJDM=IDM*JDM;
+ npad=4096-mod(IJDM,4096);
+
+ %% Read the grid
+
+ [plon,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,4*(npad+IJDM),-1);
+ [plat,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,2*4*(npad+IJDM),-1);
+ [qlon,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,3*4*(npad+IJDM),-1);
+ [qlat,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,4*4*(npad+IJDM),-1);
+ [ulon,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,5*4*(npad+IJDM),-1);
+ [ulat,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,6*4*(npad+IJDM),-1);
+ [vlon,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,7*4*(npad+IJDM),-1);
+ [vlat,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,8*4*(npad+IJDM),-1);
+ [pang,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,9*4*(npad+IJDM),-1);
+ [pscx,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,10*4*(npad+IJDM),-1);
+ [pscy,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,11*4*(npad+IJDM),-1);
+ [qscx,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,12*4*(npad+IJDM),-1);
+ [qscy,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,13*4*(npad+IJDM),-1);
+ [uscx,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,14*4*(npad+IJDM),-1);
+ [uscy,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,15*4*(npad+IJDM),-1);
+ [vscx,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+ fseek(grid_fid,16*4*(npad+IJDM),-1);
+ [vscy,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,17*4*(npad+IJDM),-1);
+ [cori,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+ fseek(grid_fid,18*4*(npad+IJDM),-1);
+ [pasp,count]=fread(grid_fid,IJDM,'float32','ieee-be');
+
+
+ plon=reshape(plon,IDM,JDM)';
+ plat=reshape(plat,IDM,JDM)';
+
+ qlon=reshape(qlon,IDM,JDM)';
+ qlat=reshape(qlat,IDM,JDM)';
+
+ ulon=reshape(ulon,IDM,JDM)';
+ ulat=reshape(ulat,IDM,JDM)';
+
+ vlon=reshape(vlon,IDM,JDM)';
+ vlat=reshape(vlat,IDM,JDM)';
+
+ pang=reshape(pang,IDM,JDM)';
+
+ pscx=reshape(pscx,IDM,JDM)';
+ pscy=reshape(pscy,IDM,JDM)';
+ qscx=reshape(qscx,IDM,JDM)';
+ qscy=reshape(qscy,IDM,JDM)';
+
+ uscx=reshape(uscx,IDM,JDM)';
+ uscy=reshape(uscy,IDM,JDM)';
+ vscx=reshape(vscx,IDM,JDM)';
+ vscy=reshape(vscy,IDM,JDM)';
+
+ cori=reshape(cori,IDM,JDM)';
+
+ pasp=reshape(pasp,IDM,JDM)';
+
+ %% Close file
+ fclose(grid_fid);
+
diff --git a/MATLAB/UTILITIES/sigma0_hycom.m b/MATLAB/UTILITIES/sigma0_hycom.m
new file mode 100755
index 0000000..bf13f4f
--- /dev/null
+++ b/MATLAB/UTILITIES/sigma0_hycom.m
@@ -0,0 +1,14 @@
+function sig=sigma0_hycom(T,S)
+%%
+%% --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1= -1.36471E-01 ;
+ C2= 4.68181E-02 ;
+ C3= 8.07004E-01 ;
+ C4= -7.45353E-03 ;
+ C5= -2.94418E-03 ;
+ C6= 3.43570E-05 ;
+ C7= 3.48658E-05 ;
+
+%% --- sigma-theta as a function of temp (deg c) and salinity (mil)
+ sig=(C1+C3*S+T.*(C2+C5*S+T.*(C4+C7*S+C6*T)))
+
diff --git a/MATLAB/UTILITIES/sigma2_hycom.m b/MATLAB/UTILITIES/sigma2_hycom.m
new file mode 100755
index 0000000..0ad262a
--- /dev/null
+++ b/MATLAB/UTILITIES/sigma2_hycom.m
@@ -0,0 +1,13 @@
+function sig=sigma2_hycom(T,S)
+%%
+%% --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00 ;
+ C2=-2.26493E-02 ;
+ C3= 7.89879E-01 ;
+ C4=-6.43205E-03 ;
+ C5=-2.62983E-03 ;
+ C6= 2.75835E-05 ;
+ C7= 3.15235E-05 ;
+
+%% --- sigma-theta as a function of temp (deg c) and salinity (mil)
+ sig=(C1+C3*S+T.*(C2+C5*S+T.*(C4+C7*S+C6*T)))
diff --git a/MATLAB/UTILITIES/sofsig.m b/MATLAB/UTILITIES/sofsig.m
new file mode 100755
index 0000000..a3b2ab5
--- /dev/null
+++ b/MATLAB/UTILITIES/sofsig.m
@@ -0,0 +1,25 @@
+function sof=sofsig(T,R,sig)
+
+ if (sig == 2.)
+%% --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00;
+ C2=-2.26493E-02;
+ C3= 7.89879E-01;
+ C4=-6.43205E-03;
+ C5=-2.62983E-03;
+ C6= 2.75835E-05;
+ C7= 3.15235E-05;
+ end
+ if (sig == 0.)
+%% --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1=-1.36471E-01;
+ C2= 4.68181E-02;
+ C3= 8.07004E-01;
+ C4=-7.45353E-03;
+ C5=-2.94418E-03;
+ C6= 3.43570E-05;
+ C7= 3.48658E-05;
+ end
+
+%% --- salinity (mil) as a function of sigma and temperature (deg c)
+ sof=(R-C1-T*(C2+T*(C4+C6*T)))/(C3+T*(C5+C7*T))
diff --git a/MATLAB/UTILITIES/sub_var2.m b/MATLAB/UTILITIES/sub_var2.m
new file mode 100755
index 0000000..9605ed5
--- /dev/null
+++ b/MATLAB/UTILITIES/sub_var2.m
@@ -0,0 +1,64 @@
+%
+ function [aout]=sub_var2(fName,dims,num2,ivar,jj,ii)
+%
+% Read/extract a 2-D variable from hycom archive file
+%----------------------------------------------------------------------
+% Input:
+% fName = [file Name]
+% dims = dimensions jdm idm [kdm]
+% num2 = numer of 2d variable [check .b file]
+% ivar = index of var (2d)
+%
+% optional subset parameters
+% jj = j index
+% ii = i index
+%
+% Output:
+% aout
+%----------------------------------------------------------------------
+% Xiaobiao Xu, 2007
+%
+ aout = [];
+ if (nargin~=4 & nargin~=6)
+ display('W r o n g n a r g i n ');
+ elseif (ivar>num2 | ivar<1);
+ display('1 <= ivar <= num2 ');
+ else
+ fid = fopen(fName,'r','ieee-be');
+ if (fid<0); display(['error in opening ' fName]);
+ else
+
+ jdm = dims(1);
+ idm = dims(2);
+ nn = ceil(jdm*idm/4096)*4096;
+%============================================================
+ if nargin==6 % subregion
+%============================================================
+ nj = length(jj);
+ ni = length(ii);
+
+ offs= (ivar-1);
+ aout = nan*ones(nj,ni);
+ for j=1:nj
+ offset = (offs*nn + (jj(j)-1)*idm + ii(1)-1)*4;
+ status = fseek(fid,offset,'bof');
+ if status~=0; display('error in seek'); end
+ aout(j,:) = fread(fid,[1,ni],'real*4');
+ end
+%============================================================
+ else % whole domain
+%============================================================
+ offs = (ivar-1)*nn*4;
+ status = fseek(fid,offs,'bof');
+ if status~=0; display('error in seek'); end
+ aone = fread(fid,[1,jdm*idm],'real*4');
+ aout = reshape(aone,idm,jdm)';
+ clear status aone
+ end
+ aout(aout>=2^100)=nan;
+ fclose(fid);
+ end
+ clear fid
+
+ end
+%
diff --git a/MATLAB/UTILITIES/sub_var3.m b/MATLAB/UTILITIES/sub_var3.m
new file mode 100755
index 0000000..3716e69
--- /dev/null
+++ b/MATLAB/UTILITIES/sub_var3.m
@@ -0,0 +1,67 @@
+%
+ function [aout] = sub_var3(fName,dims,num2,num3,ivar,jj,ii,kk)
+%
+% read/extract a 3-D variable from hycom archive file
+%----------------------------------------------------------------------
+% Input:
+% fName : file name '.a'
+% dims : dimension for full domain [jdm idm kdm]
+% num2/3 : number of 2d/3d variables -- .b
+% ivar : index of the 3d variable (1-num3)
+% [jj ii kk]: dimension for sub domain [optional]
+%----------------------------------------------------------------------
+% Xiaobiao Xu, 2007
+%
+
+ aout = [];
+ if (nargin~=5 & nargin~=8)
+ display('W r o n g n a r g i n ');
+ elseif (ivar>num3 | ivar<1);
+ display('1 <= ivar <= num3 ');
+ else
+
+ fid = fopen(fName,'r','ieee-be');
+ if (fid<0); display(['error in opening ' fName]);
+ else
+ jdm = dims(1);
+ idm = dims(2);
+ kdm = dims(3);
+ nn = ceil(jdm*idm/4096)*4096;
+% ========================================================================
+ if nargin==8 % subset of the variable --
+% ========================================================================
+ nj = length(jj);
+ ni = length(ii);
+ nk = length(kk);
+
+ aout = nan(nj,ni,nk);
+ for k=1:nk
+ offs = num2+num3*(kk(k)-1)+ivar-1;
+ for j=1:nj
+ offset = (offs*nn + (jj(j)-1)*idm + ii(1)-1)*4;
+ status = fseek(fid,offset,'bof');
+ if status~=0; display('error in seek'); end
+ aout(j,:,k) = fread(fid,[1,ni],'real*4');
+ end
+ end
+ clear aone k offset status
+% ========================================================================
+ else %full domain
+% ========================================================================
+ aout = nan(jdm,idm,kdm);
+ for k=1:kdm
+ offset = (num2+num3*(k-1)+ivar-1)*nn*4;
+ status = fseek(fid,offset,'bof');
+ if status~=0; display('error in seek'); end
+ aone = fread(fid,[1,jdm*idm],'real*4');
+ aout(:,:,k) = reshape(aone,idm,jdm)';
+ end
+ clear aone k offset status
+ end
+ aout(aout>=2^100)=nan;
+ fclose(fid);
+ end
+ clear fid
+
+ end
+%
diff --git a/MATLAB/UTILITIES/tofsig.m b/MATLAB/UTILITIES/tofsig.m
new file mode 100755
index 0000000..d773d1b
--- /dev/null
+++ b/MATLAB/UTILITIES/tofsig.m
@@ -0,0 +1,45 @@
+function tof=tofsig(S,R,sig)
+ if (sig == 2.)
+%% --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ C1= 9.77093E+00;
+ C2=-2.26493E-02;
+ C3= 7.89879E-01;
+ C4=-6.43205E-03;
+ C5=-2.62983E-03;
+ C6= 2.75835E-05;
+ C7= 3.15235E-05;
+ end
+ if (sig == 0.)
+%% --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ C1=-1.36471E-01;
+ C2= 4.68181E-02;
+ C3= 8.07004E-01;
+ C4=-7.45353E-03;
+ C5=-2.94418E-03;
+ C6= 3.43570E-05;
+ C7= 3.48658E-05;
+ end
+
+
+ AZERO = 0.;
+ AHALF = 1/2.;
+ ATHIRD = 1/3.;
+ A1P5 = 3.0/2;
+%% --- auxiliary statements for finding root of 3rd degree polynomial
+ A0=(C1+C3.*S -R)/C6;
+ A1=(C2+C5.*S)/C6;
+ A2=(C4+C7.*S)/C6;
+ CUBQ=ATHIRD.*A1-(ATHIRD.*A2)^2;
+ CUBR=ATHIRD.*(AHALF.*A1.*A2-A1P5.*A0) -(ATHIRD.*A2)^3;
+%% --- if q**3+r**2>0, water is too dense to yield real root at given
+%% --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+%% --- lowering sigma until a double real root is obtained.
+ CUBAN=ATHIRD.*atan2(sqrt(max([AZERO,-(CUBQ.^3+CUBR.^2)])),CUBR);
+ CUBRL=sqrt(-CUBQ).*cos(CUBAN);
+ CUBIM=sqrt(-CUBQ).*sin(CUBAN);
+
+%% --- temp (deg c) as a function of sigma and salinity (mil)
+ tof=-CUBRL+sqrt(3.)*CUBIM-ATHIRD.*A2;
+
+
+
diff --git a/MATLAB/UTILITIES/write_depth_hycom.m b/MATLAB/UTILITIES/write_depth_hycom.m
new file mode 100755
index 0000000..91ff902
--- /dev/null
+++ b/MATLAB/UTILITIES/write_depth_hycom.m
@@ -0,0 +1,39 @@
+function write_depth_hycom(im, jm, file, bathy)
+
+ %% Script to write the bathymetry in the HYCOM format
+ %% file is the name of the file WITHOUT the extension .a or .b
+ %% A. Bozec & D. Dukhovskoy Aug, 2011
+
+ %% Get the id of the bathymetry file
+ flda=[file,'.a'];
+ depth_fid=fopen(flda,'w');
+ IDM=im;
+ JDM=jm;
+ IJDM=IDM*JDM;
+ npad=4096-mod(IJDM,4096);
+ toto=zeros(npad,1);
+
+ %% Writing .a file:
+ A=bathy';
+ A=reshape(A,IJDM,1);
+% Writing the bathy:
+ fwrite(depth_fid,A,'float32','ieee-be');
+% Writing the padding at the end of the record:
+ fwrite(depth_fid,toto,'float32','ieee-be');
+ fclose(depth_fid);
+
+ %%find mask value
+ ind=find(A > 1e10);
+ A(ind)=NaN;
+
+ %% Writing .b file;
+ fldb=[file,'.b'];
+ fid1=fopen(fldb,'wt');
+ fprintf(fid1,'Bathymetry\n');
+ fprintf(fid1,'i/jdm = %i %i \n',IDM,JDM);
+ fprintf(fid1,'\n');
+ fprintf(fid1,'\n');
+ fprintf(fid1,'\n');
+% fprintf(fid1,'min,max depth = %10.5f %10.5f \n',nanmin(nanmin(A)), nanmax(nanmax(A)) );
+ fprintf(fid1,'min,max depth = %10.5f %10.5f \n',min(A(find(~isnan(A)))), max(A(find(~isnan(A)))) );
+ fclose(fid1);
diff --git a/MATLAB/UTILITIES/write_depth_hycom.m~ b/MATLAB/UTILITIES/write_depth_hycom.m~
new file mode 100755
index 0000000..41c688d
--- /dev/null
+++ b/MATLAB/UTILITIES/write_depth_hycom.m~
@@ -0,0 +1,38 @@
+function write_depth_hycom(im, jm, file, bathy)
+
+ %% Script to write the bathymetry in the HYCOM format
+ %% file is the name of the file WITHOUT the extension .a or .b
+ %% A. Bozec & D. Dukhovskoy Aug, 2011
+
+ %% Get the id of the bathymetry file
+ flda=[file,'.a'];
+ depth_fid=fopen(flda,'w');
+ IDM=im;
+ JDM=jm;
+ IJDM=IDM*JDM;
+ npad=4096-mod(IJDM,4096);
+ toto=zeros(npad,1);
+
+ %% Writing .a file:
+ A=bathy';
+ A=reshape(A,IJDM,1);
+% Writing the bathy:
+ fwrite(depth_fid,A,'float32','ieee-be');
+% Writing the padding at the end of the record:
+ fwrite(depth_fid,toto,'float32','ieee-be');
+ fclose(depth_fid);
+
+ %%find mask value
+ ind=find(A > 1e10);
+ A(ind)=NaN;
+
+ %% Writing .b file;
+ fldb=[file,'.b'];
+ fid1=fopen(fldb,'wt');
+ fprintf(fid1,'Bathymetry\n');
+ fprintf(fid1,'i/jdm = %i %i \n',IDM,JDM);
+ fprintf(fid1,'\n');
+ fprintf(fid1,'\n');
+ fprintf(fid1,'\n');
+ fprintf(fid1,'min,max depth = %10.5f %10.5f \n',nanmin(nanmin(A)), nanmax(nanmax(A)) );
+ fclose(fid1);
diff --git a/MATLAB/UTILITIES/write_grid_hycom.m b/MATLAB/UTILITIES/write_grid_hycom.m
new file mode 100755
index 0000000..ae712c2
--- /dev/null
+++ b/MATLAB/UTILITIES/write_grid_hycom.m
@@ -0,0 +1,152 @@
+function write_grid_hycom(im, jm, io, file,plon, plat, ulon, ulat, vlon, vlat, qlon, qlat, pang, ...
+ pscx, pscy, qscx, qscy, uscx, uscy, vscx, vscy, cori, pasp, mapflg)
+
+ %% Script to write the grid in the HYCOM format
+ %% file is the name of the file WITHOUT the extension .a or .b
+ %% A. Bozec & D. Dukhovskoy Aug, 2011
+
+ %% Get the id of the .a grid file
+ flga=[io,file,'.a'];
+ grid_fid=fopen(flga,'w');
+ IDM=im;
+ JDM=jm;
+ IJDM=IDM*JDM;
+ npad=4096-mod(IJDM,4096);
+ toto=zeros(npad,1);
+
+ %% Writing .a file:
+ A=plon';
+ A=reshape(A,IJDM,1);
+% Writing the field
+ fwrite(grid_fid,A,'float32','ieee-be');
+% Writing the padding at the end of the record:
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=plat';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=qlon';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=qlat';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=ulon';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=ulat';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=vlon';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=vlat';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ A=pang';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ A=pscx';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=pscy';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=qscx';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=qscy';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ A=uscx';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=uscy';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=vscx';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+ A=vscy';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ A=cori';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ A=pasp';
+ A=reshape(A,IJDM,1);
+ fwrite(grid_fid,A,'float32','ieee-be');
+ fwrite(grid_fid,toto,'float32','ieee-be');
+
+
+ fclose(grid_fid);
+
+
+
+ %% Writing .b file;
+ fldb=[io,file,'.b'];
+ fid1=fopen(fldb,'wt');
+ fprintf(fid1,' %i ''idm '' = longitudinal array size\n',IDM);
+ fprintf(fid1,' %i ''jdm '' = latitudinal array size\n', JDM);
+ fprintf(fid1,' %i ''mapflg'' = map flag (0=mercator,10=panam,12=ulon-panam)\n',mapflg);
+ fprintf(fid1,'plon: min,max = %12.5f %12.5f\n', min(min(plon')), max(max(plon')) );
+ fprintf(fid1,'plat: min,max = %12.5f %12.5f\n', min(min(plat')), max(max(plat')) );
+ fprintf(fid1,'qlon: min,max = %12.5f %12.5f\n', min(min(qlon')), max(max(qlon')) );
+ fprintf(fid1,'qlat: min,max = %12.5f %12.5f\n', min(min(qlat')), max(max(qlat')) );
+ fprintf(fid1,'ulon: min,max = %12.5f %12.5f\n', min(min(ulon')), max(max(ulon')) );
+ fprintf(fid1,'ulat: min,max = %12.5f %12.5f\n', min(min(ulat')), max(max(ulat')) );
+ fprintf(fid1,'vlon: min,max = %12.5f %12.5f\n', min(min(vlon')), max(max(vlon')) );
+ fprintf(fid1,'vlat: min,max = %12.5f %12.5f\n', min(min(vlat')), max(max(vlat')) );
+ fprintf(fid1,'pang: min,max = %12.5f %12.5f\n', min(min(pang')), max(max(pang')) );
+ fprintf(fid1,'pscx: min,max = %12.5f %12.5f\n', min(min(pscx')), max(max(pscx')) );
+ fprintf(fid1,'pscy: min,max = %12.5f %12.5f\n', min(min(pscy')), max(max(pscy')) );
+ fprintf(fid1,'qscx: min,max = %12.5f %12.5f\n', min(min(qscx')), max(max(qscx')) );
+ fprintf(fid1,'qscy: min,max = %12.5f %12.5f\n', min(min(qscy')), max(max(qscy')) );
+ fprintf(fid1,'uscx: min,max = %12.5f %12.5f\n', min(min(uscx')), max(max(uscx')) );
+ fprintf(fid1,'uscy: min,max = %12.5f %12.5f\n', min(min(uscy')), max(max(uscy')) );
+ fprintf(fid1,'vscx: min,max = %12.5f %12.5f\n', min(min(vscx')), max(max(vscx')) );
+ fprintf(fid1,'vscy: min,max = %12.5f %12.5f\n', min(min(vscy')), max(max(vscy')) );
+ fprintf(fid1,'cori: min,max = %10.5E %10.5E\n', min(min(cori')), max(max(cori')) );
+ fprintf(fid1,'pasp: min,max = %12.5f %12.5f\n', min(min(pasp')), max(max(pasp')) );
+
+ fclose(fid1);
+
diff --git a/MATLAB/UTILITIES/write_relax_hycom.m b/MATLAB/UTILITIES/write_relax_hycom.m
new file mode 100755
index 0000000..1fe72d7
--- /dev/null
+++ b/MATLAB/UTILITIES/write_relax_hycom.m
@@ -0,0 +1,78 @@
+function write_relax_hycom(im, jm, km, io, file, field, d, res)
+
+ %% Script to write relax files in the HYCOM format (initial conditions)
+ %% file is the name of the file WITHOUT the extension .a or .b
+ %% field='intf'
+ %% field='temp'
+ %% field='saln'
+ %% d(kdm); target density
+
+ switch field
+ case 'intf'
+ long_name = 'Interface Depths' ;
+ short_name = 'int' ;
+
+ case 'temp'
+ long_name = 'Potential Temperature' ;
+ short_name = 'tem' ;
+
+ case 'saln'
+ long_name = 'Salinity' ;
+ short_name = 'sal' ;
+ otherwise
+ disp('Should be intf, temp or saln');
+ end
+
+ %% Dimensions of the domain
+ kdm = km ;
+ idm = im ;
+ jdm = jm ;
+ tdm = 12 ;
+ ijdm = idm*jdm ;
+
+ %% NPAD size
+ npad=4096-mod(ijdm,4096);
+ toto=zeros(npad,1);
+
+ %% Grid Directory and file
+ file1 = [io,file];
+
+ %% WRITING .a binary file
+ flga=[file1,'.a'];
+ relax_fid=fopen(flga,'w');
+
+ for t=1:tdm
+ for k = 1:kdm
+ A=res(:,:,k,t)';
+ A=reshape(A,ijdm,1);
+ %% Writing the field
+ fwrite(relax_fid,A,'float32','ieee-be');
+ %% Writing the padding at the end of the record:
+ fwrite(relax_fid,toto,'float32','ieee-be');
+ end
+ end
+ fclose(relax_fid);
+
+ %% mask the field by nan
+ index = find(res > 1e10) ;
+ res(index) = NaN ;
+
+
+ %% WRITING .b text file
+ density = d ;
+
+ fldb=[file1,'.b'];
+ fid1=fopen(fldb,'wt');
+ fprintf( fid1, ' %s \n',long_name );
+ fprintf( fid1, '\n');
+ fprintf( fid1, '\n');
+ fprintf( fid1, '\n');
+ fprintf( fid1, 'i/jdm = %i %i \n', idm, jdm);
+ for m = 1:tdm
+ for k = 1:kdm
+ fprintf( fid1, ' %s : month,layer,dens,range = %2.2i %2.2i %7.3f %10.5E %10.5E\n', short_name, m, k, density(k), nanmin(nanmin(res(:, :, k,m)')), nanmax(nanmax(res(:,:, k,m)')));
+
+ end
+ end
+
+ fclose(fid1);
diff --git a/MATLAB/plot_res_bb86.m b/MATLAB/plot_res_bb86.m
new file mode 100755
index 0000000..0b9ce2b
--- /dev/null
+++ b/MATLAB/plot_res_bb86.m
@@ -0,0 +1,217 @@
+%% plot results from bb86 and HYCOM-bb86
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath(['',iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'../'];
+
+ %% size of the domain
+ idm = 101 ; %% size of the domain
+ jdm = 101 ; %% size of the domain
+ kdm = 2 ; %% number of layer in bb86
+ dp0 = 500.; %% thickness of the first layer (m)
+ tdm = 1800 ; %% 12 month climatology
+ tplot1 = 5 ; tplot2 = 5 ; %% time-stamp to plot (starts from 1)
+
+ %% Postscript
+ PS=0;
+ file_ps='../PS/test.eps'
+
+ %% constants
+ rho = 1000.; %% reference density
+ g = 9.806 ; %% gravity
+
+
+ %% Read grid
+ file_grid = 'regional.grid.BB86.a'
+ [plon,plat]=read_grid_hycom(idm, jdm, ([io,'topo/']), file_grid);
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ %% READ the HYCOM files
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ io_hycom = [io,'expt_01.0/data/output/'];
+
+ for t = tplot1:tplot2
+ if (t <= 344)
+ year = '0001' ;
+ day = sprintf('%3.3d',t+16) ; %% 16 u and v == 0. so we start at day 17.
+ elseif (t > 344) && (t <= 704)
+ year = '0002' ;
+ day = sprintf('%3.3d',t-344) ;
+ elseif (t > 704) && (t <= 1064)
+ year = '0003' ;
+ day = sprintf('%3.3d',t-704) ;
+ elseif (t > 1064) && (t <= 1424)
+ year = '0004' ;
+ day = sprintf('%3.3d',t-1064) ;
+ elseif (t > 1424) && (t <= 1784)
+ year = '0005' ;
+ day = sprintf('%3.3d',t-1424) ;
+ elseif (t > 1784) && (t <= 2144)
+ year = '0006' ;
+ day = sprintf('%3.3d',t-1784) ;
+ end
+ file = ['archv.',year,'_',day,'_00.a']
+
+
+ %% archive files 2D variable units (see archv.*.b for the list of available var.)
+ %% montg1 : *1./g to get in m
+ %% srfhgt : *1./g to get in m
+ %% surflx : W/m2
+ %% salflx : kg/m2/s
+ %% bl_dpth : *1./(rho*g) to get in m
+ %% mix_dpth: *1./(rho*g) to get in m
+ %% u_btrop : m/s
+ %% v_btrop : m/s
+
+ %% extract barotropic velocities (ubarot)
+ num2 = 8 ; %% number of 2D variables in the archive file
+ ivar_ub = 7; %% index of ubaro (7th 2D variable)
+ ivar_vb = 8; %% index of vbaro (8th 2D variable)
+ ubaro=sub_var2([io_hycom,file],[jdm, idm], num2, ivar_ub) ;
+ vbaro=sub_var2([io_hycom,file],[jdm, idm], num2, ivar_vb) ;
+
+
+
+ %% archive files 3D variable units (see archv.*.b for the list of available var.)
+ %% u-vel. : m/s
+ %% v-vel. : m/s
+ %% thknss : *1./(rho*g) to get in m
+ %% temp : C
+ %% salin : psu
+
+ %% extract velocities (ubaroc)
+ num3 = 5 ; %% number of 3D variables in the archive file
+ ivar_u = 1; %% index of u baroclinic
+ ivar_v = 2; %% index of v baroclinic
+ ubac=sub_var3([io_hycom,file],[jdm, idm, kdm+1], num2, num3, ivar_u) ;
+ vbac=sub_var3([io_hycom,file],[jdm, idm, kdm+1], num2, num3, ivar_v) ;
+
+ %% Get utot & vtot
+ uhyc=zeros(jdm,idm,kdm+1,tdm) ;
+ for k = 1:kdm+1
+ uhyc(:, :, k, t) = ubaro(:, :)+ubac(:, :,k) ;
+ end
+ vhyc=zeros(jdm,idm,kdm+1,tdm) ;
+ for k = 1:kdm+1
+ vhyc(:, :, k, t) = vbaro(:, :)+vbac(:, :, k) ;
+ end
+
+
+ %% extract the layer thickness
+ ivar_dp = 3 ;
+ dp=sub_var3([io_hycom,file],[jdm, idm, kdm+1], num2, num3, ivar_dp) ;
+ dphyc=zeros(jdm,idm,kdm+1,tdm) ;
+ dphyc(:, :, :, t) = dp/(rho*g) ;
+
+ %% put the u vel on the p-grid
+ %%get the umask
+ maskt = ones(jdm, idm, kdm+1, tdm) ;
+ maskt(find(uhyc == 0.)) = 0. ;
+ maxval = maskt+circshift(maskt, [0, -1, 0, 0]) ;
+ maxval(find(maxval == 0.)) = NaN ;
+
+ %% get the average value of u at the p-point
+ uthyc = (uhyc+circshift(uhyc, [0, -1, 0, 0]))./maxval ;
+ uthyc(:,idm, :, :) = uthyc(:,idm-1, :, :) ;
+
+ %% put the v vel on the p-grid
+ %%get the vmask
+ maskt = ones(jdm, idm, kdm+1, tdm) ;
+ maskt(find(vhyc == 0.)) = 0. ;
+ maxval = maskt+circshift(maskt, [-1, 0, 0, 0]) ;
+ maxval(find(maxval == 0.)) = NaN ;
+
+ %% get the average value of v at the p-point
+ vthyc = (vhyc+circshift(vhyc, [-1, 0, 0, 0]))./maxval ;
+ vthyc(jdm, :, :, :) = vthyc(jdm-1,:, :, :) ;
+
+ end
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ %% plot
+ for t = tplot1:tplot2
+
+ %% norme, min and max of the plots
+ normeref_hyc = 0.02 ; %% vector norm of HYCOM-BB86 (in m)
+ onevectout = 2 ; %% plot one vector out of 'onevectorout'
+ min_dp = -5. ;
+ max_dp = 5. ; %% layer thickness anomaly in m (min and max)
+
+ %% Define the figure dimensions
+ set(gcf,'Units','normalized');
+ set(gcf,'position',[0.1 0.08,0.5,0.7])
+ set(gcf,'PaperType', 'usletter');
+ set(gcf,'PaperUnits','normalized');
+ set(gcf,'PaperPosition',[0,0,1,1]);
+ set(gcf,'PaperOrientation', 'landscape');
+
+
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ %% HYCOM-BB86
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+ subplot(2,2,1)
+ uu = uthyc(1:onevectout:jdm, 1:onevectout:idm, 2, t);
+ vv = vthyc(1:onevectout:jdm, 1:onevectout:idm, 2, t);
+ lon = plon(1:onevectout:jdm, 1:onevectout:idm);
+ lat = plat(1:onevectout:jdm, 1:onevectout:idm);
+ [m,n] = size(uu);
+
+ %% we normalize the vectors
+ normeref = normeref_hyc ; %% in m
+ norme =sqrt(uu.^2+vv.^2) ;
+ normemax = nanmax(nanmax(norme))/normeref ;
+
+ quiver(lon, lat, uu,vv,3*normemax,'k') %% ref vector over 3*dx
+ axis;
+ set(gca,'xlim',[0, 20],'ylim',[0,20]);
+ title(['HYCOM-BB86 Velocity field t = ',sprintf('%4.4d',t)]);
+ xlabel('Longitude (E)')
+ ylabel('Latitude (N)')
+
+ %% draw a reference vector
+ framelim = get(gca,'Position');
+ x=framelim(1) ; y=framelim(2) ; %% (x,y) position of the arrow in the figure(normalized) units
+ xpl=1.2 ; ypl=-1.8 ; %% (x,y) position of the arrow in the plot units
+
+ x1=x+xpl*framelim(3)/(lon(1,n)-lon(1,1));
+ y1=y+ypl*framelim(4)/(lat(m,1)-lat(1,1));
+ dx=3*(lon(1,2)-lon(1,1))*framelim(3)/(lon(1,n)-lon(1,1));
+ dy=0.;
+ annotation(figure(1),'arrow','Position',[x1,y1,dx,dy],'headstyle','vback3','headwidth',5,'headlength',5)
+ text(xpl,ypl-1.,[sprintf('%3.2f',normeref),'m'])
+
+
+
+ subplot(2,2,2)
+
+ levels = 40 ;
+ Minss = min_dp ;
+ Maxss = max_dp ;
+ step = (Maxss - Minss) / levels ;
+ toto = 1:levels;
+ num_level = toto * step + Minss ;
+
+ caxis([min_dp max_dp]);hold on;
+ diff_dp = dphyc(:, :, 2, t) - (dp0+1.) ;
+ contourf(plon,plat,diff_dp,num_level);hold on;
+ colorbar;
+ axis;
+ title(['HYCOM-BB86 thickness ano. t = ',sprintf('%4.4d',t)]);
+ xlabel('Longitude (E)')
+ ylabel('Latitude (N)')
+
+ end
+ if (PS == 1)
+ print('-depsc2',file_ps);
+ end
+ % end
+
+
+
diff --git a/MATLAB/write_depth_bb86.m b/MATLAB/write_depth_bb86.m
new file mode 100755
index 0000000..939589a
--- /dev/null
+++ b/MATLAB/write_depth_bb86.m
@@ -0,0 +1,70 @@
+%% write bathy double gyre
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath([iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'/../topo/'];
+ file_bat_new = 'depth_BB86_01' ; %% !! without .a or .b !!
+ pl = 0; %% 1 or 0 for plot or not
+
+ %% size of the domain
+ idm = 101 ;
+ jdm = 101 ;
+
+ %% definition of the bathymetry
+ depth = 5000. ;%% constant bathy everywhere
+
+ %% closed boundary (latbdy=0) or open boundaries (latbdy=1) or cyclic (latbdy =2)
+ latbdy = 0;
+
+ %%%%%%; END of the USER inputs %%%%%%%%%%%%%%;
+
+ idm_hd = idm;
+ jdm_hd = jdm;
+ vmiss = 2.^100; %% HYCOM missing values
+
+ %% get the Depth
+ bathy_hd = zeros(jdm_hd, idm_hd);
+ bathy_hd(:, :) = depth;
+% bathy_hd(:,1)=0.;
+% for i=2:50
+% bathy_hd(:,i)=bathy_hd(:,i-1) + 10.;
+% end
+ disp('Depth Ok')
+
+ %% Plot
+ if (pl == 1)
+ figure(1)
+ pcolor(bathy_hd(:,:));colormap(jet(length(1:32)));
+ colorbar;shading flat
+ end
+
+ %% Mask by missing values if any
+ ind = find(bathy_hd == 0.);
+ bathy_hd (ind) = vmiss;
+
+
+ %% Get the edge of the domain right
+ switch latbdy
+ case 0
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd(:, idm_hd) = vmiss ;
+ bathy_hd(1, :) = vmiss ;
+ bathy_hd(:, 1) = vmiss ;
+
+ case 1
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd(:, idm_hd) = vmiss ;
+
+ case 2
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd( 1, :) = vmiss ;
+ end
+
+
+ %% write the file
+ write_depth_hycom(idm_hd, jdm_hd, [io,file_bat_new], bathy_hd)
+ disp('Writing depth file done ')
+
diff --git a/MATLAB/write_depth_bb86.m~ b/MATLAB/write_depth_bb86.m~
new file mode 100755
index 0000000..cf7eb4a
--- /dev/null
+++ b/MATLAB/write_depth_bb86.m~
@@ -0,0 +1,70 @@
+%% write bathy double gyre
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath([iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'/../topo/'];
+ file_bat_new = 'depth_BB86_03' ; %% !! without .a or .b !!
+ pl = 0; %% 1 or 0 for plot or not
+
+ %% size of the domain
+ idm = 101 ;
+ jdm = 101 ;
+
+ %% definition of the bathymetry
+ depth = 3000. ;%% constant bathy everywhere
+
+ %% closed boundary (latbdy=0) or open boundaries (latbdy=1) or cyclic (latbdy =2)
+ latbdy = 0;
+
+ %%%%%%; END of the USER inputs %%%%%%%%%%%%%%;
+
+ idm_hd = idm;
+ jdm_hd = jdm;
+ vmiss = 2.^100; %% HYCOM missing values
+
+ %% get the Depth
+ bathy_hd = zeros(jdm_hd, idm_hd);
+ bathy_hd(:, :) = depth;
+% bathy_hd(:,1)=0.;
+% for i=2:50
+% bathy_hd(:,i)=bathy_hd(:,i-1) + 10.;
+% end
+ disp('Depth Ok')
+
+ %% Plot
+ if (pl == 1)
+ figure(1)
+ pcolor(bathy_hd(:,:));colormap(jet(length(1:32)));
+ colorbar;shading flat
+ end
+
+ %% Mask by missing values if any
+ ind = find(bathy_hd == 0.);
+ bathy_hd (ind) = vmiss;
+
+
+ %% Get the edge of the domain right
+ switch latbdy
+ case 0
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd(:, idm_hd) = vmiss ;
+ bathy_hd(1, :) = vmiss ;
+ bathy_hd(:, 1) = vmiss ;
+
+ case 1
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd(:, idm_hd) = vmiss ;
+
+ case 2
+ bathy_hd(jdm_hd, :) = vmiss ;
+ bathy_hd( 1, :) = vmiss ;
+ end
+
+
+ %% write the file
+ write_depth_hycom(idm_hd, jdm_hd, [io,file_bat_new], bathy_hd)
+ disp('Writing depth file done ')
+
diff --git a/MATLAB/write_grid_bb86.m b/MATLAB/write_grid_bb86.m
new file mode 100755
index 0000000..58810c8
--- /dev/null
+++ b/MATLAB/write_grid_bb86.m
@@ -0,0 +1,142 @@
+%% write grid double gyre
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath(['',iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'/../topo/'];
+ file_grid_new = 'regional.grid.BB86'; %% !! without .a or .b !!
+
+ %% size of the domain
+ idm = 101 ;
+ jdm = 101 ;
+
+ %% longitude/latitude starting point + resolution (in degrees) (NB: those
+ %% variables are not used in HYCOM)
+ ini_lon = 0. ;
+ ini_lat = 0. ;
+ res = 0.20 ;
+
+ %% scale dx and dy (in m) (used in HYCOM)
+ dx = 20e3 ;
+ dy = dx ;
+
+ %% grid type
+ mapflg=0 ; %% uniform or mercator
+
+
+ %%%%%%; END of the USER inputs %%%%%%%%%%%%%%;
+
+ %% missing value in HYCOM
+ vmiss = 2.^100 ;
+
+ %% Get the p-point the grid
+ plon = zeros(jdm, idm) ;
+ plat = zeros(jdm, idm) ;
+
+ %% Longitude
+ plon(:, 1) = ini_lon ;
+ for i = 2:idm
+ plon(:, i) = plon(:, i-1) + res;
+ end
+ %% Latitude
+ plat(1, :) = ini_lat ;
+ for j = 2:jdm
+ plat(j, :) = plat(j-1, :) + res;
+ end
+
+ disp('p-points grid OK')
+
+
+ %% Declaration of the grid tabs
+ idm_hd = idm ;
+ jdm_hd = jdm ;
+
+ plon_hd = plon ;
+ plat_hd = plat ;
+
+ qlon_hd = zeros(jdm_hd, idm_hd) ;
+ qlat_hd = zeros(jdm_hd, idm_hd) ;
+ ulon_hd = zeros(jdm_hd, idm_hd) ;
+ ulat_hd = zeros(jdm_hd, idm_hd) ;
+ vlon_hd = zeros(jdm_hd, idm_hd) ;
+ vlat_hd = zeros(jdm_hd, idm_hd) ;
+
+ pang_hd = zeros(jdm_hd, idm_hd) ;
+
+ pscx_hd = zeros(jdm_hd, idm_hd) ;
+ pscy_hd = zeros(jdm_hd, idm_hd) ;
+
+ qscx_hd = zeros(jdm_hd, idm_hd) ;
+ qscy_hd = zeros(jdm_hd, idm_hd) ;
+
+ uscx_hd = zeros(jdm_hd, idm_hd) ;
+ uscy_hd = zeros(jdm_hd, idm_hd) ;
+
+ vscx_hd = zeros(jdm_hd, idm_hd) ;
+ vscy_hd = zeros(jdm_hd, idm_hd) ;
+
+ cori_hd = zeros(jdm_hd, idm_hd) ;
+ pasp_hd = zeros(jdm_hd, idm_hd) ;
+
+
+ %% Longitude/Latitude for each point (Q-points stay at the same location)
+ %% longitude
+ vlon_hd = plon_hd ;
+ for i = 2:idm
+ qlon_hd(:, i) = 0.5*(plon_hd(:, i)+plon_hd(:, i-1));
+ end
+ diff = plon_hd(1, 3)-plon_hd(1, 2) ;
+ qlon_hd(:, 1) = plon_hd(:, 1)-0.5*diff ;
+ ulon_hd = qlon_hd ;
+
+ %% latitude
+ ulat_hd = plat_hd ;
+ for j = 2:jdm
+ qlat_hd(j, :) = 0.5*(plat_hd(j, :)+plat_hd(j-1, :));
+ end
+ diff = plat_hd(3, 1)-plat_hd(2, 1) ;
+ qlat_hd(1, :) = plat_hd(1, :)-0.5*diff ;
+ vlat_hd = qlat_hd ;
+
+ %% simplified grid with prescribed dx and dy
+ pscx_hd(:, :) = dx;
+ pscy_hd(:, :) = dy;
+ uscx_hd(:, :) = dx;
+ uscy_hd(:, :) = dy;
+ vscx_hd(:, :) = dx;
+ vscy_hd(:, :) = dy;
+ qscx_hd(:, :) = dx;
+ qscy_hd(:, :) = dy;
+
+ %% Coriolis
+ beta = 2.e-11 ;
+ for j= 1:jdm_hd
+ for i= 1:idm_hd
+ cori_hd(j, i)=.93e-4+double(j-(jdm_hd-1)/2)*dx*beta ;
+ end
+ end
+
+ %% pang ( p-angle for rotated grid)
+ %% here uniform or mercator so pang = 0.
+
+
+ %% pasp= paspect: pscx/pscy
+
+ for j= 1:jdm_hd
+ for i= 1:idm_hd
+ pasp_hd(j,i) = pscx_hd(j,i)/pscy_hd(j,i) ;
+ end
+ end
+
+
+ %% Writing new grid file
+ write_grid_hycom(idm_hd, jdm_hd, io, file_grid_new, plon_hd, plat_hd, ulon_hd, ulat_hd, vlon_hd, vlat_hd, ...
+ qlon_hd, qlat_hd, pang_hd,pscx_hd, pscy_hd, qscx_hd, qscy_hd, uscx_hd, uscy_hd, vscx_hd, vscy_hd, cori_hd, pasp_hd,mapflg)
+
+ disp('Writing grid file done ')
+
+
+
+
diff --git a/MATLAB/write_relax_bb86.m b/MATLAB/write_relax_bb86.m
new file mode 100755
index 0000000..9dd769b
--- /dev/null
+++ b/MATLAB/write_relax_bb86.m
@@ -0,0 +1,128 @@
+%% write relax files (initial condition of T, S and interface
+%depth)
+
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath(['',iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'../relax/010/'];
+ file_topo = 'depth_BB86_01.a';
+ file_int_new = 'relax_int_BB86' ; %% !! without .a or .b !!
+ file_tem_new = 'relax_tem_BB86' ;
+ file_sal_new = 'relax_sal_BB86' ;
+ pl = 0; %% 1 or 0 for plot or not
+
+ %% size of the domain
+ idm = 101 ;
+ jdm = 101 ;
+ kdm = 3 ; %% number of layers (first layer very thin)
+ tdm = 12 ; %% 12 month climatology
+
+ %% interface depth (!!!first interface depth always 0. !!!)
+ id = zeros(kdm) ;
+ id = [0., 1., 500.] ;
+
+
+ %% target density
+ %% from bb86: rho=27.01037, rho=27.22136
+ d = zeros(kdm) ;
+ d = [27.0100, 27.01037,27.22136] ;
+
+ %% salinity profile
+ sa = zeros(kdm) ;
+ sa = [37., 37., 37.] ;
+
+ %%%%%%; END of the USER inputs %%%%%%%%%%%%%%;
+
+ %% constants
+ rho = 1000.;
+ g = 9.806;
+ vmiss = 2.^100;
+
+ %% temperature profile for sigma0
+ sigma = 0 ;
+ te = 1:kdm ;
+ for k = 1:kdm
+ te(k) = tofsig(sa(k), d(k), sigma) ;
+ end
+ disp(te)
+
+
+ %% read bathy for mask
+ bathy=read_depth_hycom(idm, jdm, [io,'../../topo/',file_topo]);
+ ind = isnan(bathy) ;
+ bathy(ind) = 0. ;
+ %% create mask
+ mask2d = ones(jdm, idm) ;
+ mask2d(ind) = 0. ;
+ mask = zeros(jdm, idm, kdm, tdm) ;
+ for t = 1:tdm
+ for k = 1:kdm
+ mask(:, :, k, t) = mask2d ;
+ end
+ end
+
+ %% interface depth files (first layer always the surface i.e. 0.)
+ int = zeros(jdm, idm, kdm, tdm) ;
+ for k= 2:kdm
+ int(:, :, k,:) = rho*g * id(k) ; %% 1st layer tiny to fake a two layer config
+ end
+
+ %% make sure that the interface depths are not lower than the bathy
+ for t = 1:tdm
+ for k = 1:kdm
+ for i = 1:idm
+ for j = 1:jdm
+ if (int(j, i, k)/9806. > bathy(j, i))
+ int(j, i, k) = bathy(j,i)*9806. ;
+ end
+ end
+ end
+ end
+ end
+
+ %% mask
+ ind3d = find(mask == 0.) ;
+ int(ind3d) = vmiss ;
+
+
+ %% write the field in relax file
+ write_relax_hycom(idm, jdm, kdm, io, file_int_new, 'intf', d, int) ;
+ disp('Interface depth OK')
+
+ %% Temperature
+ tem = zeros(jdm, idm, kdm, tdm) ;
+ for k = 1:kdm
+ tem(:, :, k,:) = te(k) ;
+ end
+
+ %% mask
+ tem(ind3d) = vmiss;
+
+ %% write the field in relax file
+ write_relax_hycom(idm, jdm, kdm, io, file_tem_new, 'temp', d, tem) ;
+ disp('Temperature OK')
+
+ %% Salinity
+ sal = zeros(jdm, idm, kdm, tdm) ;
+ for k = 1:kdm
+ sal(:,:, k,:) = sa(k) ;
+ end
+
+ %% mask
+ sal(ind3d) = vmiss ;
+
+ %% write the field in relax file
+ write_relax_hycom(idm, jdm, kdm, io, file_sal_new, 'saln', d, sal);
+ disp('Salinity OK')
+
+
+
+ %% Plot
+ if (pl == 1)
+ figure(1)
+ pcolor(tem(:,:,1));colormap(jet(length(1:32)));
+ colorbar;shading flat
+ end
diff --git a/MATLAB/write_windstress_bb86.m b/MATLAB/write_windstress_bb86.m
new file mode 100755
index 0000000..6f588ef
--- /dev/null
+++ b/MATLAB/write_windstress_bb86.m
@@ -0,0 +1,118 @@
+%% write windstress double gyre
+
+ clear all,clf, close all
+ iodir='/Net/yucatan/abozec/BB86_PACKAGE/MATLAB/';
+ addpath(genpath(['',iodir,'/UTILITIES/']));
+
+ %% PATH
+ io = [iodir,'/../topo/'];
+ file_grid = 'regional.grid.BB86.a'
+
+ %% domain
+ idm = 101 ;
+ jdm = 101 ;
+ tdm = 12 ;%% monthly files
+
+ %% name the new files
+ file_E = 'forcing.tauewd.BB86'; %% without .a or .b %%
+ file_N = 'forcing.taunwd.BB86';
+
+
+ %% Read grid
+ [plon,plat]=read_grid_hycom(idm, jdm, ([io,'../topo/']), file_grid);
+
+ %% Calculation of the analytical wind-stress (N/m2)
+ ustress = zeros(jdm);
+ stressa = -1.;
+ sconv = 1.e-1; %% scale factor form dyn/cm2 to N/m2
+
+ %% BB86 formulation
+ for j = 1:jdm
+ ustress(j) = stressa*cos(double(j-1)/double(jdm-1)*6.28318530718)*sconv;
+ end
+
+ %% plot the stress
+ figure(1)
+ plot(ustress,plat);
+ ylim([0 20]);
+ xlim([-0.2 0.2]);
+ grid on;
+
+
+ %% Write the wind-stress files
+ tte = zeros(jdm, idm, tdm);
+ ttn = zeros(jdm, idm, tdm);
+
+ IJDM=idm*jdm;
+ npad=4096-mod(IJDM,4096);
+ toto=zeros(npad,1);
+
+
+ %% we apply a taux , no tauy
+ for j = 1:jdm
+ tte(j, :, :) = ustress(j);
+ end
+
+ %% Taux
+ taux_fid=fopen([io,'../force/',file_E,'.a'],'w');
+
+ for ll = 1:tdm
+ A=tte(:,:,ll)';
+ A=reshape(A,IJDM,1);
+ %% Writing the field
+ fwrite(taux_fid,A,'float32','ieee-be');
+ %% Writing the padding at the end of the record:
+ fwrite(taux_fid,toto,'float32','ieee-be');
+ end
+ fclose(taux_fid);
+
+ %% Tauy
+ tauy_fid=fopen([io,'../force/',file_N,'.a'],'w');
+
+ for ll = 1:tdm
+ A=ttn(:,:,ll)';
+ A=reshape(A,IJDM,1);
+ %% Writing the field
+ fwrite(tauy_fid,A,'float32','ieee-be');
+ %% Writing the padding at the end of the record:
+ fwrite(tauy_fid,toto,'float32','ieee-be');
+ end
+ fclose(tauy_fid);
+
+
+ %% create .b file
+ time = 1:12;
+
+ %% Write Eastward Wind stress file
+ fldb=[io,'../force/',file_E,'.b'];
+ fid1=fopen(fldb,'wt');
+
+ fprintf(fid1, 'Analytical Eastward Wind-stress\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, 'i/jdm = %i %i \n',idm,jdm);
+ for m = 1:tdm
+ fprintf(fid1,' tauewd: month,range = %2.2i %10.5E %10.5E\n', ...
+ time(m), min(min(tte(:, :, m)')), max(max(tte(:, :, m)')));
+ end
+
+ fclose(fid1);
+
+ %% Write Northward Wind stress file
+ fldb=[io,'../force/',file_N,'.b'];
+ fid1=fopen(fldb,'wt');
+
+ fprintf(fid1, 'Analytical Northward Wind-stress\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, '\n');
+ fprintf(fid1, 'i/jdm = %i %i \n',idm,jdm);
+ for m = 1:tdm
+ fprintf(fid1,' taunwd: month,range = %2.2i %10.5E %10.5E\n', ...
+ time(m), min(min(ttn(:, :, m)')), max(max(ttn(:, :, m)')));
+ end
+
+ fclose(fid1);
+
+
\ No newline at end of file
diff --git a/PS/uv_dp_d1800_bb86-hycom.ps b/PS/uv_dp_d1800_bb86-hycom.ps
new file mode 100755
index 0000000..0d88584
Binary files /dev/null and b/PS/uv_dp_d1800_bb86-hycom.ps differ
diff --git a/config/alphaL_one b/config/alphaL_one
new file mode 100755
index 0000000..f74adbe
--- /dev/null
+++ b/config/alphaL_one
@@ -0,0 +1,46 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Compaq Alpha, Linux, one processor, real*8
+# see http://www.compaq.com/fortran/linux/ for Compaq f90 compiler
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = fort
+FCFFLAGS = -g3 -fast -O5 -convert big_endian -assume byterecl -warn nouncalled -real_size 64 -double_size 64 -integer_size 32
+CC = gcc
+CCFLAGS = -O
+CPP = cpp -P
+CPPFLAGS = -DALPHA -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -version
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/alpha_one b/config/alpha_one
new file mode 100755
index 0000000..81b184f
--- /dev/null
+++ b/config/alpha_one
@@ -0,0 +1,45 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Compaq Alpha, one processor, real*8
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f90
+FCFFLAGS = -g3 -fpe1 -fast -O5 -convert big_endian -assume byterecl -warn nouncalled -real_size 64 -double_size 64 -integer_size 32
+CC = cc
+CCFLAGS = -g3 -fast
+CPP = cpp -P
+CPPFLAGS = -DALPHA -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -version
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/amd64_one b/config/amd64_one
new file mode 100755
index 0000000..185c059
--- /dev/null
+++ b/config/amd64_one
@@ -0,0 +1,47 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for AMD64 Linux/PGI, single processor, real*8
+# see http://www.pgroup.com/ for Portland Group f90 compiler
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = pgf90
+FCFFLAGS = -g -w -fastsse -tp k8-64 -mcmodel=medium -byteswapio -r8
+CC = gcc
+CCFLAGS = -g -O -march=k8 -m64 -mcmodel=medium
+CPP = cpp -P
+#CPPFLAGS = -DIA32 -DREAL8
+CPPFLAGS = -DIA32 -DREAL8 -DTIMER
+LD = $(FC)
+LDFLAGS = -V $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/gfortran_one b/config/gfortran_one
new file mode 100755
index 0000000..01855f1
--- /dev/null
+++ b/config/gfortran_one
@@ -0,0 +1,46 @@
+#
+# ---------------------------------------------------------------------------
+# common definitions for gfortran version 8+, single processor, real*8
+# IFC version 8 has -convert big_endian, and does not need -DENDIAN_IO
+# ---------------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = gfortran
+FCFFLAGS = -g -O3 -w -static-libgfortran -fno-second-underscore -fconvert=big-endian -fdefault-real-8
+CC = gcc
+CCFLAGS = -O -static-libgfortran -fno-second-underscore
+CPP = cpp -P
+#CPPFLAGS = -DIA32 -DREAL8
+CPPFLAGS = -DIA32 -DREAL8 -DTIMER
+LD = $(FC)
+LDFLAGS = -v $(FCFFLAGS)
+EXTRALIBS =
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/hp_one b/config/hp_one
new file mode 100755
index 0000000..495f185
--- /dev/null
+++ b/config/hp_one
@@ -0,0 +1,47 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for HP, single processor, real*8
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f90
+#FCFFLAGS = +O3 +r8 +DD64
+FCFFLAGS = +O3 +r8
+CC = cc
+#CCFLAGS = -O +DD64
+CCFLAGS = -O
+CPP = cpp -P
+CPPFLAGS = -DHPUX -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/intelIFC7_one b/config/intelIFC7_one
new file mode 100755
index 0000000..afbd92a
--- /dev/null
+++ b/config/intelIFC7_one
@@ -0,0 +1,45 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Intel Linux/IFC, single processor, real*8
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = ifc
+FCFFLAGS = -g -cm -vec_report0 -w -O3 -tpp7 -xW -r8
+CC = gcc
+CCFLAGS = -O
+CPP = cpp -P
+CPPFLAGS = -DIA32 -DIFC -DREAL8 -DENDIAN_IO
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -Vaxlib -Bstatic
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/intelIFC_one b/config/intelIFC_one
new file mode 100755
index 0000000..f8a48f4
--- /dev/null
+++ b/config/intelIFC_one
@@ -0,0 +1,46 @@
+#
+# ---------------------------------------------------------------------------
+# common definitions for Intel Linux/IFC version 8+, single processor, real*8
+# IFC version 8 has -convert big_endian, and does not need -DENDIAN_IO
+# ---------------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = ifort
+FCFFLAGS = -g -convert big_endian -assume byterecl -cm -vec_report0 -w -O3 -tpp7 -xW -r8
+CC = gcc
+CCFLAGS = -O
+CPP = cpp -P
+CPPFLAGS = -DIA32 -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -Bstatic
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/intel_one b/config/intel_one
new file mode 100755
index 0000000..2befae6
--- /dev/null
+++ b/config/intel_one
@@ -0,0 +1,46 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Intel Linux/PGI, single processor, real*8
+# see http://www.pgroup.com/ for Portland Group f90 compiler
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = pgf90
+FCFFLAGS = -g -fast -byteswapio -r8
+CC = gcc
+CCFLAGS = -O
+CPP = cpp -P
+CPPFLAGS = -DIA32 -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -Wl,-Bstatic
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/o2k_one b/config/o2k_one
new file mode 100755
index 0000000..1bdb183
--- /dev/null
+++ b/config/o2k_one
@@ -0,0 +1,46 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for SGI Origin 2000, single processor, real*8
+# using -O3 instead of -Ofast=ip27 because of a bug in 7.3+ compilers
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f90
+FCFFLAGS = -g3 -64 -O3 -r8 -d8 -i4 -macro_expand
+CC = cc
+CCFLAGS = -g3 -64 -O3
+CPP = /usr/lib/acpp -P
+CPPFLAGS = -DSGI -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) -nocpp $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) -cpp $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/sp3_one b/config/sp3_one
new file mode 100755
index 0000000..349e400
--- /dev/null
+++ b/config/sp3_one
@@ -0,0 +1,49 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for IBM SMP Power3, single processor, real*8.
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = xlf95
+FCFFLAGS = -qfixed -O3 -qstrict -qarch=pwr3 -qtune=pwr3 -qcache=auto -qspillsize=32000 -qrealsize=8 -qintsize=4
+CC = cc
+CCFLAGS =
+CPP = /usr/lib/cpp -P
+CPPFLAGS = -DAIX -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -bmaxdata:2000000000 -bmaxstack:256000000
+EXTRALIBS = -lmass
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(RM) $<.f
+ $(CPP) $(CPPFLAGS) $< | sed -e '/^ *$$/d' > $<.f
+ $(FC) $(FCFFLAGS) -c $<.f
+ -\mv $<.o $*.o
+ $(RM) $<.f
diff --git a/config/sp4_one b/config/sp4_one
new file mode 100755
index 0000000..b62612d
--- /dev/null
+++ b/config/sp4_one
@@ -0,0 +1,49 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for IBM SMP Power4, single processor, real*8.
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = xlf95
+FCFFLAGS = -qfixed -O3 -qstrict -qarch=pwr4 -qtune=pwr4 -qcache=auto -qspillsize=32000 -qrealsize=8 -qintsize=4
+CC = cc
+CCFLAGS =
+CPP = /usr/lib/cpp -P
+CPPFLAGS = -DAIX -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -bmaxdata:2000000000 -bmaxstack:256000000
+EXTRALIBS = -lmass
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(RM) $<.f
+ $(CPP) $(CPPFLAGS) $< | sed -e '/^ *$$/d' > $<.f
+ $(FC) $(FCFFLAGS) -c $<.f
+ -\mv $<.o $*.o
+ $(RM) $<.f
diff --git a/config/sp5_one b/config/sp5_one
new file mode 100755
index 0000000..c888629
--- /dev/null
+++ b/config/sp5_one
@@ -0,0 +1,49 @@
+#
+# ------------------------------------------------------------------------
+# common definitions for IBM SMP Power5, single processor, real*8, 64-bit
+# ------------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = xlf95
+FCFFLAGS = -qfixed -O3 -qstrict -qarch=pwr5 -qtune=pwr5 -qcache=auto -qspillsize=32000 -qrealsize=8 -qintsize=4 -q64 -qwarn64
+CC = cc
+CCFLAGS = -q64
+CPP = /usr/lib/cpp -P
+CPPFLAGS = -DAIX -DREAL8 -DTIMER
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS) -b64
+EXTRALIBS = -lmass
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(RM) $<.f
+ $(CPP) $(CPPFLAGS) $< | sed -e '/^ *$$/d' > $<.f
+ $(FC) $(FCFFLAGS) -c $<.f
+ -\mv $<.o $*.o
+ $(RM) $<.f
diff --git a/config/sun64_one b/config/sun64_one
new file mode 100755
index 0000000..8187961
--- /dev/null
+++ b/config/sun64_one
@@ -0,0 +1,45 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Sun E10000, single processor, real*8, 64-bit
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f95
+FCFFLAGS = -g -fast -xarch=native64 -xpp=cpp -xtypemap=real:64,double:64,integer:32
+CC = cc
+CCFLAGS = -g -fast -xarch=native64
+CPP = /usr/ccs/lib/cpp -P
+CPPFLAGS = -DSUN -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/sun_one b/config/sun_one
new file mode 100755
index 0000000..9081302
--- /dev/null
+++ b/config/sun_one
@@ -0,0 +1,45 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Sun, single processor, real*8
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f95
+FCFFLAGS = -g -fast -xpp=cpp -xtypemap=real:64,double:64,integer:32
+CC = cc
+CCFLAGS = -g -fast
+CPP = /usr/ccs/lib/cpp -P
+CPPFLAGS = -DSUN -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(FC) $(CPPFLAGS) $(FCFFLAGS) -c $*.F
diff --git a/config/t3e_one b/config/t3e_one
new file mode 100755
index 0000000..ed89a0a
--- /dev/null
+++ b/config/t3e_one
@@ -0,0 +1,50 @@
+#
+# ---------------------------------------------------------------------
+# common definitions for Cray T3E, single processor.
+# ---------------------------------------------------------------------
+#
+# MACROS DESCRIPTIONS:
+#
+# FC: Fortran 90 compiler.
+# FCFFLAGS: Fortran 90 compilation flags.
+# CC: C compiler.
+# CCFLAGS: C compilation flags.
+# CPP: cpp preprocessor (may be implied by FC).
+# CPPFLAGS: cpp -D macro flags.
+# LD: Loader.
+# LDFLAGS: Loader flags.
+# EXTRALIBS: Extra local libraries (if any).
+#
+FC = f90
+FCFFLAGS = -X 1 -V -f fixed -O scalar2,unroll2,pipeline1,vector3 -d p -M 801
+CC = cc
+CCFLAGS =
+CPP = cpp -P
+CPPFLAGS = -Ucray -DT3E -DREAL8
+LD = $(FC)
+LDFLAGS = $(FCFFLAGS)
+EXTRALIBS =
+
+#
+# --- generic make definitions
+#
+SHELL = /bin/sh
+RM = \rm -f
+
+#
+# rules.
+#
+
+.c.o:
+ $(CC) $(CPPFLAGS) $(CCFLAGS) -c $*.c
+
+.f.o:
+ $(FC) $(FCFFLAGS) -c $*.f
+
+.F.o:
+ $(RM) $<.f $<.C
+ sed -e 's? */// *?/ / /?g' -e 's? *// *?/ /?g' $< > $<.C
+ $(CPP) $(CPPFLAGS) $<.C | sed -e '/^ *$$/d' > $<.f
+ $(FC) $(FCFFLAGS) -c $<.f
+ -\mv $<.o $*.o
+ $(RM) $<.f $<.C
diff --git a/expt_01.0/blkdat.input b/expt_01.0/blkdat.input
new file mode 100755
index 0000000..a0bd939
--- /dev/null
+++ b/expt_01.0/blkdat.input
@@ -0,0 +1,159 @@
+BB86 config ; analytic wind-stress
+3 layers (first one very thinto mimick a 2 layers config);
+src_2.2.18;
+12345678901234567890123456789012345678901234567890123456789012345678901234567890
+ 22 'iversn' = hycom version number x10
+ 010 'iexpt ' = experiment number x10
+ 101 'idm ' = longitudinal array size
+ 101 'jdm ' = latitudinal array size
+ 6 'itest ' = grid point where detailed diagnostics are desired
+ 6 'jtest ' = grid point where detailed diagnostics are desired
+ 3 'kdm ' = number of layers
+ 3 'nhybrd' = number of hybrid levels (0=all isopycnal)
+ 0 'nsigma' = number of sigma levels (nhybrd-nsigma z-levels)
+ 1.0 'dp00 ' = deep z-level spacing minimum thickness (m)
+ 1.0 'dp00x ' = deep z-level spacing maximum thickness (m)
+ 1.0 'dp00f ' = deep z-level spacing stretching factor (1.0=const.space)
+ 1.0 'ds00 ' = shallow z-level spacing minimum thickness (m)
+ 1.0 'ds00x ' = shallow z-level spacing maximum thickness (m)
+ 1.0 'ds00f ' = shallow z-level spacing stretching factor (1.0=const.space)
+ 1.0 'dp00i ' = deep iso-pycnal spacing minimum thickness (m)
+ 1.0 'isotop' = shallowest depth for isopycnal layers (m), <0 from file
+ 37.0 'saln0 ' = initial salinity value (psu), only used for iniflg<2
+ 1 'locsig' = locally-referenced pot. density for stability (0=F,1=T)
+ 0 'kapref' = thermobaric ref. state (-1=input,0=none,1,2,3=constant)
+ 0 'thflag' = reference pressure flag (0=Sigma-0, 2=Sigma-2)
+ 27.01037 'thbase' = reference density (sigma units)
+ 0 'vsigma' = spacially varying isopycnal target densities (0=F,1=T)
+ 27.01000 'sigma ' = layer 1 isopycnal target density (sigma units)
+ 27.01037 'sigma ' = layer 2 isopycnal target density (sigma units)
+ 27.22136 'sigma ' = layer 3 isopycnal target density (sigma units)
+ 2 'iniflg' = initial state flag (0=levl, 1=zonl, 2=clim)
+ 0 'jerlv0' = initial jerlov water type (1 to 5; 0 to use KPAR)
+ 0 'yrflag' = days in year flag (0=360, 1=366, 2=366J1, 3=actual)
+ 0 'sshflg' = diagnostic SSH flag (0=SSH,1=SSH&stericSSH)
+ 1.0 'dsurfq' = number of days between model diagnostics at the surface
+ 1.0 'diagfq' = number of days between model diagnostics
+ 0.0 'tilefq' = number of days between model diagnostics on selected tiles
+ 0.0 'meanfq' = number of days between model diagnostics (time averaged)
+ 10.0 'rstrfq' = number of days between model restart output
+ 0.0 'bnstfq' = number of days between baro nesting archive input
+ 0.0 'nestfq' = number of days between 3-d nesting archive input
+ 0.125 'cplifq' = number of days (or time steps) between sea ice coupling
+ 900.0 'baclin' = baroclinic time step (seconds), int. divisor of 86400
+ 45. 'batrop' = barotropic time step (seconds), int. div. of baclin/2
+ 0 'incflg' = incremental update flag (0=no, 1=yes, 2=full-velocity)
+ 12 'incstp' = no. timesteps for full update (1=direct insertion)
+ 1 'incupf' = number of days of incremental updating input
+ 0.125 'wbaro ' = barotropic time smoothing weight
+ 1 'btrlfr' = leapfrog barotropic time step (0=F,1=T)
+ 0 'btrmas' = barotropic is mass conserving (0=F,1=T)
+ 8.0 'hybrlx' = HYBGEN: inverse relaxation coefficient (time steps)
+ 0.01 'hybiso' = HYBGEN: Use PCM if layer is within hybiso of target density
+ 3 'hybmap' = hybrid remapper flag (0=PCM, 1=PLM, 2=PPM, 3=WENO-like)
+ 0 'hybflg' = hybrid generator flag (0=T&S, 1=th&S, 2=th&T)
+ 0 'advflg' = thermal advection flag (0=T&S, 1=th&S, 2=th&T)
+ 2 'advtyp' = scalar advection type (0=PCM,1=MPDATA,2=FCT2,4=FCT4)
+ 2 'momtyp' = momentum advection type (2=2nd order, 4=4th order)
+ -1.0 'slip ' = +1 for free-slip, -1 for non-slip boundary conditions
+ 0.005 'visco2' = deformation-dependent Laplacian viscosity factor
+ 0.0 'visco4' = deformation-dependent biharmonic viscosity factor
+ 0.0 'facdf4' = speed-dependent biharmonic viscosity factor
+ 0.005 'veldf2' = diffusion velocity (m/s) for Laplacian momentum dissip.
+ 0.00 'veldf4' = diffusion velocity (m/s) for biharmonic momentum dissip.
+ 0.0 'thkdf2' = diffusion velocity (m/s) for Laplacian thickness diffus.
+ 0.01 'thkdf4' = diffusion velocity (m/s) for biharmonic thickness diffus.
+ 0.015 'temdf2' = diffusion velocity (m/s) for Laplacian temp/saln diffus.
+ 1.0 'temdfc' = temp diffusion conservation (0.0,1.0 all dens,temp resp.)
+ 0.e-5 'vertmx' = diffusion velocity (m/s) for momentum at MICOM M.L.base
+ 0.02 'cbar ' = rms flow speed (m/s) for bottom friction
+ 0.e-3 'cb ' = coefficient of quadratic bottom friction
+ 1.e-7 'cbar2 ' = linear bottom drag (bb86)
+ 0.0 'drglim' = limiter for explicit friction (1.0 none, 0.0 implicit)
+ 0.0 'drgscl' = scale factor for tidal drag (0.0 for no tidal drag)
+ 500.0 'thkdrg' = thickness of bottom boundary layer for tidal drag (m)
+ 10.0 'thkbot' = thickness of bottom boundary layer (m)
+ 0.02 'sigjmp' = minimum density jump across interfaces (kg/m**3)
+ 0.3 'tmljmp' = equivalent temperature jump across mixed-layer (degC)
+ 15.0 'thkmls' = reference mixed-layer thickness for SSS relaxation (m)
+ 0.0 'thkmlt' = reference mixed-layer thickness for SST relaxation (m)
+ 6.0 'thkriv' = nominal thickness of river inflow (m)
+ 20.0 'thkfrz' = maximum thickness of near-surface freezing zone (m)
+ 0 'iceflg' = sea ice model flag (0=none,1=energy loan,2=coupled/esmf)
+ 0.0 'tfrz_0' = ENLN: ice melting point (degC) at S=0psu
+ -0.054 'tfrz_s' = ENLN: gradient of ice melting point (degC/psu)
+ 0.0 'ticegr' = ENLN: temp. grad. inside ice (deg/m); =0 use surtmp
+ 0.5 'hicemn' = ENLN: minimum ice thickness (m)
+ 10.0 'hicemx' = ENLN: maximum ice thickness (m)
+ 0 'ntracr' = number of tracers (0=none,negative to initialize)
+ 0 'trcflg' = tracer flags (one digit per tr, most sig. replicated)
+ 64 'tsofrq' = number of time steps between anti-drift offset calcs
+ 0.0 'tofset' = temperature anti-drift offset (degC/century)
+ 0.0 'sofset' = salnity anti-drift offset (psu/century)
+ 0 'mlflag' = mixed layer flag (0=none,1=KPP,2-3=KT,4=PWP,5=MY,6=GISS)
+ 0 'pensol' = KT: activate penetrating solar rad. (0=F,1=T)
+ 999.0 'dtrate' = KT: maximum permitted m.l. detrainment rate (m/day)
+ 19.2 'thkmin' = KT/PWP: minimum mixed-layer thickness (m)
+ 0 'dypflg' = KT/PWP: diapycnal mixing flag (0=none, 1=KPP, 2=explicit)
+99999 'mixfrq' = KT/PWP: number of time steps between diapycnal mix calcs
+ 1.e-7 'diapyc' = KT/PWP: diapycnal diffusivity x buoyancy freq. (m**2/s**2)
+ 0.25 'rigr ' = PWP: critical gradient richardson number
+ 0.65 'ribc ' = PWP: critical bulk richardson number
+ 0.7 'rinfty' = KPP: maximum gradient richardson number (shear inst.)
+ 0.25 'ricr ' = KPP: critical bulk richardson number
+ 0.0 'bldmin' = KPP: minimum surface boundary layer thickness (m)
+1200.0 'bldmax' = K-PROF: maximum surface boundary layer thickness (m)
+ 0.7 'cekman' = KPP/KT: scale factor for Ekman depth
+ 1.0 'cmonob' = KPP: scale factor for Monin-Obukov depth
+ 0 'bblkpp' = KPP: activate bottom boundary layer (0=F,1=T)
+ 1 'shinst' = KPP: activate shear instability mixing (0=F,1=T)
+ 1 'dbdiff' = KPP: activate double diffusion mixing (0=F,1=T)
+ 1 'nonloc' = KPP: activate nonlocal b. layer mixing (0=F,1=T)
+ 0 'latdiw' = K-PROF: activate lat.dep. int.wave mixing (0=F,1=T)
+ 0 'botdiw' = GISS: activate bot.enhan.int.wav mixing (0=F,1=T)
+ 0 'difout' = K-PROF: output visc/diff coffs in archive (0=F,1=T)
+ 13 'difsmo' = K-PROF: number of layers with horiz smooth diff coeffs
+ 50.0e-4 'difm0 ' = KPP: max viscosity due to shear instability (m**2/s)
+ 50.0e-4 'difs0 ' = KPP: max diffusivity due to shear instability (m**2/s)
+ 1.0e-4 'difmiw' = KPP: background/internal wave viscosity (m**2/s)
+ 0.1e-4 'difsiw' = KPP: background/internal wave diffusivity (m**2/s)
+ 10.0e-4 'dsfmax' = KPP: salt fingering diffusivity factor (m**2/s)
+ 1.9 'rrho0 ' = KPP: salt fingering rp=(alpha*delT)/(beta*delS)
+ 98.96 'cs ' = KPP: value for nonlocal flux term
+ 10.0 'cstar ' = KPP: value for nonlocal flux term
+ 0.0 'cv ' = KPP: buoyancy frequency ratio (0.0 to use a fn. of N)
+ 5.0 'c11 ' = KPP: value for turb velocity scale
+ 2 'hblflg' = KPP: b. layer interp. flag (0=const.,1=linear,2=quad.)
+ 2 'niter ' = KPP: iterations for semi-implicit soln. (2 recomended)
+ 0 'fltflg' = FLOATS: synthetic float flag (0=no; 1=yes)
+ 4 'nfladv' = FLOATS: advect every nfladv bacl. time steps (even, >=4)
+ 1 'nflsam' = FLOATS: output (0=every nfladv steps; >0=no. of days)
+ 0 'intpfl' = FLOATS: horiz. interp. (0=2nd order+n.n.; 1=n.n. only)
+ 0 'iturbv' = FLOATS: add horiz. turb. advection velocity (0=no; 1=yes)
+ 1 'ismpfl' = FLOATS: sample water properties at float (0=no; 1=yes)
+4.63e-6 'tbvar ' = FLOATS: horizontal turb. vel. variance scale (m**2/s**2)
+ 0.4 'tdecri' = FLOATS: inverse decorrelation time scale (1/day)
+ 0 'lbflag' = lateral barotropic bndy flag (0=none, 1=port, 2=input)
+ 0 'tidflg' = TIDES: tidal forcing flag (0=none,1=open-bdy,2=bdy&body)
+00000001 'tidcon' = TIDES: 1 digit per (Q1K2P1N2O1K1S2M2), 0=off,1=on
+ 0.06 'tidsal' = TIDES: scalar self attraction and loading factor
+ 1 'tidgen' = TIDES: generic time (0=F,1=T)
+ 1.0 'tidrmp' = TIDES: ramp time (days)
+ 0.0 'tid_t0' = TIDES: origin for ramp time (model day)
+ 12 'clmflg' = climatology frequency flag (6=bimonthly, 12=monthly)
+ 2 'wndflg' = wind stress input flag (0=none,1=u/v-grid,2,3=p-grid)
+ 50. 'pstrsi' = depth over which the wind is apply (m) (> 0 for bb86 only )
+ 4 'ustflg' = ustar forcing flag (3=input,1,2=wndspd,4=stress)
+ 0 'flxflg' = thermal forcing flag (0=none,3=net-flux,1,2,4=sst-based)
+ 0 'empflg' = E-P forcing flag (0=none,3=net_E-P, 1,2,4=sst-bas_E)
+ 0 'dswflg' = diurnal shortwave flag (0=none,1=daily to diurnal corr.)
+ 0 'sssflg' = SSS relaxation flag (0=none,1=clim)
+ 0 'lwflag' = longwave (SST) flag (0=none,1=clim,2=atmos)
+ 0 'sstflg' = SST relaxation flag (0=none,1=clim,2=atmos,3=observed)
+ 0 'icmflg' = ice mask flag (0=none,1=clim,2=atmos,3=obs/coupled)
+ 0 'flxoff' = net flux offset flag (0=F,1=T)
+ 0 'flxsmo' = smooth surface fluxes (0=F,1=T)
+ 0 'relax ' = activate lateral boundary nudging (0=F,1=T)
+ 0 'trcrlx' = activate lat. bound. tracer nudging (0=F,1=T)
+ 0 'priver' = rivers as a precipitation bogas (0=F,1=T)
+ 0 'epmass' = treat evap-precip as a mass exchange (0=F,1=T)
diff --git a/expt_01.0/gfortran.log b/expt_01.0/gfortran.log
new file mode 100755
index 0000000..4f0bce0
--- /dev/null
+++ b/expt_01.0/gfortran.log
@@ -0,0 +1,714 @@
+/Net/yucatan/abozec/BB86_PACKAGE/expt_01.0/data
+
+BB86 config ; analytic wind-stress
+3 layers (first one very thinto mimick a 2 layers config);
+src_2.2.18;
+12345678901234567890123456789012345678901234567890123456789012345678901234567890
+
+iversn = 22
+iexpt = 10
+
+idm = 101
+jdm = 101
+
+itest = 6
+jtest = 6
+
+kdm = 3
+nhybrd = 3
+nsigma = 0
+dp00 = 1.0000 m
+dp00x = 1.0000 m
+dp00f = 1.0000
+ds00 = 1.0000 m
+ds00x = 1.0000 m
+ds00f = 1.0000
+dp00i = 1.0000 m
+isotop = 1.0000 m
+
+saln0 = 37.0000 psu
+locsig = T
+kapref = 0
+thflag = 0
+
+equation of state is 7-term sigma-0
+
+thbase = 27.0104 sigma-0
+
+vsigma = F
+sigma = 27.0100 sigma-0
+sigma = 27.0104 sigma-0
+sigma = 27.2214 sigma-0
+
+iniflg = 2
+jerlv0 = 0
+
+yrflag = 0
+sshflg = 0
+dsurfq = 1.0000 days
+diagfq = 1.0000 days
+tilefq = 0.0000 days
+meanfq = 0.0000 days
+rstrfq = 10.0000 days
+bnstfq = 0.0000 days
+nestfq = 0.0000 days
+cplifq = 0.1250 days (-ve time steps)
+baclin = 900.0000 sec
+batrop = 45.0000 sec
+
+icefrq = 12
+
+incflg = 0
+incstp = 12
+incupf = 1
+
+wbaro = 0.1250
+btrlfr = T
+btrmas = F
+hybrlx = 8.0000 time steps
+hybiso = 0.0100 kg/m^3
+hybmap = 3
+hybflg = 0
+advflg = 0
+advtyp = 2
+momtyp = 2
+slip = -1.0000 (-1=no-slip, +1=free-slip)
+visco2 = 0.0050
+visco4 = 0.0000
+facdf4 = 0.0000
+veldf2 = 0.0050 m/s
+veldf4 = 0.0000 m/s
+thkdf2 = 0.0000 m/s
+thkdf4 = 0.0100 m/s (-ve if variable)
+temdf2 = 0.0150 m/s
+temdfc = 1.0000 (0.0,1.0 conserve dens,temp resp.)
+vertmx = 0.0000 m/s
+cbar = 0.0200 m/s
+cb = 0.0000
+cbar2 = 0.0000
+drglim = 0.0000
+drgscl = 0.0000
+thkdrg = 500.0000 m
+
+thkbot = 10.0000 m
+sigjmp = 0.0200 kg/m**3
+tmljmp = 0.3000 degC
+thkmls = 15.0000 m
+thkmlt = 0.0000 m
+thkriv = 6.0000 m
+
+thkfrz = 20.0000 m
+iceflg = 0
+tfrz_0 = 0.0000 degC
+tfrz_s = -0.0540 degC/psu
+ticegr = 0.0000 degC/m
+hicemn = 0.5000 m
+hicemx = 10.0000 m
+
+ntracr = 0
+trcflg = 0
+
+tsofrq = 64
+tofset = 0.0000 degC/century
+sofset = 0.0000 psu/century
+
+mlflag = 0
+pensol = F
+dtrate = 999.0000 m/day
+thkmin = 19.2000 m
+dypflg = 0
+mixfrq = 99999
+diapyc = 0.0000 m**2/s**2
+rigr = 0.2500
+ribc = 0.6500
+rinfty = 0.7000
+ricr = 0.2500
+bldmin = 0.0000 m
+bldmax = 1200.0000 m
+cekman = 0.7000
+cmonob = 1.0000
+bblkpp = F
+shinst = T
+dbdiff = T
+nonloc = T
+latdiw = F
+botdiw = F
+difout = F
+difsmo = 13
+difm0 = 0.0050 m**2/s
+difs0 = 0.0050 m**2/s
+difmiw = 0.0001 m**2/s
+difsiw = 0.0000 m**2/s
+dsfmax = 0.0010 m**2/s
+rrho0 = 1.9000
+cs = 98.9600
+cstar = 10.0000
+cv = 0.0000
+c11 = 5.0000
+hblflg = 2
+niter = 2
+fltflg = 0
+nfladv = 4
+nflsam = 1
+intpfl = 0
+iturbv = 0
+ismpfl = 1
+tbvar = 0.0000 m**2/s**2
+tdecri = 0.4000 1/day
+
+lbflag = 0
+tidflg = 0
+tidcon = 1
+tidsal = 0.0600
+tidgen = T
+tidrmp = 1.0000 days
+tid_t0 = 0.0000 model day
+
+clmflg = 12
+wndflg = 2
+pstrsi = 50.0000 m
+ustflg = 4
+flxflg = 0
+empflg = 0
+dswflg = 0
+sssflg = 0
+lwflag = 0
+sstflg = 0
+icmflg = 0
+flxoff = F
+flxsmo = F
+
+ !!!! BB86 Configuration !!!!
+
+
+relax = F
+trcrlx = F
+priver = F
+epmass = F
+
+
+ ddsurf = 1.0000000000000000 96
+ ddiagf = 1.0000000000000000 96
+ dtilef = 1.32046937523773889E+028 0
+ dmeanf = 1.32046937523773889E+028 0
+ drstrf = 10.000000000000000 960
+
+ turb. flux parameters:
+ thkdf2,temdf2 = 0.00E+00 1.50E-02
+ thkdf4 = 1.00E-02
+ veldf2,visco2 = 5.00E-03 5.00E-03
+ veldf4,visco4 = 0.00E+00 0.00E+00
+ diapyc,vertmx = 1.00E-07 0.00E+00
+
+ 20 barotropic steps per baroclinic time step
+
+ reading grid file from regional.grid.[ab]
+ 0 'mapflg' = map flag (0=mercator,10=panam,12=ulon-panam)
+plon: min,max = 0.00000 20.00000
+plat: min,max = 0.00000 20.00000
+ulon: min,max = -0.10000 19.90000
+ulat: min,max = 0.00000 20.00000
+vlon: min,max = 0.00000 20.00000
+vlat: min,max = -0.10000 19.90000
+pscx: min,max = 20000.00000 20000.00000
+pscy: min,max = 20000.00000 20000.00000
+qscx: min,max = 20000.00000 20000.00000
+qscy: min,max = 20000.00000 20000.00000
+uscx: min,max = 20000.00000 20000.00000
+uscy: min,max = 20000.00000 20000.00000
+vscx: min,max = 20000.00000 20000.00000
+vscy: min,max = 20000.00000 20000.00000
+cori: min,max = 7.34000E-05 1.13400E-04
+
+ i,j= 6 6 plat= 1.000 corio,scux,vy= 0.000075400 20000.00 20000.00
+
+ reading bathymetry file from regional.depth.[ab]
+
+ Bathymetry
+ i/jdm = 101 101
+
+
+
+ min,max depth = 5000.00000 5000.00000
+
+bigrid: nreg = 0
+bigrid: closed basin
+
+ip array, cols 1 -- 101
+ 101 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+ 100 0***************************************************************************************************0
+ 99 0***************************************************************************************************0
+ 98 0***************************************************************************************************0
+ 97 0***************************************************************************************************0
+ 96 0***************************************************************************************************0
+ 95 0***************************************************************************************************0
+ 94 0***************************************************************************************************0
+ 93 0***************************************************************************************************0
+ 92 0***************************************************************************************************0
+ 91 0***************************************************************************************************0
+ 90 0***************************************************************************************************0
+ 89 0***************************************************************************************************0
+ 88 0***************************************************************************************************0
+ 87 0***************************************************************************************************0
+ 86 0***************************************************************************************************0
+ 85 0***************************************************************************************************0
+ 84 0***************************************************************************************************0
+ 83 0***************************************************************************************************0
+ 82 0***************************************************************************************************0
+ 81 0***************************************************************************************************0
+ 80 0***************************************************************************************************0
+ 79 0***************************************************************************************************0
+ 78 0***************************************************************************************************0
+ 77 0***************************************************************************************************0
+ 76 0***************************************************************************************************0
+ 75 0***************************************************************************************************0
+ 74 0***************************************************************************************************0
+ 73 0***************************************************************************************************0
+ 72 0***************************************************************************************************0
+ 71 0***************************************************************************************************0
+ 70 0***************************************************************************************************0
+ 69 0***************************************************************************************************0
+ 68 0***************************************************************************************************0
+ 67 0***************************************************************************************************0
+ 66 0***************************************************************************************************0
+ 65 0***************************************************************************************************0
+ 64 0***************************************************************************************************0
+ 63 0***************************************************************************************************0
+ 62 0***************************************************************************************************0
+ 61 0***************************************************************************************************0
+ 60 0***************************************************************************************************0
+ 59 0***************************************************************************************************0
+ 58 0***************************************************************************************************0
+ 57 0***************************************************************************************************0
+ 56 0***************************************************************************************************0
+ 55 0***************************************************************************************************0
+ 54 0***************************************************************************************************0
+ 53 0***************************************************************************************************0
+ 52 0***************************************************************************************************0
+ 51 0***************************************************************************************************0
+ 50 0***************************************************************************************************0
+ 49 0***************************************************************************************************0
+ 48 0***************************************************************************************************0
+ 47 0***************************************************************************************************0
+ 46 0***************************************************************************************************0
+ 45 0***************************************************************************************************0
+ 44 0***************************************************************************************************0
+ 43 0***************************************************************************************************0
+ 42 0***************************************************************************************************0
+ 41 0***************************************************************************************************0
+ 40 0***************************************************************************************************0
+ 39 0***************************************************************************************************0
+ 38 0***************************************************************************************************0
+ 37 0***************************************************************************************************0
+ 36 0***************************************************************************************************0
+ 35 0***************************************************************************************************0
+ 34 0***************************************************************************************************0
+ 33 0***************************************************************************************************0
+ 32 0***************************************************************************************************0
+ 31 0***************************************************************************************************0
+ 30 0***************************************************************************************************0
+ 29 0***************************************************************************************************0
+ 28 0***************************************************************************************************0
+ 27 0***************************************************************************************************0
+ 26 0***************************************************************************************************0
+ 25 0***************************************************************************************************0
+ 24 0***************************************************************************************************0
+ 23 0***************************************************************************************************0
+ 22 0***************************************************************************************************0
+ 21 0***************************************************************************************************0
+ 20 0***************************************************************************************************0
+ 19 0***************************************************************************************************0
+ 18 0***************************************************************************************************0
+ 17 0***************************************************************************************************0
+ 16 0***************************************************************************************************0
+ 15 0***************************************************************************************************0
+ 14 0***************************************************************************************************0
+ 13 0***************************************************************************************************0
+ 12 0***************************************************************************************************0
+ 11 0***************************************************************************************************0
+ 10 0***************************************************************************************************0
+ 9 0***************************************************************************************************0
+ 8 0***************************************************************************************************0
+ 7 0***************************************************************************************************0
+ 6 0***************************************************************************************************0
+ 5 0***************************************************************************************************0
+ 4 0***************************************************************************************************0
+ 3 0***************************************************************************************************0
+ 2 0***************************************************************************************************0
+ 1 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+
+
+ mean basin depth (m) and area (10^6 km^2): 5000.0 3.92
+
+dp0k( 1) = 1.00 m thkns = 1.00 m depth = 1.00 m
+dp0k( 2) = 1.00 m thkns = 1.00 m depth = 2.00 m
+dp0k( 3) = 1.00 m thkns = 1.00 m depth = 3.00 m
+
+ds0k( 1) = 1.00 m thkns = 1.00 m depth = 1.00 m
+
+ now opening forcing fields ...
+
+Analytical Eastward Wind-stress
+i/jdm = 101 101
+ tauewd: month,range = 01 -1.00000E-01 1.00000E-01
+
+Analytical Northward Wind-stress
+i/jdm = 101 101
+ taunwd: month,range = 01 0.00000E+00 0.00000E+00
+ ...finished opening forcing fields
+ now opening kpar field ...
+ ...finished opening kpar field
+ now opening rivers field ...
+ ...finished opening river field
+ now opening relaxation fields ...
+ No thermal relaxation mask.
+
+ Potential Temperature
+i/jdm = 101 101
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+
+ Salinity
+i/jdm = 101 101
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+
+ Interface Depths
+i/jdm = 101 101
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+ ...finished opening relaxation fields
+ rdrlax - month = 1 1
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+rdrlax: pwall.2 ok; expected,input min depth = 1.00 1.00
+rdrlax: pwall.3 NOT ok; expected,input min depth = 2.00 500.00 (bad climatology?)
+rdrlax: continuing because file ./relax.weird exists (ignore the "bad" climatology)
+ relaxation fields for month 1 written into slot 1
+ sigma(k): 27.01 27.01 27.22
+ 0 6 6 istate: temp saln thstar thkns dpth montg
+ mxl 19.2
+ 1 17.18 37.00 27.01 1.0 0.5 0.000
+ 2 17.18 37.00 27.01 499.0 250.5 -0.000
+ 3 16.30 37.00 27.22 4500.0 2750.0 -0.106
+ bot 5000.0
+ 0 6 6 istate: temp saln thstar thkns dpth montg
+ mxl 19.2
+ 1 17.18 37.00 27.01 1.0 0.5 0.000
+ 2 17.18 37.00 27.01 499.0 250.5 -0.000
+ 3 16.30 37.00 27.22 4500.0 2750.0 -0.106
+ bot 5000.0
+
+model starts at day 0.0, goes to day 11.0 (steps 0 -- 1056)
+
+ tauewd: month,range = 12 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 12 0.00000E+00 0.00000E+00
+ forcing functions for month 12 written into slot 1
+ tauewd: month,range = 01 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 01 0.00000E+00 0.00000E+00
+ forcing functions for month 1 written into slot 2
+ tauewd: month,range = 02 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 02 0.00000E+00 0.00000E+00
+ forcing functions for month 2 written into slot 3
+ tauewd: month,range = 03 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 03 0.00000E+00 0.00000E+00
+ forcing functions for month 3 written into slot 4
+ rdrlax - month = 12 12
+ tem : month,layer,dens,range = 12 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 12 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 12 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 12 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 12 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 12 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 12 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 12 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 12 03 27.221 4.90300E+06 4.90300E+06
+rdrlax: pwall.2 ok; expected,input min depth = 1.00 1.00
+rdrlax: pwall.3 NOT ok; expected,input min depth = 2.00 500.00 (bad climatology?)
+rdrlax: continuing because file ./relax.weird exists (ignore the "bad" climatology)
+ relaxation fields for month 12 written into slot 1
+ rdrlax - month = 1 1
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 1 written into slot 2
+ rdrlax - month = 2 2
+ tem : month,layer,dens,range = 02 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 02 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 02 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 02 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 02 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 02 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 02 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 02 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 02 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 2 written into slot 3
+ rdrlax - month = 3 3
+ tem : month,layer,dens,range = 03 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 03 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 03 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 03 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 03 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 03 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 03 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 03 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 03 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 3 written into slot 4
+
+
+ timer statistics
+ ------------------
+
+ xceget calls = 1 time = 0.00000 time/call = 0.00000000
+ xclget calls = 101 time = 0.00000 time/call = 0.00000000
+ xcsum calls = 2 time = 0.00000 time/call = 0.00000000
+ xcmaxr calls = 5 time = 0.00000 time/call = 0.00000000
+ xctilr calls = 79 time = 0.00000 time/call = 0.00000000
+ zaio** calls = 191 time = 0.00100 time/call = 0.00000524
+ zaiord calls = 21 time = 0.01100 time/call = 0.00052381
+ zaiowr calls = 26 time = 0.01200 time/call = 0.00046154
+ total calls = 1 time = 0.08700 time/call = 0.08700000
+
+
+
+ 1 (0001/016 00) mean SSH (mm): -0.00 (-4.9E-05 to -4.9E-05)
+ 1 (0001/016 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 1 (0001/016 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 1 (0001/016 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 1 (0001/016 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 1 (0001/016 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 1 (0001/016 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 1 (0001/016 00) region-wide mean Kin. Energy: 0.0046712813
+ 1 (0001/016 00) region-wide mean Temperature: 16.3881703000
+ 1 (0001/016 00) region-wide mean Salinity: 37.0000000000
+ 1 (0001/016 00) region-wide mean Density Dev: 0.1898957149
+ 96 1 min/max of s after advection: 37.000 37.000 (range: 1.21E-13)
+ 96 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 96 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 96 (0001/017 00) mean SSH (mm): -0.00 (-5.2E+00 to 4.7E+00)
+ 96 (0001/017 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 96 (0001/017 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 96 (0001/017 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 96 (0001/017 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 96 (0001/017 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 96 (0001/017 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 96 (0001/017 00) region-wide mean Kin. Energy: 4.1435491705
+ 96 (0001/017 00) region-wide mean Temperature: 16.3881703000
+ 96 (0001/017 00) region-wide mean Salinity: 37.0000000000
+ 96 (0001/017 00) region-wide mean Density Dev: 0.1898957164
+ step 96 day 1.00 -- archiving completed --
+ 192 1 min/max of s after advection: 37.000 37.000 (range: 1.63E-13)
+ 192 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 192 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 192 (0001/018 00) mean SSH (mm): -0.00 (-1.0E+01 to 9.3E+00)
+ 192 (0001/018 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 192 (0001/018 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 192 (0001/018 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 192 (0001/018 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 192 (0001/018 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 192 (0001/018 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 192 (0001/018 00) region-wide mean Kin. Energy: 13.4000676946
+ 192 (0001/018 00) region-wide mean Temperature: 16.3881703000
+ 192 (0001/018 00) region-wide mean Salinity: 37.0000000000
+ 192 (0001/018 00) region-wide mean Density Dev: 0.1898957164
+ step 192 day 2.00 -- archiving completed --
+ 288 1 min/max of s after advection: 37.000 37.000 (range: 1.99E-13)
+ 288 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 288 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 288 (0001/019 00) mean SSH (mm): -0.00 (-1.6E+01 to 1.4E+01)
+ 288 (0001/019 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 288 (0001/019 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 288 (0001/019 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 288 (0001/019 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 288 (0001/019 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 288 (0001/019 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 288 (0001/019 00) region-wide mean Kin. Energy: 28.1775874769
+ 288 (0001/019 00) region-wide mean Temperature: 16.3881702999
+ 288 (0001/019 00) region-wide mean Salinity: 37.0000000000
+ 288 (0001/019 00) region-wide mean Density Dev: 0.1898957164
+ step 288 day 3.00 -- archiving completed --
+ 384 1 min/max of s after advection: 37.000 37.000 (range: 1.99E-13)
+ 384 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 384 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 384 (0001/020 00) mean SSH (mm): -0.00 (-2.1E+01 to 1.9E+01)
+ 384 (0001/020 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 384 (0001/020 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 384 (0001/020 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 384 (0001/020 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 384 (0001/020 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 384 (0001/020 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 384 (0001/020 00) region-wide mean Kin. Energy: 48.4792337492
+ 384 (0001/020 00) region-wide mean Temperature: 16.3881702999
+ 384 (0001/020 00) region-wide mean Salinity: 37.0000000000
+ 384 (0001/020 00) region-wide mean Density Dev: 0.1898957164
+ step 384 day 4.00 -- archiving completed --
+ 480 1 min/max of s after advection: 37.000 37.000 (range: 2.06E-13)
+ 480 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 480 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 480 (0001/021 00) mean SSH (mm): -0.00 (-2.6E+01 to 2.3E+01)
+ 480 (0001/021 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 480 (0001/021 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 480 (0001/021 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 480 (0001/021 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 480 (0001/021 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 480 (0001/021 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 480 (0001/021 00) region-wide mean Kin. Energy: 74.1010188713
+ 480 (0001/021 00) region-wide mean Temperature: 16.3881702998
+ 480 (0001/021 00) region-wide mean Salinity: 37.0000000000
+ 480 (0001/021 00) region-wide mean Density Dev: 0.1898957164
+ step 480 day 5.00 -- archiving completed --
+ 576 1 min/max of s after advection: 37.000 37.000 (range: 2.34E-13)
+ 576 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 576 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 576 (0001/022 00) mean SSH (mm): -0.00 (-3.1E+01 to 2.8E+01)
+ 576 (0001/022 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 576 (0001/022 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 576 (0001/022 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 576 (0001/022 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 576 (0001/022 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 576 (0001/022 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 576 (0001/022 00) region-wide mean Kin. Energy: 103.6767480728
+ 576 (0001/022 00) region-wide mean Temperature: 16.3881702998
+ 576 (0001/022 00) region-wide mean Salinity: 37.0000000000
+ 576 (0001/022 00) region-wide mean Density Dev: 0.1898957164
+ step 576 day 6.00 -- archiving completed --
+ 672 1 min/max of s after advection: 37.000 37.000 (range: 2.49E-13)
+ 672 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 672 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 672 (0001/023 00) mean SSH (mm): -0.00 (-3.7E+01 to 3.2E+01)
+ 672 (0001/023 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 672 (0001/023 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 672 (0001/023 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 672 (0001/023 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 672 (0001/023 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 672 (0001/023 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 672 (0001/023 00) region-wide mean Kin. Energy: 137.1932721004
+ 672 (0001/023 00) region-wide mean Temperature: 16.3881702997
+ 672 (0001/023 00) region-wide mean Salinity: 37.0000000000
+ 672 (0001/023 00) region-wide mean Density Dev: 0.1898957164
+ step 672 day 7.00 -- archiving completed --
+ 768 1 min/max of s after advection: 37.000 37.000 (range: 2.56E-13)
+ 768 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 768 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 768 (0001/024 00) mean SSH (mm): -0.00 (-4.2E+01 to 3.7E+01)
+ 768 (0001/024 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 768 (0001/024 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 768 (0001/024 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 768 (0001/024 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 768 (0001/024 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 768 (0001/024 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 768 (0001/024 00) region-wide mean Kin. Energy: 174.0606716237
+ 768 (0001/024 00) region-wide mean Temperature: 16.3881702996
+ 768 (0001/024 00) region-wide mean Salinity: 37.0000000000
+ 768 (0001/024 00) region-wide mean Density Dev: 0.1898957165
+ step 768 day 8.00 -- archiving completed --
+ 864 1 min/max of s after advection: 37.000 37.000 (range: 2.56E-13)
+ 864 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 864 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 864 (0001/025 00) mean SSH (mm): -0.00 (-4.7E+01 to 4.1E+01)
+ 864 (0001/025 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 864 (0001/025 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 864 (0001/025 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 864 (0001/025 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 864 (0001/025 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 864 (0001/025 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 864 (0001/025 00) region-wide mean Kin. Energy: 213.4808462973
+ 864 (0001/025 00) region-wide mean Temperature: 16.3881702995
+ 864 (0001/025 00) region-wide mean Salinity: 37.0000000000
+ 864 (0001/025 00) region-wide mean Density Dev: 0.1898957165
+ step 864 day 9.00 -- archiving completed --
+ 960 1 min/max of s after advection: 37.000 37.000 (range: 2.77E-13)
+ 960 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 960 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 960 (0001/026 00) mean SSH (mm): -0.00 (-5.2E+01 to 4.5E+01)
+ 960 (0001/026 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 960 (0001/026 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 960 (0001/026 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 960 (0001/026 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 960 (0001/026 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 960 (0001/026 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 960 (0001/026 00) region-wide mean Kin. Energy: 255.1225661207
+ 960 (0001/026 00) region-wide mean Temperature: 16.3881702995
+ 960 (0001/026 00) region-wide mean Salinity: 37.0000000000
+ 960 (0001/026 00) region-wide mean Density Dev: 0.1898957165
+ time step 960 y e a r 0001 d a y 026 h o u r 00
+ creating a new backup restart file
+ restart created at model day 10.000
+ step 960 day 10.00 -- archiving completed --
+ 1056 1 min/max of s after advection: 37.000 37.000 (range: 1.35E-13)
+ 1056 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 1056 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 1056 (0001/027 00) mean SSH (mm): -0.00 (-5.6E+01 to 4.9E+01)
+ 1056 (0001/027 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 1056 (0001/027 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 1056 (0001/027 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 1056 (0001/027 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 1056 (0001/027 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 1056 (0001/027 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 1056 (0001/027 00) region-wide mean Kin. Energy: 298.0232597882
+ 1056 (0001/027 00) region-wide mean Temperature: 16.3881704135
+ 1056 (0001/027 00) region-wide mean Salinity: 37.0000000000
+ 1056 (0001/027 00) region-wide mean Density Dev: 0.1898956897
+ northward heat flux (petawatts):
+ 0.000 0.000 0.006 0.010 0.012 0.012 0.012 0.011 0.009 0.007 0.004
+ 0.002 0.001 0.001 0.000 0.000 0.001 0.001 0.001 0.002 0.002 0.001
+ 0.001 -0.000 -0.001 -0.001 -0.002 -0.002 -0.002 -0.002 -0.002 -0.002 -0.002
+ -0.003 -0.004 -0.005 -0.007 -0.008 -0.009 -0.010 -0.010 -0.009 -0.009 -0.007
+ -0.006 -0.005 -0.004 -0.004 -0.004 -0.004 -0.005 -0.007 -0.008 -0.009 -0.010
+ -0.010 -0.010 -0.010 -0.009 -0.008 -0.006 -0.005 -0.004 -0.003 -0.003 -0.003
+ -0.003 -0.003 -0.004 -0.004 -0.004 -0.004 -0.003 -0.003 -0.002 -0.001 -0.001
+ -0.001 -0.000 -0.000 -0.000 -0.000 0.000 0.001 0.001 0.002 0.003 0.004
+ 0.004 0.005 0.005 0.005 0.005 0.004 0.002 0.002 0.001 0.001 0.002
+ 0.001
+ time step 1056 y e a r 0001 d a y 027 h o u r 00
+ creating a new standard restart file
+ restart created & closed at model day 11.000
+ step 1056 day 11.00 -- archiving completed --
+
+
+ timer statistics
+ ------------------
+
+ xcsum calls = 2412 time = 0.13000 time/call = 0.00005390
+ xcmaxr calls = 1432 time = 0.00200 time/call = 0.00000140
+ xctilr calls = 111982 time = 1.97200 time/call = 0.00001761
+ zaio** calls = 27 time = 0.00200 time/call = 0.00007407
+ zaiowr calls = 374 time = 0.16900 time/call = 0.00045187
+ cnuity calls = 1056 time = 7.14000 time/call = 0.00676136
+ tsadvc calls = 1056 time = 14.14400 time/call = 0.01339394
+ momtum calls = 1056 time = 24.70100 time/call = 0.02339110
+ barotp calls = 1056 time = 14.23900 time/call = 0.01348390
+ thermf calls = 1056 time = 0.16000 time/call = 0.00015152
+ ic**** calls = 1056 time = 0.16100 time/call = 0.00015246
+ mx**** calls = 1056 time = 0.00000 time/call = 0.00000000
+ conv** calls = 1056 time = 5.00300 time/call = 0.00473769
+ diapf* calls = 1056 time = 0.00000 time/call = 0.00000000
+ hybgen calls = 1056 time = 19.23500 time/call = 0.01821496
+ restrt calls = 2 time = 0.04600 time/call = 0.02300000
+ overtn calls = 1 time = 0.00100 time/call = 0.00100000
+ archiv calls = 11 time = 0.14700 time/call = 0.01336364
+ incupd calls = 1056 time = 0.00000 time/call = 0.00000000
+ total calls = 1 time = 85.42300 time/call = 85.42300000
+
+
+
+ **************************************************
+ (normal)
+ **************************************************
+You are Done !
diff --git a/expt_01.0/intel.log b/expt_01.0/intel.log
new file mode 100755
index 0000000..cb00a32
--- /dev/null
+++ b/expt_01.0/intel.log
@@ -0,0 +1,701 @@
+/Net/yucatan/abozec/BB86_PACKAGE/expt_01.0/data
+
+BB86 config ; analytic wind-stress
+3 layers (first one very thinto mimick a 2 layers config);
+src_2.2.18;
+12345678901234567890123456789012345678901234567890123456789012345678901234567890
+
+iversn = 22
+iexpt = 10
+
+idm = 101
+jdm = 101
+
+itest = 6
+jtest = 6
+
+kdm = 3
+nhybrd = 3
+nsigma = 0
+dp00 = 1.0000 m
+dp00x = 1.0000 m
+dp00f = 1.0000
+ds00 = 1.0000 m
+ds00x = 1.0000 m
+ds00f = 1.0000
+dp00i = 1.0000 m
+isotop = 1.0000 m
+
+saln0 = 37.0000 psu
+locsig = T
+kapref = 0
+thflag = 0
+
+equation of state is 7-term sigma-0
+
+thbase = 27.0104 sigma-0
+
+vsigma = F
+sigma = 27.0100 sigma-0
+sigma = 27.0104 sigma-0
+sigma = 27.2214 sigma-0
+
+iniflg = 2
+jerlv0 = 0
+
+yrflag = 0
+sshflg = 0
+dsurfq = 1.0000 days
+diagfq = 1.0000 days
+tilefq = 0.0000 days
+meanfq = 0.0000 days
+rstrfq = 10.0000 days
+bnstfq = 0.0000 days
+nestfq = 0.0000 days
+cplifq = 0.1250 days (-ve time steps)
+baclin = 900.0000 sec
+batrop = 45.0000 sec
+
+icefrq = 12
+
+incflg = 0
+incstp = 12
+incupf = 1
+
+wbaro = 0.1250
+btrlfr = T
+btrmas = F
+hybrlx = 8.0000 time steps
+hybiso = 0.0100 kg/m^3
+hybmap = 3
+hybflg = 0
+advflg = 0
+advtyp = 2
+momtyp = 2
+slip = -1.0000 (-1=no-slip, +1=free-slip)
+visco2 = 0.0050
+visco4 = 0.0000
+facdf4 = 0.0000
+veldf2 = 0.0050 m/s
+veldf4 = 0.0000 m/s
+thkdf2 = 0.0000 m/s
+thkdf4 = 0.0100 m/s (-ve if variable)
+temdf2 = 0.0150 m/s
+temdfc = 1.0000 (0.0,1.0 conserve dens,temp resp.)
+vertmx = 0.0000 m/s
+cbar = 0.0200 m/s
+cb = 0.0000
+cbar2 = 0.0000
+drglim = 0.0000
+drgscl = 0.0000
+thkdrg = 500.0000 m
+
+thkbot = 10.0000 m
+sigjmp = 0.0200 kg/m**3
+tmljmp = 0.3000 degC
+thkmls = 15.0000 m
+thkmlt = 0.0000 m
+thkriv = 6.0000 m
+
+thkfrz = 20.0000 m
+iceflg = 0
+tfrz_0 = 0.0000 degC
+tfrz_s = -0.0540 degC/psu
+ticegr = 0.0000 degC/m
+hicemn = 0.5000 m
+hicemx = 10.0000 m
+
+ntracr = 0
+trcflg = 0
+
+tsofrq = 64
+tofset = 0.0000 degC/century
+sofset = 0.0000 psu/century
+
+mlflag = 0
+pensol = F
+dtrate = 999.0000 m/day
+thkmin = 19.2000 m
+dypflg = 0
+mixfrq = 99999
+diapyc = 0.0000 m**2/s**2
+rigr = 0.2500
+ribc = 0.6500
+rinfty = 0.7000
+ricr = 0.2500
+bldmin = 0.0000 m
+bldmax = 1200.0000 m
+cekman = 0.7000
+cmonob = 1.0000
+bblkpp = F
+shinst = T
+dbdiff = T
+nonloc = T
+latdiw = F
+botdiw = F
+difout = F
+difsmo = 13
+difm0 = 0.0050 m**2/s
+difs0 = 0.0050 m**2/s
+difmiw = 0.0001 m**2/s
+difsiw = 0.0000 m**2/s
+dsfmax = 0.0010 m**2/s
+rrho0 = 1.9000
+cs = 98.9600
+cstar = 10.0000
+cv = 0.0000
+c11 = 5.0000
+hblflg = 2
+niter = 2
+fltflg = 0
+nfladv = 4
+nflsam = 1
+intpfl = 0
+iturbv = 0
+ismpfl = 1
+tbvar = 0.0000 m**2/s**2
+tdecri = 0.4000 1/day
+
+lbflag = 0
+tidflg = 0
+tidcon = 1
+tidsal = 0.0600
+tidgen = T
+tidrmp = 1.0000 days
+tid_t0 = 0.0000 model day
+
+clmflg = 12
+wndflg = 2
+pstrsi = 50.0000 m
+ustflg = 4
+flxflg = 0
+empflg = 0
+dswflg = 0
+sssflg = 0
+lwflag = 0
+sstflg = 0
+icmflg = 0
+flxoff = F
+flxsmo = F
+
+ !!!! BB86 Configuration !!!!
+
+
+relax = F
+trcrlx = F
+priver = F
+epmass = F
+
+
+ ddsurf = 1.00000000000000 96
+ ddiagf = 1.00000000000000 96
+ dtilef = 1.320469375237739E+028 -2147483648
+ dmeanf = 1.320469375237739E+028 -2147483648
+ drstrf = 10.0000000000000 960
+
+ turb. flux parameters:
+ thkdf2,temdf2 = 0.00E+00 1.50E-02
+ thkdf4 = 1.00E-02
+ veldf2,visco2 = 5.00E-03 5.00E-03
+ veldf4,visco4 = 0.00E+00 0.00E+00
+ diapyc,vertmx = 1.00E-07 0.00E+00
+
+ 20 barotropic steps per baroclinic time step
+
+ reading grid file from regional.grid.[ab]
+ 0 'mapflg' = map flag (0=mercator,10=panam,12=ulon-panam)
+plon: min,max = 0.00000 20.00000
+plat: min,max = 0.00000 20.00000
+ulon: min,max = -0.10000 19.90000
+ulat: min,max = 0.00000 20.00000
+vlon: min,max = 0.00000 20.00000
+vlat: min,max = -0.10000 19.90000
+pscx: min,max = 20000.00000 20000.00000
+pscy: min,max = 20000.00000 20000.00000
+qscx: min,max = 20000.00000 20000.00000
+qscy: min,max = 20000.00000 20000.00000
+uscx: min,max = 20000.00000 20000.00000
+uscy: min,max = 20000.00000 20000.00000
+vscx: min,max = 20000.00000 20000.00000
+vscy: min,max = 20000.00000 20000.00000
+cori: min,max = 7.34000E-05 1.13400E-04
+
+ i,j= 6 6 plat= 1.000 corio,scux,vy= 0.000075400 20000.00 20000.00
+
+ reading bathymetry file from regional.depth.[ab]
+
+ Bathymetry
+ i/jdm = 101 101
+
+
+
+ min,max depth = 5000.00000 5000.00000
+
+bigrid: nreg = 0
+bigrid: closed basin
+
+ip array, cols 1 -- 101
+ 101 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+ 100 0***************************************************************************************************0
+ 99 0***************************************************************************************************0
+ 98 0***************************************************************************************************0
+ 97 0***************************************************************************************************0
+ 96 0***************************************************************************************************0
+ 95 0***************************************************************************************************0
+ 94 0***************************************************************************************************0
+ 93 0***************************************************************************************************0
+ 92 0***************************************************************************************************0
+ 91 0***************************************************************************************************0
+ 90 0***************************************************************************************************0
+ 89 0***************************************************************************************************0
+ 88 0***************************************************************************************************0
+ 87 0***************************************************************************************************0
+ 86 0***************************************************************************************************0
+ 85 0***************************************************************************************************0
+ 84 0***************************************************************************************************0
+ 83 0***************************************************************************************************0
+ 82 0***************************************************************************************************0
+ 81 0***************************************************************************************************0
+ 80 0***************************************************************************************************0
+ 79 0***************************************************************************************************0
+ 78 0***************************************************************************************************0
+ 77 0***************************************************************************************************0
+ 76 0***************************************************************************************************0
+ 75 0***************************************************************************************************0
+ 74 0***************************************************************************************************0
+ 73 0***************************************************************************************************0
+ 72 0***************************************************************************************************0
+ 71 0***************************************************************************************************0
+ 70 0***************************************************************************************************0
+ 69 0***************************************************************************************************0
+ 68 0***************************************************************************************************0
+ 67 0***************************************************************************************************0
+ 66 0***************************************************************************************************0
+ 65 0***************************************************************************************************0
+ 64 0***************************************************************************************************0
+ 63 0***************************************************************************************************0
+ 62 0***************************************************************************************************0
+ 61 0***************************************************************************************************0
+ 60 0***************************************************************************************************0
+ 59 0***************************************************************************************************0
+ 58 0***************************************************************************************************0
+ 57 0***************************************************************************************************0
+ 56 0***************************************************************************************************0
+ 55 0***************************************************************************************************0
+ 54 0***************************************************************************************************0
+ 53 0***************************************************************************************************0
+ 52 0***************************************************************************************************0
+ 51 0***************************************************************************************************0
+ 50 0***************************************************************************************************0
+ 49 0***************************************************************************************************0
+ 48 0***************************************************************************************************0
+ 47 0***************************************************************************************************0
+ 46 0***************************************************************************************************0
+ 45 0***************************************************************************************************0
+ 44 0***************************************************************************************************0
+ 43 0***************************************************************************************************0
+ 42 0***************************************************************************************************0
+ 41 0***************************************************************************************************0
+ 40 0***************************************************************************************************0
+ 39 0***************************************************************************************************0
+ 38 0***************************************************************************************************0
+ 37 0***************************************************************************************************0
+ 36 0***************************************************************************************************0
+ 35 0***************************************************************************************************0
+ 34 0***************************************************************************************************0
+ 33 0***************************************************************************************************0
+ 32 0***************************************************************************************************0
+ 31 0***************************************************************************************************0
+ 30 0***************************************************************************************************0
+ 29 0***************************************************************************************************0
+ 28 0***************************************************************************************************0
+ 27 0***************************************************************************************************0
+ 26 0***************************************************************************************************0
+ 25 0***************************************************************************************************0
+ 24 0***************************************************************************************************0
+ 23 0***************************************************************************************************0
+ 22 0***************************************************************************************************0
+ 21 0***************************************************************************************************0
+ 20 0***************************************************************************************************0
+ 19 0***************************************************************************************************0
+ 18 0***************************************************************************************************0
+ 17 0***************************************************************************************************0
+ 16 0***************************************************************************************************0
+ 15 0***************************************************************************************************0
+ 14 0***************************************************************************************************0
+ 13 0***************************************************************************************************0
+ 12 0***************************************************************************************************0
+ 11 0***************************************************************************************************0
+ 10 0***************************************************************************************************0
+ 9 0***************************************************************************************************0
+ 8 0***************************************************************************************************0
+ 7 0***************************************************************************************************0
+ 6 0***************************************************************************************************0
+ 5 0***************************************************************************************************0
+ 4 0***************************************************************************************************0
+ 3 0***************************************************************************************************0
+ 2 0***************************************************************************************************0
+ 1 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+
+
+ mean basin depth (m) and area (10^6 km^2): 5000.0 3.92
+
+dp0k( 1) = 1.00 m thkns = 1.00 m depth = 1.00 m
+dp0k( 2) = 1.00 m thkns = 1.00 m depth = 2.00 m
+dp0k( 3) = 1.00 m thkns = 1.00 m depth = 3.00 m
+
+ds0k( 1) = 1.00 m thkns = 1.00 m depth = 1.00 m
+
+ now opening forcing fields ...
+
+Analytical Eastward Wind-stress
+i/jdm = 101 101
+ tauewd: month,range = 01 -1.00000E-01 1.00000E-01
+
+Analytical Northward Wind-stress
+i/jdm = 101 101
+ taunwd: month,range = 01 0.00000E+00 0.00000E+00
+ ...finished opening forcing fields
+ now opening kpar field ...
+ ...finished opening kpar field
+ now opening rivers field ...
+ ...finished opening river field
+ now opening relaxation fields ...
+ No thermal relaxation mask.
+
+ Potential Temperature
+i/jdm = 101 101
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+
+ Salinity
+i/jdm = 101 101
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+
+ Interface Depths
+i/jdm = 101 101
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+ ...finished opening relaxation fields
+ rdrlax - month = 1 1
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+rdrlax: pwall.2 ok; expected,input min depth = 1.00 1.00
+rdrlax: pwall.3 NOT ok; expected,input min depth = 2.00 500.00 (bad climatology?)
+rdrlax: continuing because file ./relax.weird exists (ignore the "bad" climatology)
+ relaxation fields for month 1 written into slot 1
+ sigma(k): 27.01 27.01 27.22
+ 0 6 6 istate: temp saln thstar thkns dpth montg
+ mxl 19.2
+ 1 17.18 37.00 27.01 1.0 0.5 0.000
+ 2 17.18 37.00 27.01 499.0 250.5 0.000
+ 3 16.30 37.00 27.22 4500.0 2750.0 -0.106
+ bot 5000.0
+ 0 6 6 istate: temp saln thstar thkns dpth montg
+ mxl 19.2
+ 1 17.18 37.00 27.01 1.0 0.5 0.000
+ 2 17.18 37.00 27.01 499.0 250.5 0.000
+ 3 16.30 37.00 27.22 4500.0 2750.0 -0.106
+ bot 5000.0
+
+model starts at day 0.0, goes to day 11.0 (steps 0 -- 1056)
+
+ tauewd: month,range = 12 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 12 0.00000E+00 0.00000E+00
+ forcing functions for month 12 written into slot 1
+ tauewd: month,range = 01 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 01 0.00000E+00 0.00000E+00
+ forcing functions for month 1 written into slot 2
+ tauewd: month,range = 02 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 02 0.00000E+00 0.00000E+00
+ forcing functions for month 2 written into slot 3
+ tauewd: month,range = 03 -1.00000E-01 1.00000E-01
+ taunwd: month,range = 03 0.00000E+00 0.00000E+00
+ forcing functions for month 3 written into slot 4
+ rdrlax - month = 12 12
+ tem : month,layer,dens,range = 12 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 12 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 12 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 12 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 12 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 12 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 12 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 12 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 12 03 27.221 4.90300E+06 4.90300E+06
+rdrlax: pwall.2 ok; expected,input min depth = 1.00 1.00
+rdrlax: pwall.3 NOT ok; expected,input min depth = 2.00 500.00 (bad climatology?)
+rdrlax: continuing because file ./relax.weird exists (ignore the "bad" climatology)
+ relaxation fields for month 12 written into slot 1
+ rdrlax - month = 1 1
+ tem : month,layer,dens,range = 01 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 01 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 01 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 01 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 01 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 01 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 01 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 01 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 1 written into slot 2
+ rdrlax - month = 2 2
+ tem : month,layer,dens,range = 02 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 02 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 02 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 02 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 02 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 02 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 02 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 02 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 02 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 2 written into slot 3
+ rdrlax - month = 3 3
+ tem : month,layer,dens,range = 03 01 27.010 1.71823E+01 1.71823E+01
+ tem : month,layer,dens,range = 03 02 27.010 1.71808E+01 1.71808E+01
+ tem : month,layer,dens,range = 03 03 27.221 1.63001E+01 1.63001E+01
+ sal : month,layer,dens,range = 03 01 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 03 02 27.010 3.70000E+01 3.70000E+01
+ sal : month,layer,dens,range = 03 03 27.221 3.70000E+01 3.70000E+01
+ int : month,layer,dens,range = 03 01 27.010 0.00000E+00 0.00000E+00
+ int : month,layer,dens,range = 03 02 27.010 9.80600E+03 9.80600E+03
+ int : month,layer,dens,range = 03 03 27.221 4.90300E+06 4.90300E+06
+ relaxation fields for month 3 written into slot 4
+
+
+ timer statistics
+ ------------------
+
+ total calls = 1 time = 0.05490 time/call = 0.05490000
+
+
+
+ 1 (0001/016 00) mean SSH (mm): 0.00 (-4.9E-05 to -4.9E-05)
+ 1 (0001/016 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 1 (0001/016 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 1 (0001/016 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 1 (0001/016 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 1 (0001/016 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 1 (0001/016 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 1 (0001/016 00) region-wide mean Kin. Energy: 0.0046712813
+ 1 (0001/016 00) region-wide mean Temperature: 16.3881703000
+ 1 (0001/016 00) region-wide mean Salinity: 37.0000000000
+ 1 (0001/016 00) region-wide mean Density Dev: 0.1898957149
+ 96 1 min/max of s after advection: 37.000 37.000 (range: 1.28E-13)
+ 96 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 96 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 96 (0001/017 00) mean SSH (mm): 0.00 (-5.2E+00 to 4.7E+00)
+ 96 (0001/017 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 96 (0001/017 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 96 (0001/017 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 96 (0001/017 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 96 (0001/017 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 96 (0001/017 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 96 (0001/017 00) region-wide mean Kin. Energy: 4.1432653972
+ 96 (0001/017 00) region-wide mean Temperature: 16.3881703000
+ 96 (0001/017 00) region-wide mean Salinity: 37.0000000000
+ 96 (0001/017 00) region-wide mean Density Dev: 0.1898957164
+ step 96 day 1.00 -- archiving completed --
+ 192 1 min/max of s after advection: 37.000 37.000 (range: 1.63E-13)
+ 192 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 192 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 192 (0001/018 00) mean SSH (mm): 0.00 (-1.0E+01 to 9.3E+00)
+ 192 (0001/018 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 192 (0001/018 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 192 (0001/018 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 192 (0001/018 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 192 (0001/018 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 192 (0001/018 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 192 (0001/018 00) region-wide mean Kin. Energy: 13.4001969478
+ 192 (0001/018 00) region-wide mean Temperature: 16.3881703000
+ 192 (0001/018 00) region-wide mean Salinity: 37.0000000000
+ 192 (0001/018 00) region-wide mean Density Dev: 0.1898957164
+ step 192 day 2.00 -- archiving completed --
+ 288 1 min/max of s after advection: 37.000 37.000 (range: 1.85E-13)
+ 288 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 288 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 288 (0001/019 00) mean SSH (mm): 0.00 (-1.6E+01 to 1.4E+01)
+ 288 (0001/019 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 288 (0001/019 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 288 (0001/019 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 288 (0001/019 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 288 (0001/019 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 288 (0001/019 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 288 (0001/019 00) region-wide mean Kin. Energy: 28.1775391248
+ 288 (0001/019 00) region-wide mean Temperature: 16.3881702999
+ 288 (0001/019 00) region-wide mean Salinity: 37.0000000000
+ 288 (0001/019 00) region-wide mean Density Dev: 0.1898957164
+ step 288 day 3.00 -- archiving completed --
+ 384 1 min/max of s after advection: 37.000 37.000 (range: 1.92E-13)
+ 384 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 384 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 384 (0001/020 00) mean SSH (mm): 0.00 (-2.1E+01 to 1.9E+01)
+ 384 (0001/020 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 384 (0001/020 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 384 (0001/020 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 384 (0001/020 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 384 (0001/020 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 384 (0001/020 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 384 (0001/020 00) region-wide mean Kin. Energy: 48.4792190514
+ 384 (0001/020 00) region-wide mean Temperature: 16.3881702999
+ 384 (0001/020 00) region-wide mean Salinity: 37.0000000000
+ 384 (0001/020 00) region-wide mean Density Dev: 0.1898957164
+ step 384 day 4.00 -- archiving completed --
+ 480 1 min/max of s after advection: 37.000 37.000 (range: 1.99E-13)
+ 480 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 480 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 480 (0001/021 00) mean SSH (mm): 0.00 (-2.6E+01 to 2.3E+01)
+ 480 (0001/021 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 480 (0001/021 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 480 (0001/021 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 480 (0001/021 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 480 (0001/021 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 480 (0001/021 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 480 (0001/021 00) region-wide mean Kin. Energy: 74.1010609419
+ 480 (0001/021 00) region-wide mean Temperature: 16.3881702998
+ 480 (0001/021 00) region-wide mean Salinity: 37.0000000000
+ 480 (0001/021 00) region-wide mean Density Dev: 0.1898957164
+ step 480 day 5.00 -- archiving completed --
+ 576 1 min/max of s after advection: 37.000 37.000 (range: 2.20E-13)
+ 576 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 576 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 576 (0001/022 00) mean SSH (mm): 0.00 (-3.1E+01 to 2.8E+01)
+ 576 (0001/022 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 576 (0001/022 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 576 (0001/022 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 576 (0001/022 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 576 (0001/022 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 576 (0001/022 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 576 (0001/022 00) region-wide mean Kin. Energy: 103.6767617399
+ 576 (0001/022 00) region-wide mean Temperature: 16.3881702998
+ 576 (0001/022 00) region-wide mean Salinity: 37.0000000000
+ 576 (0001/022 00) region-wide mean Density Dev: 0.1898957164
+ step 576 day 6.00 -- archiving completed --
+ 672 1 min/max of s after advection: 37.000 37.000 (range: 2.34E-13)
+ 672 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 672 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 672 (0001/023 00) mean SSH (mm): 0.00 (-3.7E+01 to 3.2E+01)
+ 672 (0001/023 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 672 (0001/023 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 672 (0001/023 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 672 (0001/023 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 672 (0001/023 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 672 (0001/023 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 672 (0001/023 00) region-wide mean Kin. Energy: 137.1932841362
+ 672 (0001/023 00) region-wide mean Temperature: 16.3881702997
+ 672 (0001/023 00) region-wide mean Salinity: 37.0000000000
+ 672 (0001/023 00) region-wide mean Density Dev: 0.1898957164
+ step 672 day 7.00 -- archiving completed --
+ 768 1 min/max of s after advection: 37.000 37.000 (range: 2.42E-13)
+ 768 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 768 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 768 (0001/024 00) mean SSH (mm): 0.00 (-4.2E+01 to 3.7E+01)
+ 768 (0001/024 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 768 (0001/024 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 768 (0001/024 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 768 (0001/024 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 768 (0001/024 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 768 (0001/024 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 768 (0001/024 00) region-wide mean Kin. Energy: 174.0607178422
+ 768 (0001/024 00) region-wide mean Temperature: 16.3881702996
+ 768 (0001/024 00) region-wide mean Salinity: 37.0000000000
+ 768 (0001/024 00) region-wide mean Density Dev: 0.1898957165
+ step 768 day 8.00 -- archiving completed --
+ 864 1 min/max of s after advection: 37.000 37.000 (range: 2.77E-13)
+ 864 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 864 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 864 (0001/025 00) mean SSH (mm): 0.00 (-4.7E+01 to 4.1E+01)
+ 864 (0001/025 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 864 (0001/025 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 864 (0001/025 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 864 (0001/025 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 864 (0001/025 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 864 (0001/025 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 864 (0001/025 00) region-wide mean Kin. Energy: 213.4808880508
+ 864 (0001/025 00) region-wide mean Temperature: 16.3881702995
+ 864 (0001/025 00) region-wide mean Salinity: 37.0000000000
+ 864 (0001/025 00) region-wide mean Density Dev: 0.1898957165
+ step 864 day 9.00 -- archiving completed --
+ 960 1 min/max of s after advection: 37.000 37.000 (range: 2.77E-13)
+ 960 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 960 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 960 (0001/026 00) mean SSH (mm): 0.00 (-5.2E+01 to 4.5E+01)
+ 960 (0001/026 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 960 (0001/026 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 960 (0001/026 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 960 (0001/026 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 960 (0001/026 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 960 (0001/026 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 960 (0001/026 00) region-wide mean Kin. Energy: 255.1227171568
+ 960 (0001/026 00) region-wide mean Temperature: 16.3881702995
+ 960 (0001/026 00) region-wide mean Salinity: 37.0000000000
+ 960 (0001/026 00) region-wide mean Density Dev: 0.1898957165
+ time step 960 y e a r 0001 d a y 026 h o u r 00
+ creating a new backup restart file
+ restart created at model day 10.000
+ step 960 day 10.00 -- archiving completed --
+ 1056 1 min/max of s after advection: 37.000 37.000 (range: 1.49E-13)
+ 1056 2 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 1056 3 min/max of s after advection: 37.000 37.000 (range: 0.00E+00)
+ 1056 (0001/027 00) mean SSH (mm): 0.00 (-5.6E+01 to 4.9E+01)
+ 1056 (0001/027 00) mean mixl thk. (m): 19.20 temp: 17.182 saln: 37.000
+ 1056 (0001/027 00) mean surf thk. (m): 1.00 sst: 17.182 sss: 37.000
+ 1056 (0001/027 00) mean clim thk. (m): 19.20 sst: 17.182 sss: 37.000
+ 1056 (0001/027 00) mean L 1 thk. (m): 1.00 temp: 17.182 saln: 37.000
+ 1056 (0001/027 00) mean L 2 thk. (m): 498.89 temp: 17.181 saln: 37.000
+ 1056 (0001/027 00) mean L 3 thk. (m): 4500.11 temp: 16.300 saln: 37.000
+ 1056 (0001/027 00) region-wide mean Kin. Energy: 298.0234395822
+ 1056 (0001/027 00) region-wide mean Temperature: 16.3881704135
+ 1056 (0001/027 00) region-wide mean Salinity: 37.0000000000
+ 1056 (0001/027 00) region-wide mean Density Dev: 0.1898956897
+ northward heat flux (petawatts):
+ 0.000 0.000 0.006 0.010 0.012 0.012 0.012 0.011 0.009 0.007 0.004
+ 0.002 0.001 0.001 0.000 0.000 0.001 0.001 0.001 0.002 0.002 0.001
+ 0.001 0.000 -0.001 -0.001 -0.002 -0.002 -0.002 -0.002 -0.002 -0.002 -0.002
+ -0.003 -0.004 -0.005 -0.007 -0.008 -0.009 -0.010 -0.010 -0.009 -0.009 -0.007
+ -0.006 -0.005 -0.004 -0.004 -0.004 -0.004 -0.005 -0.007 -0.008 -0.009 -0.010
+ -0.010 -0.010 -0.010 -0.009 -0.008 -0.006 -0.005 -0.004 -0.003 -0.003 -0.003
+ -0.003 -0.003 -0.004 -0.004 -0.004 -0.004 -0.003 -0.003 -0.002 -0.001 -0.001
+ -0.001 0.000 0.000 0.000 0.000 0.000 0.001 0.001 0.002 0.003 0.004
+ 0.004 0.005 0.005 0.005 0.005 0.004 0.002 0.002 0.001 0.001 0.002
+ 0.001
+ time step 1056 y e a r 0001 d a y 027 h o u r 00
+ creating a new standard restart file
+ restart created & closed at model day 11.000
+ step 1056 day 11.00 -- archiving completed --
+
+
+ timer statistics
+ ------------------
+
+ cnuity calls = 1056 time = 5.52540 time/call = 0.00523239
+ tsadvc calls = 1056 time = 9.11310 time/call = 0.00862983
+ momtum calls = 1056 time = 20.12560 time/call = 0.01905833
+ barotp calls = 1056 time = 13.51720 time/call = 0.01280038
+ thermf calls = 1056 time = 0.10300 time/call = 0.00009754
+ ic**** calls = 1056 time = 0.18430 time/call = 0.00017453
+ mx**** calls = 1056 time = 0.00000 time/call = 0.00000000
+ conv** calls = 1056 time = 4.29240 time/call = 0.00406477
+ diapf* calls = 1056 time = 0.00020 time/call = 0.00000019
+ hybgen calls = 1056 time = 12.58270 time/call = 0.01191544
+ restrt calls = 2 time = 0.01360 time/call = 0.00680000
+ overtn calls = 1 time = 0.00140 time/call = 0.00140000
+ archiv calls = 11 time = 0.04990 time/call = 0.00453636
+ incupd calls = 1056 time = 0.00000 time/call = 0.00000000
+ total calls = 1 time = 65.85210 time/call = 65.85210000
+
+
+
+ **************************************************
+ (normal)
+ **************************************************
+You are Done !
diff --git a/expt_01.0/limits b/expt_01.0/limits
new file mode 100755
index 0000000..2a043ba
--- /dev/null
+++ b/expt_01.0/limits
@@ -0,0 +1 @@
+-111 360
diff --git a/expt_01.0/script_exe.com b/expt_01.0/script_exe.com
new file mode 100755
index 0000000..71b6b68
--- /dev/null
+++ b/expt_01.0/script_exe.com
@@ -0,0 +1,92 @@
+#!/bin/csh
+
+set echo
+## CONFIGURATION BOX 20kmx20km
+setenv R BB86 ## config name
+setenv T 01 ## topography version (see name of your file..)
+setenv E 010 ## experiment number (ex: 010)
+setenv E1 `echo ${E} | awk '{printf("%04.1f", $1*0.1)}'` ## (ex: 01.0)
+
+## time to run
+setenv day1 111
+setenv day2 360
+## restart run?
+setenv restart - ## - means no restart (+ means restart)
+
+## get all the files in the same directory
+# P : path where you are going to launch the run
+# D : path where you are actually running
+setenv P /Net/yucatan/abozec/BB86_PACKAGE/expt_${E1}/
+setenv D ${P}/data
+
+mkdir -p ${D}
+
+## get the grid and depth files
+touch ${D}/regional.grid.[ab] ${D}/regional.depth.[ab]
+/bin/rm ${D}/regional.grid.[ab] ${D}/regional.depth.[ab]
+
+/bin/cp ${P}/../topo/regional.grid.${R}.a ${D}/regional.grid.a
+/bin/cp ${P}/../topo/regional.grid.${R}.b ${D}/regional.grid.b
+/bin/cp ${P}/../topo/depth_${R}_${T}.a ${D}/regional.depth.a
+/bin/cp ${P}/../topo/depth_${R}_${T}.b ${D}/regional.depth.b
+
+## get the initial conditions
+touch ${D}/relax.temp.[ab] ${D}/relax.saln.[ab] ${D}/relax.intf.[ab]
+/bin/rm ${D}/relax.temp.[ab] ${D}/relax.saln.[ab] ${D}/relax.intf.[ab]
+
+#potential temperature
+/bin/cp ${P}/../relax/${E}/relax_tem_${R}.a ${D}/relax.temp.a
+/bin/cp ${P}/../relax/${E}/relax_tem_${R}.b ${D}/relax.temp.b
+
+#salinity
+/bin/cp ${P}/../relax/${E}/relax_sal_${R}.a ${D}/relax.saln.a
+/bin/cp ${P}/../relax/${E}/relax_sal_${R}.b ${D}/relax.saln.b
+
+#interface depth
+/bin/cp ${P}/../relax/${E}/relax_int_${R}.a ${D}/relax.intf.a
+/bin/cp ${P}/../relax/${E}/relax_int_${R}.b ${D}/relax.intf.b
+
+## to not get into trouble with some flags ..
+touch ${D}/relax.weird
+
+## get the forcing
+touch ${D}/forcing.tauewd.[ab] ${D}/forcing.taunwd.[ab]
+/bin/rm ${D}/forcing.tauewd.[ab] ${D}/forcing.taunwd.[ab]
+
+#eastward windstress
+/bin/cp ${P}/../force/forcing.tauewd.${R}.a ${D}/forcing.tauewd.a
+/bin/cp ${P}/../force/forcing.tauewd.${R}.b ${D}/forcing.tauewd.b
+
+#northward windstress
+/bin/cp ${P}/../force/forcing.taunwd.${R}.a ${D}/forcing.taunwd.a
+/bin/cp ${P}/../force/forcing.taunwd.${R}.b ${D}/forcing.taunwd.b
+
+## get the executable
+/bin/cp ${P}/../src_2.2.18_3_one/hycom_gfortran ${D}/hycom
+
+## get rid of the old files
+/bin/rm ${D}/restart_out* ${D}/ovrtn_out
+
+
+## Parameter file
+/bin/cp ${P}/blkdat.input ${D}/blkdat.input
+
+## length of the run
+cat > limits <0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature (degC); s: salinity (psu);
+c --- r: potential density (sigma); prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.406,1.e7,1) = 0.11827355
+c --- example: kappaf(4.5,34.5,36.406,1.e7,2) = 0.03204273
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.05106071
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.2, t-toff(kkf) ), !Hallberg,T-only: -1.8,0.9
+ & max(-3.0,min(1.5, s-soff(kkf))), !Hallberg,S-only: -4.2,2.1
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c> Mar 2009 - modified limits in kappaf
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+16 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+16
new file mode 100755
index 0000000..f715d8e
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+16
@@ -0,0 +1,156 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=1 !7-term sigma-0
+csig2& sigver=2 !7-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1=-1.36471E-01, !const. coefficent
+ & c2= 4.68181E-02, !T coefficent
+ & c3= 8.07004E-01, ! S coefficent
+ & c4=-7.45353E-03, !T^2 coefficent
+ & c5=-2.94418E-03, !T S coefficent
+ & c6= 3.43570E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.48658E-05, !T^2S coefficent
+ & pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+csig2 real, parameter ::
+csig2& c1= 9.77093E+00, !const. coefficent
+csig2& c2=-2.26493E-02, !T coefficent
+csig2& c3= 7.89879E-01, ! S coefficent
+csig2& c4=-6.43205E-03, !T^2 coefficent
+csig2& c5=-2.62983E-03, !T S coefficent
+csig2& c6= 2.75835E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.15235E-05, !T^2S coefficent
+csig2& pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,1.e7,1) = 0.11411243
+c --- example: kappaf(4.5,34.5,1.e7,2) = 0.03091669
+c --- example: kappaf(4.5,34.5,1.e7,3) = -0.06423524
+ kappaf1(t,s,prs,kkf)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*(qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) )
+ kappaf(t,s,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+17 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+17
new file mode 100755
index 0000000..2b097aa
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0.h+17
@@ -0,0 +1,163 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=1 !7-term sigma-0
+csig2& sigver=2 !7-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1=-1.36471E-01, !const. coefficent
+ & c2= 4.68181E-02, !T coefficent
+ & c3= 8.07004E-01, ! S coefficent
+ & c4=-7.45353E-03, !T^2 coefficent
+ & c5=-2.94418E-03, !T S coefficent
+ & c6= 3.43570E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.48658E-05, !T^2S coefficent
+ & pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+csig2 real, parameter ::
+csig2& c1= 9.77093E+00, !const. coefficent
+csig2& c2=-2.26493E-02, !T coefficent
+csig2& c3= 7.89879E-01, ! S coefficent
+csig2& c4=-6.43205E-03, !T^2 coefficent
+csig2& c5=-2.62983E-03, !T S coefficent
+csig2& c6= 2.75835E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.15235E-05, !T^2S coefficent
+csig2& pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature (degC); s: salinity (psu);
+c --- r: potential density (sigma); prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.406,1.e7,1) = 0.11827355
+c --- example: kappaf(4.5,34.5,36.406,1.e7,2) = 0.03204273
+c --- example: kappaf(4.5,34.5,36.406,1.e7,3) = -0.06657165
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h
new file mode 100755
index 0000000..8ae7906
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h
@@ -0,0 +1,180 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=3 !9-term sigma-0
+csig2& sigver=4 !9-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+ real, parameter ::
+ & c1=-4.311829E-02, !const. coefficent
+ & c2= 5.429948E-02, !T coefficent
+ & c3= 8.011774E-01, ! S coefficent
+ & c4=-7.641336E-03, !T^2 coefficent
+ & c5=-3.258442E-03, !T S coefficent
+ & c6= 3.757643E-05, !T^3 coefficent
+ & rc6=1.0/c6,
+ & c7= 3.630361E-05, !T^2S coefficent
+ & c8= 8.675546E-05, ! S^2 coefficent
+ & c9= 3.995086E-06, !T S^2 coefficent
+ & pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+csig2 real, parameter ::
+csig2& c1= 9.903308E+00, !const. coefficent
+csig2& c2=-1.618075E-02, !T coefficent
+csig2& c3= 7.819166E-01, ! S coefficent
+csig2& c4=-6.593939E-03, !T^2 coefficent
+csig2& c5=-2.896464E-03, !T S coefficent
+csig2& c6= 3.038697E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.266933E-05, !T^2S coefficent
+csig2& c8= 1.180109E-04, ! S^2 coefficent
+csig2& c9= 3.399511E-06, !T S^2 coefficent
+csig2& pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.408,1.e7,1) = 0.11827378
+c --- example: kappaf(4.5,34.5,36.408,1.e7,2) = 0.03204280
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.05106071
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.2, t-toff(kkf) ), !Hallberg,T-only: -1.8,0.9
+ & max(-3.0,min(1.5, s-soff(kkf))), !Hallberg,S-only: -4.2,2.1
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c> Mar 2009 - modified limits in kappaf
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+16 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+16
new file mode 100755
index 0000000..7eaa741
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+16
@@ -0,0 +1,173 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=3 !9-term sigma-0
+csig2& sigver=4 !9-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+ real, parameter ::
+ & c1=-4.311829E-02, !const. coefficent
+ & c2= 5.429948E-02, !T coefficent
+ & c3= 8.011774E-01, ! S coefficent
+ & c4=-7.641336E-03, !T^2 coefficent
+ & c5=-3.258442E-03, !T S coefficent
+ & c6= 3.757643E-05, !T^3 coefficent
+ & rc6=1.0/c6,
+ & c7= 3.630361E-05, !T^2S coefficent
+ & c8= 8.675546E-05, ! S^2 coefficent
+ & c9= 3.995086E-06, !T S^2 coefficent
+ & pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+csig2 real, parameter ::
+csig2& c1= 9.903308E+00, !const. coefficent
+csig2& c2=-1.618075E-02, !T coefficent
+csig2& c3= 7.819166E-01, ! S coefficent
+csig2& c4=-6.593939E-03, !T^2 coefficent
+csig2& c5=-2.896464E-03, !T S coefficent
+csig2& c6= 3.038697E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.266933E-05, !T^2S coefficent
+csig2& c8= 1.180109E-04, ! S^2 coefficent
+csig2& c9= 3.399511E-06, !T S^2 coefficent
+csig2& pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,1.e7,1) = 0.11411243
+c --- example: kappaf(4.5,34.5,1.e7,2) = 0.03091669
+c --- example: kappaf(4.5,34.5,1.e7,3) = -0.06423524
+ kappaf1(t,s,prs,kkf)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*(qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) )
+ kappaf(t,s,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+17 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+17
new file mode 100755
index 0000000..54a024b
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA0_9term.h+17
@@ -0,0 +1,179 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=3 !9-term sigma-0
+csig2& sigver=4 !9-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+ real, parameter ::
+ & c1=-4.311829E-02, !const. coefficent
+ & c2= 5.429948E-02, !T coefficent
+ & c3= 8.011774E-01, ! S coefficent
+ & c4=-7.641336E-03, !T^2 coefficent
+ & c5=-3.258442E-03, !T S coefficent
+ & c6= 3.757643E-05, !T^3 coefficent
+ & rc6=1.0/c6,
+ & c7= 3.630361E-05, !T^2S coefficent
+ & c8= 8.675546E-05, ! S^2 coefficent
+ & c9= 3.995086E-06, !T S^2 coefficent
+ & pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+csig2 real, parameter ::
+csig2& c1= 9.903308E+00, !const. coefficent
+csig2& c2=-1.618075E-02, !T coefficent
+csig2& c3= 7.819166E-01, ! S coefficent
+csig2& c4=-6.593939E-03, !T^2 coefficent
+csig2& c5=-2.896464E-03, !T S coefficent
+csig2& c6= 3.038697E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.266933E-05, !T^2S coefficent
+csig2& c8= 1.180109E-04, ! S^2 coefficent
+csig2& c9= 3.399511E-06, !T S^2 coefficent
+csig2& pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.408,1.e7,1) = 0.11827378
+c --- example: kappaf(4.5,34.5,36.408,1.e7,2) = 0.03204280
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.06657178
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h
new file mode 100755
index 0000000..0920944
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h
@@ -0,0 +1,164 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=2 !7-term sigma-2
+csig0& sigver=1 !7-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+csig0 real, parameter ::
+csig0& c1=-1.36471E-01, !const. coefficent
+csig0& c2= 4.68181E-02, !T coefficent
+csig0& c3= 8.07004E-01, ! S coefficent
+csig0& c4=-7.45353E-03, !T^2 coefficent
+csig0& c5=-2.94418E-03, !T S coefficent
+csig0& c6= 3.43570E-05, !T^3 coefficent
+csig0& rc6= 1.0/c6,
+csig0& c7= 3.48658E-05, !T^2S coefficent
+csig0& pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1= 9.77093E+00, !const. coefficent
+ & c2=-2.26493E-02, !T coefficent
+ & c3= 7.89879E-01, ! S coefficent
+ & c4=-6.43205E-03, !T^2 coefficent
+ & c5=-2.62983E-03, !T S coefficent
+ & c6= 2.75835E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.15235E-05, !T^2S coefficent
+ & pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature (degC); s: salinity (psu);
+c --- r: potential density (sigma); prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.406,1.e7,1) = 0.11827355
+c --- example: kappaf(4.5,34.5,36.406,1.e7,2) = 0.03204273
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.05106071
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.2, t-toff(kkf) ), !Hallberg,T-only: -1.8,0.9
+ & max(-3.0,min(1.5, s-soff(kkf))), !Hallberg,S-only: -4.2,2.1
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c> Mar 2009 - modified limits in kappaf
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+16 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+16
new file mode 100755
index 0000000..727d91e
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+16
@@ -0,0 +1,156 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=2 !7-term sigma-2
+csig0& sigver=1 !7-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+csig0 real, parameter ::
+csig0& c1=-1.36471E-01, !const. coefficent
+csig0& c2= 4.68181E-02, !T coefficent
+csig0& c3= 8.07004E-01, ! S coefficent
+csig0& c4=-7.45353E-03, !T^2 coefficent
+csig0& c5=-2.94418E-03, !T S coefficent
+csig0& c6= 3.43570E-05, !T^3 coefficent
+csig0& rc6= 1.0/c6,
+csig0& c7= 3.48658E-05, !T^2S coefficent
+csig0& pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1= 9.77093E+00, !const. coefficent
+ & c2=-2.26493E-02, !T coefficent
+ & c3= 7.89879E-01, ! S coefficent
+ & c4=-6.43205E-03, !T^2 coefficent
+ & c5=-2.62983E-03, !T S coefficent
+ & c6= 2.75835E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.15235E-05, !T^2S coefficent
+ & pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,1.e7,1) = 0.11411243
+c --- example: kappaf(4.5,34.5,1.e7,2) = 0.03091669
+c --- example: kappaf(4.5,34.5,1.e7,3) = -0.06423524
+ kappaf1(t,s,prs,kkf)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*(qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) )
+ kappaf(t,s,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+17 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+17
new file mode 100755
index 0000000..c24bbac
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2.h+17
@@ -0,0 +1,163 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=2 !7-term sigma-2
+csig0& sigver=1 !7-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+csig0 real, parameter ::
+csig0& c1=-1.36471E-01, !const. coefficent
+csig0& c2= 4.68181E-02, !T coefficent
+csig0& c3= 8.07004E-01, ! S coefficent
+csig0& c4=-7.45353E-03, !T^2 coefficent
+csig0& c5=-2.94418E-03, !T S coefficent
+csig0& c6= 3.43570E-05, !T^3 coefficent
+csig0& rc6= 1.0/c6,
+csig0& c7= 3.48658E-05, !T^2S coefficent
+csig0& pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1= 9.77093E+00, !const. coefficent
+ & c2=-2.26493E-02, !T coefficent
+ & c3= 7.89879E-01, ! S coefficent
+ & c4=-6.43205E-03, !T^2 coefficent
+ & c5=-2.62983E-03, !T S coefficent
+ & c6= 2.75835E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.15235E-05, !T^2S coefficent
+ & pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature (degC); s: salinity (psu);
+c --- r: potential density (sigma); prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.406,1.e7,1) = 0.11827355
+c --- example: kappaf(4.5,34.5,36.406,1.e7,2) = 0.03204273
+c --- example: kappaf(4.5,34.5,36.406,1.e7,3) = -0.06657165
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h
new file mode 100755
index 0000000..d6144b5
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h
@@ -0,0 +1,180 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=4 !9-term sigma-2
+csig0& sigver=3 !9-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+csig0 real, parameter ::
+csig0& c1=-4.311829E-02, !const. coefficent
+csig0& c2= 5.429948E-02, !T coefficent
+csig0& c3= 8.011774E-01, ! S coefficent
+csig0& c4=-7.641336E-03, !T^2 coefficent
+csig0& c5=-3.258442E-03, !T S coefficent
+csig0& c6= 3.757643E-05, !T^3 coefficent
+csig0& rc6=1.0/c6,
+csig0& c7= 3.630361E-05, !T^2S coefficent
+csig0& c8= 8.675546E-05, ! S^2 coefficent
+csig0& c9= 3.995086E-06, !T S^2 coefficent
+csig0& pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+ real, parameter ::
+ & c1= 9.903308E+00, !const. coefficent
+ & c2=-1.618075E-02, !T coefficent
+ & c3= 7.819166E-01, ! S coefficent
+ & c4=-6.593939E-03, !T^2 coefficent
+ & c5=-2.896464E-03, !T S coefficent
+ & c6= 3.038697E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.266933E-05, !T^2S coefficent
+ & c8= 1.180109E-04, ! S^2 coefficent
+ & c9= 3.399511E-06, !T S^2 coefficent
+ & pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.408,1.e7,1) = 0.11827378
+c --- example: kappaf(4.5,34.5,36.408,1.e7,2) = 0.03204280
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.05106071
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.2, t-toff(kkf) ), !Hallberg,T-only: -1.8,0.9
+ & max(-3.0,min(1.5, s-soff(kkf))), !Hallberg,S-only: -4.2,2.1
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c> Mar 2009 - modified limits in kappaf
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+16 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+16
new file mode 100755
index 0000000..f0e82ef
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+16
@@ -0,0 +1,173 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=4 !9-term sigma-2
+csig0& sigver=3 !9-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+csig0 real, parameter ::
+csig0& c1=-4.311829E-02, !const. coefficent
+csig0& c2= 5.429948E-02, !T coefficent
+csig0& c3= 8.011774E-01, ! S coefficent
+csig0& c4=-7.641336E-03, !T^2 coefficent
+csig0& c5=-3.258442E-03, !T S coefficent
+csig0& c6= 3.757643E-05, !T^3 coefficent
+csig0& rc6=1.0/c6,
+csig0& c7= 3.630361E-05, !T^2S coefficent
+csig0& c8= 8.675546E-05, ! S^2 coefficent
+csig0& c9= 3.995086E-06, !T S^2 coefficent
+csig0& pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+ real, parameter ::
+ & c1= 9.903308E+00, !const. coefficent
+ & c2=-1.618075E-02, !T coefficent
+ & c3= 7.819166E-01, ! S coefficent
+ & c4=-6.593939E-03, !T^2 coefficent
+ & c5=-2.896464E-03, !T S coefficent
+ & c6= 3.038697E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.266933E-05, !T^2S coefficent
+ & c8= 1.180109E-04, ! S^2 coefficent
+ & c9= 3.399511E-06, !T S^2 coefficent
+ & pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,1.e7,1) = 0.11411243
+c --- example: kappaf(4.5,34.5,1.e7,2) = 0.03091669
+c --- example: kappaf(4.5,34.5,1.e7,3) = -0.06423524
+ kappaf1(t,s,prs,kkf)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*(qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) )
+ kappaf(t,s,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+17 b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+17
new file mode 100755
index 0000000..c4fd2cf
--- /dev/null
+++ b/src_2.2.18_3_one/ALT_CODE/stmt_fns_SIGMA2_9term.h+17
@@ -0,0 +1,179 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=4 !9-term sigma-2
+csig0& sigver=3 !9-term sigma-0
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real sofsig_a,sofsig_b,sofsig_c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (9-term polynomial fit to T:[-2:30],S:[18:38])
+c
+c --- coefficients for sigma-0.
+csig0 real, parameter ::
+csig0& c1=-4.311829E-02, !const. coefficent
+csig0& c2= 5.429948E-02, !T coefficent
+csig0& c3= 8.011774E-01, ! S coefficent
+csig0& c4=-7.641336E-03, !T^2 coefficent
+csig0& c5=-3.258442E-03, !T S coefficent
+csig0& c6= 3.757643E-05, !T^3 coefficent
+csig0& rc6=1.0/c6,
+csig0& c7= 3.630361E-05, !T^2S coefficent
+csig0& c8= 8.675546E-05, ! S^2 coefficent
+csig0& c9= 3.995086E-06, !T S^2 coefficent
+csig0& pref= 0.0 ! reference pressure
+c --- coefficients for sigma-2.
+ real, parameter ::
+ & c1= 9.903308E+00, !const. coefficent
+ & c2=-1.618075E-02, !T coefficent
+ & c3= 7.819166E-01, ! S coefficent
+ & c4=-6.593939E-03, !T^2 coefficent
+ & c5=-2.896464E-03, !T S coefficent
+ & c6= 3.038697E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.266933E-05, !T^2S coefficent
+ & c8= 1.180109E-04, ! S^2 coefficent
+ & c9= 3.399511E-06, !T S^2 coefficent
+ & pref= 2000.0e4 ! reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+s*(c3+s*c8)-r)*rc6 !constant coefficient
+ a1(s) =(c2+s*(c5+s*c9) )*rc6 !linear coefficient
+ a2(s) =(c4+s* c7 )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s) =a3rd* a1(s) -(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (polynomial fit that is cubic in T and quadratic in S)
+c
+ sig(t,s)=(c1+s*(c3+s* c8)+
+ & t*(c2+s*(c5+s*c9)+t*(c4+s*c7+t*c6)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+s*(c5+s*c9)+2.0*t*(c4+s*c7+1.5*t*c6))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7)+2.0*s* c8)
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+c --- find a quadratic polynominal root of a*s**2+b*s+c=0
+ sofsig_a(r,t)=(c8+t* c9) !quadratic coefficient
+ sofsig_b(r,t)=(c3+t*(c5+t* c7)) !linear coefficient
+ sofsig_c(r,t)=(c1+t*(c2+t*(c4+t*c6))-r) !constant coefficient
+ sofsig(r,t)=(2.0*sofsig_c(r,t))/
+ & (-sofsig_b(r,t)
+ & -sign(sqrt(sofsig_b(r,t)**2-
+ & 4.0*sofsig_a(r,t)*sofsig_c(r,t)),
+ & sofsig_b(r,t)))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature; s: psu; prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.408,1.e7,1) = 0.11827378
+c --- example: kappaf(4.5,34.5,36.408,1.e7,2) = 0.03204280
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.06657178
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.5, t-toff(kkf) ),
+ & max(-4.0,min(2.0, s-soff(kkf))),
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> Sep 2006 - 9-term polynominal fit to T:[-2:30],S:[18:38]
+c> May 2007 - added sigver
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/CPP.com b/src_2.2.18_3_one/CPP.com
new file mode 100755
index 0000000..c540af6
--- /dev/null
+++ b/src_2.2.18_3_one/CPP.com
@@ -0,0 +1,36 @@
+#!/bin/csh
+#
+set echo
+#
+# --- run HYCOM through CPP.
+#
+#!/bin/csh
+#
+set echo
+cd $cwd
+#
+# --- Usage: ./CPP.com >& CPP.log
+#
+# --- Build a source code set for this ARCH and TYPE only.
+# --- assumes dimensions.h is correct for $TYPE.
+#
+#setenv ARCH alphaL
+#setenv ARCH alpha
+#setenv ARCH intel
+#setenv ARCH o2k
+#setenv ARCH sp3GPFS
+#setenv ARCH sp3
+#setenv ARCH sun64
+#setenv ARCH sun
+#setenv ARCH t3e
+#
+setenv ARCH sp3GPFS
+#
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+#
+if (! -e ../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+else
+ make hycom ARCH=$ARCH TYPE=$TYPE
+endif
diff --git a/src_2.2.18_3_one/CPP.make b/src_2.2.18_3_one/CPP.make
new file mode 100755
index 0000000..847eed5
--- /dev/null
+++ b/src_2.2.18_3_one/CPP.make
@@ -0,0 +1,33 @@
+#
+# --- HYCOM 2.0 surce code makefile
+#
+# --- Tunable parameters in ../config/$(ARCH)_$(TYPE)
+#
+
+.SUFFIXES:
+.SUFFIXES: .c .F .f .o
+
+.F:
+ @echo "Must have an explicit rule for" $*
+.f:
+ @echo "Must have an explicit rule for" $*
+.c:
+ @echo "Must have an explicit rule for" $*
+
+include ../config/$(ARCH)_$(TYPE)
+
+.F.f:
+ $(RM) $<.f $<.C
+ sed -e 's? */// *?/ / /?g' -e 's? *// *?/ /?g' $< > $<.C
+ $(CPP) $(CPPFLAGS) $<.C | sed -e '/^ *$$/d' > $<.f
+ -\mv $<.f $*.f
+ $(RM) $<.C
+
+default: hycom
+
+machine.f: machine.F
+wtime.f: wtime.F
+
+mod_pipe.f: mod_pipe.F
+mod_xc.f: mod_xc.F mod_xc_sm.F mod_xc_mp.F
+mod_za.f: mod_za.F mod_za_sm.F mod_za_mp.F mod_za_mp1.F
diff --git a/src_2.2.18_3_one/Make.com b/src_2.2.18_3_one/Make.com
new file mode 100755
index 0000000..0b982f1
--- /dev/null
+++ b/src_2.2.18_3_one/Make.com
@@ -0,0 +1,70 @@
+#!/bin/csh
+#
+set echo
+cd $cwd
+#
+# --- Usage: ./Make.com >& Make.log
+#
+# --- make hycom with TYPE from this directory's name (src_*_$TYPE).
+# --- assumes dimensions.h is correct for $TYPE.
+#
+# --- set ARCH to the correct value for this machine.
+# --- ARCH that start with A are for ARCTIC patch regions
+#
+#setenv ARCH alphaL
+#setenv ARCH alpha
+#setenv ARCH amd64
+#setenv ARCH ia64-mpi2io
+#setenv ARCH intel
+#setenv ARCH o2k
+#setenv ARCH sp3
+#setenv ARCH sp4
+#setenv ARCH sp5
+#setenv ARCH sp6-nofl
+#setenv ARCH sun64
+#setenv ARCH sun
+#setenv ARCH t3e
+#setenv ARCH xt3-mpi2io
+#setenv ARCH xt4
+#setenv ARCH xt5
+#
+setenv ARCH intelIFC
+#setenv ARCH gfortran
+#
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+#
+if (! -e ../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+endif
+#
+# --- esmf needs additional environment variables.
+#
+if ($TYPE == "esmf") then
+ switch ($ARCH)
+ case 'sp4':
+ setenv BEI_HOME /site/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'o2k':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'xt3':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ default:
+ echo "TYPE = esmf needs BEI_HOME and ESMF_DIR"
+ exit (1)
+ endsw
+endif
+#
+# --- some machines require gmake
+#
+#gmake ARCH=$ARCH TYPE=$TYPE hycom
+make hycom ARCH=$ARCH TYPE=$TYPE
+#
+if ( $ARCH == "Asp5" || $ARCH == "sp5") then
+ ldedit -bdatapsize=64K -bstackpsize=64K hycom
+endif
diff --git a/src_2.2.18_3_one/Make_cice.com b/src_2.2.18_3_one/Make_cice.com
new file mode 100755
index 0000000..9c15baa
--- /dev/null
+++ b/src_2.2.18_3_one/Make_cice.com
@@ -0,0 +1,77 @@
+#!/bin/csh
+#
+set echo
+setenv HYCOM_DIR $cwd
+cd ${HYCOM_DIR}
+#
+# --- Usage: ./Make_cice.com >& Make_cice.log
+#
+# --- make cice (ESMF HYCOM component) with TYPE=cice.
+# --- this directory's name must be src_*_cice.
+# --- assumes dimensions.h is correct for TYPE=cice (i.e. for mpi).
+#
+# --- set ARCH to the correct value for this machine.
+# --- ARCH that start with A are for ARCTIC patch regions
+#
+#setenv ARCH alphaL
+#setenv ARCH alpha
+#setenv ARCH amd64
+#setenv ARCH intel
+#setenv ARCH o2k
+#setenv ARCH sp3
+#setenv ARCH sp4
+#setenv ARCH sun64
+#setenv ARCH sun
+#setenv ARCH t3e
+#setenv ARCH xt3
+#
+setenv ARCH sp4
+#
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+#
+if ($TYPE != "cice") then
+ echo "TYPE must be cice to invoke cice make target"
+ exit 1
+endif
+#
+if (! -e ../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+endif
+#
+# --- cice needs additional environment variables.
+#
+if ($TYPE == "cice") then
+ switch ($ARCH)
+ case 'sp4':
+ setenv BEI_HOME /site/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'o2k':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'xt3':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ default:
+ echo "TYPE = cice needs BEI_HOME and ESMF_DIR"
+ exit (1)
+ endsw
+endif
+#
+# --- make CICE component
+#
+setenv CICE_DIR ../cice
+cd ${CICE_DIR}
+./comp_ice_esmf | tee comp_ice_esmf.log
+#
+# --- make HYCOM component, and update hycom_cice
+#
+cd ${HYCOM_DIR}
+# --- force a relink, because CICE is not in the dependencies
+/bin/rm hycom_cice
+make ARCH=$ARCH TYPE=$TYPE hycom_cice
+# --- some machines require gmake
+#gmake ARCH=$ARCH TYPE=$TYPE hycom_cice
diff --git a/src_2.2.18_3_one/Make_esmf.com b/src_2.2.18_3_one/Make_esmf.com
new file mode 100755
index 0000000..a889254
--- /dev/null
+++ b/src_2.2.18_3_one/Make_esmf.com
@@ -0,0 +1,67 @@
+#!/bin/csh
+#
+set echo
+cd $cwd
+#
+# --- Usage: ./Make_esmf.com >& Make_esmf.log
+#
+# --- make esmf (ESMF HYCOM component) with TYPE=esmf.
+# --- this directory's name must be src_*_esmf.
+# --- assumes dimensions.h is correct for TYPE=esmf (i.e. for mpi).
+#
+# --- set ARCH to the correct value for this machine.
+# --- ARCH that start with A are for ARCTIC patch regions
+#
+#setenv ARCH alphaL
+#setenv ARCH alpha
+#setenv ARCH amd64
+#setenv ARCH intel
+#setenv ARCH o2k
+#setenv ARCH sp3
+#setenv ARCH sp4
+#setenv ARCH sp5
+#setenv ARCH sun64
+#setenv ARCH sun
+#setenv ARCH t3e
+#setenv ARCH xt3
+#
+setenv ARCH sp4
+#
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+#
+if ($TYPE != "esmf") then
+ echo "TYPE must be esmf to invoke esmf make target"
+ exit 1
+endif
+#
+if (! -e ../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+endif
+#
+# --- esmf needs additional environment variables.
+#
+if ($TYPE == "esmf") then
+ switch ($ARCH)
+ case 'sp4':
+ setenv BEI_HOME /site/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'o2k':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ case 'xt3':
+ setenv BEI_HOME /usr/local/usp/BEI
+ setenv ESMF_DIR ${BEI_HOME}/esmf/2.2.2r
+ breaksw
+ default:
+ echo "TYPE = esmf needs BEI_HOME and ESMF_DIR"
+ exit (1)
+ endsw
+endif
+#
+# --- some machines require gmake
+#
+#gmake ARCH=$ARCH TYPE=$TYPE esmf
+make ARCH=$ARCH TYPE=$TYPE esmf
diff --git a/src_2.2.18_3_one/Makefile b/src_2.2.18_3_one/Makefile
new file mode 100755
index 0000000..1a9c4c9
--- /dev/null
+++ b/src_2.2.18_3_one/Makefile
@@ -0,0 +1,107 @@
+#
+# --- HYCOM 2.2 makefile
+#
+# --- Stand-alone HYCOM, or HYCOM ESMF component, or HYCOM+CICE.
+#
+# --- Tunable parameters in ../config/$(ARCH)_$(TYPE)
+#
+
+.SUFFIXES:
+.SUFFIXES: .c .F .f .o
+
+.F:
+ @echo "Must have an explicit rule for" $*
+.f:
+ @echo "Must have an explicit rule for" $*
+.c:
+ @echo "Must have an explicit rule for" $*
+
+include ../config/$(ARCH)_$(TYPE)
+
+MODS = mod_dimensions.o mod_xc.o mod_za.o mod_pipe.o mod_incupd.o mod_floats.o mod_tides.o mod_mean.o mod_hycom.o
+
+OBJS = archiv.o barotp.o bigrid.o blkdat.o cnuity.o convec.o \
+ diapfl.o dpthuv.o dpudpv.o forfun.o geopar.o hybgen.o \
+ icloan.o inicon.o inigiss.o inikpp.o inimy.o latbdy.o \
+ matinv.o momtum.o mxkprf.o mxkrt.o mxkrtm.o mxpwp.o \
+ overtn.o poflat.o prtmsk.o psmoo.o restart.o \
+ thermf.o trcupd.o tsadvc.o \
+ machine.o wtime.o machi_c.o isnan.o
+
+hycom: $(MODS) $(OBJS) hycom.o
+ $(LD) $(LDFLAGS) -o hycom hycom.o $(MODS) $(OBJS) $(EXTRALIBS)
+
+esmf: $(MODS) $(OBJS)
+ @echo "--- ESMF hycom component has been built ---"
+
+hycom_cice: $(MODS) $(OBJS) mod_OICPL.o hycom_cice.o
+ $(LD) $(LDFLAGS) -o hycom_cice \
+ hycom_cice.o mod_OICPL.o \
+ $(MODS) $(OBJS) \
+ ${CICE_DIR}/esmf/compile/*.o \
+ $(EXTRALIBS)
+
+hycom.o: hycom.F mod_hycom.o
+hycom_cice.o: hycom_cice.F mod_hycom.o mod_OICPL.o
+
+archiv.o: archiv.f mod_xc.o common_blocks.h mod_za.o
+barotp.o: barotp.f mod_xc.o common_blocks.h mod_pipe.o \
+ mod_tides.o
+bigrid.o: bigrid.f mod_xc.o
+blkdat.o: blkdat.F mod_xc.o common_blocks.h stmt_fns.h mod_incupd.o \
+ mod_floats.o \
+ mod_tides.o
+cnuity.o: cnuity.f mod_xc.o common_blocks.h mod_pipe.o
+convec.o: convec.f mod_xc.o common_blocks.h stmt_fns.h
+diapfl.o: diapfl.f mod_xc.o common_blocks.h stmt_fns.h
+dpthuv.o: dpthuv.f mod_xc.o common_blocks.h
+dpudpv.o: dpudpv.f mod_xc.o
+forfun.o: forfun.f mod_xc.o common_blocks.h mod_za.o
+geopar.o: geopar.F mod_xc.o common_blocks.h stmt_fns.h mod_za.o
+hybgen.o: hybgen.f mod_xc.o common_blocks.h stmt_fns.h mod_pipe.o
+icloan.o: icloan.f mod_xc.o common_blocks.h stmt_fns.h
+inicon.o: inicon.f mod_xc.o common_blocks.h stmt_fns.h mod_pipe.o
+inigiss.o: inigiss.f mod_xc.o common_blocks.h stmt_fns.h
+inikpp.o: inikpp.f mod_xc.o common_blocks.h stmt_fns.h
+inimy.o: inimy.f mod_xc.o common_blocks.h stmt_fns.h
+isnan.o: isnan.F
+latbdy.o: latbdy.f mod_xc.o common_blocks.h mod_tides.o
+machine.o: machine.F
+machi_c.o: machi_c.c
+matinv.o: matinv.f mod_xc.o common_blocks.h
+momtum.o: momtum.f mod_xc.o common_blocks.h stmt_fns.h mod_pipe.o \
+ mod_tides.o
+mxkprf.o: mxkprf.f mod_xc.o common_blocks.h stmt_fns.h mod_pipe.o
+mxkrt.o: mxkrt.f mod_xc.o common_blocks.h stmt_fns.h
+mxkrtm.o: mxkrtm.f mod_xc.o common_blocks.h stmt_fns.h
+mxpwp.o: mxpwp.f mod_xc.o common_blocks.h stmt_fns.h
+overtn.o: overtn.f mod_xc.o common_blocks.h
+poflat.o: poflat.f
+prtmsk.o: prtmsk.f
+psmoo.o: psmoo.f mod_xc.o
+restart.o: restart.f mod_xc.o common_blocks.h mod_za.o mod_tides.o
+thermf.o: thermf.f mod_xc.o common_blocks.h stmt_fns.h
+trcupd.o: trcupd.f mod_xc.o common_blocks.h mod_pipe.o
+tsadvc.o: tsadvc.f mod_xc.o common_blocks.h stmt_fns.h mod_pipe.o
+wtime.o: wtime.F
+mod_hycom.o: \
+ mod_hycom.F mod_xc.o common_blocks.h mod_za.o mod_pipe.o \
+ mod_incupd.o \
+ mod_mean.o \
+ mod_floats.o
+mod_incupd.o: \
+ mod_incupd.F mod_xc.o common_blocks.h mod_za.o
+mod_floats.o: \
+ mod_floats.F mod_xc.o common_blocks.h mod_za.o mod_pipe.o
+mod_pipe.o: \
+ mod_pipe.F mod_xc.o common_blocks.h
+mod_tides.o: \
+ mod_tides.F mod_xc.o common_blocks.h mod_za.o
+mod_mean.o: \
+ mod_mean.F mod_xc.o common_blocks.h mod_za.o
+
+mod_dimensions.o: mod_dimensions.F dimensions.h
+mod_xc.o: mod_xc.F mod_dimensions.o mod_xc_sm.h mod_xc_mp.h
+mod_za.o: mod_za.F mod_xc.o mod_za_sm.h mod_za_mp.h mod_za_mp1.h mod_za_zt.h
+
+mod_OICPL.o: mod_OICPL.F
diff --git a/src_2.2.18_3_one/README.src.MICOMvsHYCOM b/src_2.2.18_3_one/README.src.MICOMvsHYCOM
new file mode 100755
index 0000000..a316863
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.MICOMvsHYCOM
@@ -0,0 +1,94 @@
+src_2.1.02_22_one/README.src.MICOMvsHYCOM
+
+1. MICOM had a bulk mixed layer (prognostic T&S) above isopycnal layers
+(prognostic S). HYCOM has a hybrid vertical coordinate that can
+dynamically migrate between isopycnal, Z-level and sigma-level. It
+has two prognostic thermodynamic variables (T&S) in all layers, and the
+mixed layer is no longer associated with layer 1.
+
+2. MICOM used CGS units, with fluxes positive into the atmosphere, and
+its standard grid orienetation was: 1st dimension North to South, 2nd
+dimension West to East, with u and v representing southward and eastward
+velocity respectively. HYCOM uses MKS units throughout, with all input
+in MKS and with fluxes positive into the ocean. Its standard grid
+orientation is: 1st dimension West to East, 2nd dimension South to
+North, with u and v representing eastward and northward velocity
+respectively. See doc/meshmap_{hycom,micom}.[tex,ps} for HYCOM and
+MICOM standard grid maps.
+
+3. HYCOM can handle arbitrary orthogonal curvilinear grids, which are
+specified by 2-D arrays of lat,lon locations for each grid point.
+
+4. Routine hybgen.f controls the migration of layers between isopycnal
+and fixed vertical coordinates, see doc/hybrid.ps. Fixed coordinates
+are selected by specifying a minimum thickness for layers that would
+outcrop at the surface if they were isopycnal. The minimum thickness
+is layer number dependent (i.e. can be thicker for deeper layers), and
+can also depend on the bathymetry (i.e. sigma-levels).
+
+5. HYCOM containes several mixed layer models. Kraus-Turner (KT) models
+are included for compatibility with MICOM, but the recommended mixed
+layer model is the non-slab K-Profile Parameterization (KPP) approach
+of Mc Williams, Large, and Doney. In addition, Mellor-Yamada level 2.5
+and Price-Weller-Pinkel mixed layer models are available.
+
+ 5a. The KT model governs mixing only within the mixed layer while the
+KPP model provides mixing from surface to bottom. When the KT model is
+selected, interior diapycnal mixing can either be explict (as in MICOM)
+or implicit (based on a subset of the KPP scheme).
+
+ 5b. The KPP model parameterizes interior diapycnal mixing due to (1)
+background internal wave breaking, (2) double-diffusion (diffusive convection
+and salt fingering cases), and (3) instability due to resolved vertical shear
+based on a gradient Richardson number. Process (1) is always implemented,
+but the others are optional.
+
+ 5c. In KPP, diffusivities within the surface boundary layer are
+parameterized as a function of boundary layer thickness times a
+depth-dependent turbulent velocity scale (proportional to ustar) times a
+third-order polynomial shape function of depth. Boundary layer
+diffusivities depend on surface forcing (the magnitude of this forcing
+and whether it is stabilizing or de-stabilizing) plus the magnitude and
+gradient of interior mixing at the boundary layer base. At the boundary
+layer base, boundary layer diffusivity profiles are smoothly matched to
+interior diffusivity profiles resulting from the processes listed above
+(the profiles and their first derivatives are continuous at the boundary
+layer base). The turbulent boundary layer depth (hbl) is diagnosed first,
+the boundary layer diffusivity profiles are calculated, then the boundary
+and interior diffusivity profiles are combined. The depth hbl is the
+maximum depth to which boundary layer eddies can penetrate.
+
+ 5d. KPP boundary layer mixing optinally includes a nonlocal forcing
+term to parameterize countergradient fluxes due to nonlocal effects.
+
+ 5e. For KPP mixing, solutions of the vertical diffusion equation are
+performed using a tri-diagonal matrix inversion. The solution is
+semi-implicit because multiple iterations are performed. Two iterations
+are recommended as a reasonable balance between solution accuracy and
+computation time.
+
+ 5f. For KPP mixing, the mixed layer depth is diagnosed in the same
+manner as it is using observations. Vertical interpolation is used to
+find the depth at which the density exceeds the surface layer value by
+a specified value (-sigmlj-, which is set in blkdat.input).
+
+ 5g. For both mixed layer models, bulk mixed layer fields of T, S,
+density, u, and v are diagnosed by vertically averaging these fields
+from the surface down to the mixed layer base.
+
+ 5h. One additional surface forcing field, shortwave radiation flux,
+has been added. Code has been added to handle penetrating shortwave
+radiation when either mixed layer model is selected. Penetrating
+shortwave radiation is necessary for KPP mixing, but is optional for
+Kraus-Turner mixing. Penetration depth is a function of water clarity
+through the jerlov water type. The water type is currently set to
+the same value everywhere.
+
+ 5i. No matter which mixed layer model is selected, surface momentum
+forcing is distributed entirely within layer 1 at each grid point.
+Vertical mixing of momentum is performed by the mixed layer models.
+
+6. HYCOM has a MICOM-like mode, which is almost exactly the same as
+MICOM 2.8. In this mode, the mixed layer model has to MICOM's version
+of K-T, all layers below layer 1 are isopycnal (temperature is a
+dependent variable), and hybgen is never called.
diff --git a/src_2.2.18_3_one/README.src.OpenMP b/src_2.2.18_3_one/README.src.OpenMP
new file mode 100755
index 0000000..4a66dbe
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.OpenMP
@@ -0,0 +1,33 @@
+src_2.1.02_22_one/README.src.OpenMP:
+
+The OpenMP directives allow HYCOM to run on multiple processors of
+shared memory machines. They can also be used in conjuction with
+MPI domain decomposition (MPI between multi-processor nodes, OpenMP on
+each node). This mode of parallelization is typically best for a
+relatively modest number of processors (2,3,4,6,8), although more can
+profitably be used on large grids.
+
+The PARAMETER mxthrd has been added to dimensions.h. Each outer
+(i or j) loop is diviuded into mxthrd pieces by OpenMP. So mxthrd
+should be a multiple of NOMP (i.e. OMP_NUM_THREADS). It is often
+best to set mxthrd larger than NOMP, because that tends to give
+better land/sea load balance between threads. For example,
+mxthrd=16 could be used with 2, 4, 8 or 16 threads. Other good
+choices are 12, 24, 32 etcetera. Large values of mxthrd are only
+likely to be optimal for large idm and jdm.
+
+Parallel sums are not performed via an OpenMP REDUCTION clause, because
+it is not bit for bit reproducable when run twice on the same data sets.
+Instead, row sums are done explicitly in parellel, followed by a serial
+sum of the row sums. This is probably slower than REDUCTION, but it is
+bit for bit reproducable on any number of processors. Please report
+any cases where HYCOM gives different answers for different values of
+OMP_NUM_THREADS (this is not supposed to happen).
+
+Timers have been placed around all the high level routines. This involves
+linking in a potentially machine-specific wall clock time routine. The
+default is to use a timer based on the Fortran 90 SYSTEM_CLOCK intrinsic
+or MPI_WTIME is MPI is being used, see wtime.F. On some machines a timer
+written in C may be faster or more accurate, and it can be included in
+machi_c.c (but make sure to disable the timers in wtime.F).
+.
diff --git a/src_2.2.18_3_one/README.src.changes b/src_2.2.18_3_one/README.src.changes
new file mode 100755
index 0000000..31cb821
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.changes
@@ -0,0 +1,55 @@
+src_2.1.02_22_one/README.src.changes
+
+1.0.08 (08/01/00) to 1.0.10 (01/08/01):
+---------------------------------------
+
+a) See README.src.changes_1p0 for HYCOM 1.0 history.
+
+
+2.0.01 (05/30/01) to 2.0.02 (07/19/01):
+---------------------------------------
+
+a) See README.src.changes_2p0 for HYCOM 2.0 history.
+
+
+2.1.03 (09/30/02):
+------------------
+
+a) This is the first official release of HYCOM 2.1.
+
+b) See README.src.hycom2p1 for a description of the major differences
+ to HYCOM 2.0.
+
+2.1.08 (03/10/03):
+------------------
+
+a) Bugfix for annual rivers (forfun.f).
+
+b) Separate "critical Ri" input variables for KPP and PWP (blkdat.f).
+
+c) Bugfix for mixed layer model KTA, mixed layer base must be at least
+ as deep as interface 3 (mxkrt.f).
+
+d) Bugfix for the meridional heat flux calculation (overtn.f).
+
+e) Bugfix in MPI version of momtum.f.
+
+f) Bugfix for constant and zonal initial state (poflat.f).
+
+g) Removed stencil.f and zebra.f.
+
+h) Turbidity based on annual or monthly kPAR fields.
+
+i) Separate time scales for SST and SST relaxation.
+
+j) Hybrid remapper used Piecewise Linear Method for fixed depth layers
+ (can recover original Piecewise Constant Method by changing two lines
+ in hybgen.f).
+
+k) Added support for merging two MPI tiles into one tile (mod_xc_mp.F).
+
+l) Vertical viscosity and diffusivity can be written to the archive.
+ Treated as tracers by hycomproc and archv2 programs.
+
+In all source directories, diff.log provides a detailed listing of the
+differences against the last major release.
diff --git a/src_2.2.18_3_one/README.src.changes_1p0 b/src_2.2.18_3_one/README.src.changes_1p0
new file mode 100755
index 0000000..0f89884
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.changes_1p0
@@ -0,0 +1,66 @@
+src_1.0.10_16/README.src.changes
+
+1.0.08 (08/01/00):
+------------------
+
+a) This is the first official release of HYCOM.
+
+
+1.0.10 (01/08/01):
+------------------
+
+a) This is the second official release of HYCOM.
+
+b) The plot program, hycomproc, user interface has been improved.
+
+c) The climatology interpolation programs have been significantly
+ revised to provide more nearly isopycnal layers and to minimize
+ the effect of pakk I/O quantization error.
+
+d) Bugs in 1.0.08 have been fixed, see README.bugs_1.0.08.
+
+e) The OpenMP loop logic has been simplified by introducing "single
+ j-row" subroutines where appropriate.
+
+f) An "energy loan" ice model has been added as an option.
+
+g) A MICOM-like fully isopycnal mode has been added as an option.
+
+h) Convective adjustment of the mixed layer has been commented out
+ of the Kraus-Turner bulk mixed layer model, because it tends to
+ prevent springtime shallowing.
+
+i) A second Kraus-Turner bulk mixed layer has been added as an option.
+
+j) High frequency atmospheric forcing is now available as an option.
+ The naming conventions for archive files now key to the wind day
+ and are of the form archv.YYYY.DDD.HH, where YYYY is the year
+ (model or actual), DDD is the day in the year, and HH is the Zulu
+ hour in the day. Exchange coefficients are more significant with
+ high frequency forcing, so the more accurate Kara coefficients have
+ been made available as an option (flxflg=2).
+
+k) The hybrid grid generator, hybgen, has been modified to include
+ "unmixing" of the lowest active layer (commented out by default in
+ 1.0.08), to use a more natural scale factor in the cushion function,
+ to fill massless isopycnal layers on sea floor with salinity from
+ above, to reduce the ignored isopycnic variance from 0.1*sigjmp
+ to 0.0001 kg/m**3, and to allow for "blocking" interior layers.
+
+l) The hybrid grid generator and thermal advection terms can each
+ conserve T&S, th&S, or th&T under run-time control. In 1.0.08
+ both conserved T&S, but conserving density (th&S) in both terms
+ appears to improve the long-term properties of the hybrid grid
+ generator.
+
+m) The reference pressure type (Sigma-0, Sigma-2, or Sigma-4) must
+ still be selected at compile time, but it is now checked at run
+ time (via the thflag input value). Thermobaric compressibility
+ can now be selected at run time (via the kapflg input value).
+
+n) The vertical profile of the (itest,jtest) location is written to
+ the .log file after every major subroutine on every time step when
+ the file PIPE_DEBUG exists in the primary scratch directory.
+
+In all source directories, diff.log provides a detailed listing of the
+differences against the last major release.
diff --git a/src_2.2.18_3_one/README.src.changes_2p0 b/src_2.2.18_3_one/README.src.changes_2p0
new file mode 100755
index 0000000..7dcaaa6
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.changes_2p0
@@ -0,0 +1,47 @@
+src_2.0.01_16_omp/README.src.changes
+
+1.0.08 (08/01/00) to 1.0.10 (01/08/01):
+------------------
+
+a) See README.src.changes_1p0 for HYCOM 1.0 history.
+
+
+2.0.01 (05/30/01):
+------------------
+
+a) This is the first official release of HYCOM 2.0.
+
+b) See README.src.hycom2p0 for a description of the major differences
+ to HYCOM 1.0.
+
+2.0.02 (07/19/01):
+------------------
+
+a) Fixed a high frequency wind input bug in forfun.f.
+
+b) Skip (rather than read) to the first required high frequency wind
+ inoput record in forfun.f.
+
+c) Fixed periodic domain and xcsum bugs in mod_xc_mp.F.
+
+d) Fixed do-loop extent bug in bigrid.f.
+
+e) Fixed a MICOM-like side-wall relaxation bug in thermf.f.
+
+f) Added a check on the vertical structure of the input climatology
+ (geopar.f and forfun.f modified).
+
+g) Fixed a tracer I/O bug in restart.f.
+
+h) Added support for f-plane (mapflg=4). Several source files were
+ changed (bigrid.f, blkdat.f, geopar.f, inicon.f and mod_xc*.F).
+
+i) Added a comment about minimums for kdpth and klat to poflat*.f.
+
+j) Added support for net heat flux (flxflg=3) in blkdat.f and thermf.f.
+
+k) Modified how dpudpv is called. Several source files were changed
+ (diapfl.f, dpudpv.f, hybgen.f, hycom.f, inicon.f, momtum.f and mxkrtm.f).
+
+In all source directories, diff.log provides a detailed listing of the
+differences against the last major release.
diff --git a/src_2.2.18_3_one/README.src.cice b/src_2.2.18_3_one/README.src.cice
new file mode 100755
index 0000000..d9dfcbe
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.cice
@@ -0,0 +1,28 @@
+README.src.cice:
+
+The Makefile sources ../config/$(ARCH)_$(TYPE) where ARCH defines exactly
+what machine architecture to target and TYPE is the parallelization
+strategy and precision. For HYCOM coupled to CICE via ESMF, TYPE is cice.
+The make process for HYCOM+CICE is automated by the script Make_cice.com,
+which should be used instead of directly invoking the make command.
+
+The source code directory name should end with _${TYPE}, where ${TYPE}
+is cice. The script Make_cice.com should be edited to define ${ARCH}
+appropriately for the machine. The executable is then created by the
+command:
+
+ ./Make_cice.com >& Make_cice.log
+
+In order for this to work, the file config/${ARCH}_${TYPE} must exist
+and must contain the machine-specific parts of Makefile (see README.config).
+Also, the CICE ESMF component is built in a separate subdirectory by
+Make_cice.com.
+
+Note that ESMF is built on MPI, and so dimensions.h should be configured as
+for mpi. In addition, CICE is hardwired at compile time for one domain
+decomposition and dimensions.h must be consistent with CICE.
+
+The source code is the same for all TYPE values including cice. Each TYPE
+invokes different CPP macros to modify the source code behavior. In addition,
+there is a different main program and an extra coupling module for hycom_cice
+only and these are specified in the Makefile.
diff --git a/src_2.2.18_3_one/README.src.esmf b/src_2.2.18_3_one/README.src.esmf
new file mode 100755
index 0000000..c74180b
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.esmf
@@ -0,0 +1,24 @@
+README.src.esmf:
+
+The Makefile sources ../config/$(ARCH)_$(TYPE) where ARCH defines exactly
+what machine architecture to target and TYPE is the parallelization
+strategy and precision. For HYCOM as an ESMF compenent or stand-alone with
+ESMF, TYPE is esmf. For HYCOM+CICE with ESMF, TYPE is cice (see README.cice).
+The make process for stand-alone HYCOM is automated by the script Make.com,
+which should be used instead of directly invoking the make command. To make
+a HYCOM ESMF component, use the script Make_esmf.com.
+
+The source code directory name should end with _${TYPE}, where ${TYPE}
+is esmf. The script Make.com or Make_esmf.com should be edited to define
+${ARCH} appropriately for the machine. The executable is then created by
+the command:
+
+ ./Make.com >& Make.log
+
+In order for this to work, the file config/${ARCH}_${TYPE} must exist
+and must contain the machine-specific parts of Makefile (see README.config).
+
+Note that ESMF is built on MPI, and so dimensions.h should be configured as
+for mpi. Also, the source code is the same for all TYPE values including
+esmf. Each TYPE invokes different CPP macros to modify the source code
+behavior.
diff --git a/src_2.2.18_3_one/README.src.hycom2p1 b/src_2.2.18_3_one/README.src.hycom2p1
new file mode 100755
index 0000000..f9d0ed5
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.hycom2p1
@@ -0,0 +1,19 @@
+src_2.1.08_22_one/README.src.hycom2p1
+
+Major changes since version 2.0:
+
+a) Support for orthogonal curvilinear grids.
+
+b) Support for 1-D and 2-D domains.
+
+c) Improved support for Z and Sigma levels in shallow water.
+
+d) More flexible selection of Laplacian and biharminic diffusion.
+
+e) Rivers as (annual or monthly) bogused surface precipitation.
+
+f) Beta-level support for passive and simple bio tracers.
+
+g) Added PWP and MY 2.5 mixed layers.
+
+h) Support for off-line one-way nesting.
diff --git a/src_2.2.18_3_one/README.src.hycom2p2 b/src_2.2.18_3_one/README.src.hycom2p2
new file mode 100755
index 0000000..4dc96f5
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.hycom2p2
@@ -0,0 +1,34 @@
+README.src.hycom2p2
+
+Major changes since version 2.1.34:
+
+a) Bugfix to FCT2 tsadvc
+
+b) Incremental updating (data assimilation)
+
+c) Initial support for ESMF, coupled HYCOM+CICE
+
+d) Alternative LeapFrog barotropic time splitting
+
+e) Alternative scalar advection techniques, FCT2 replaces MPDATA as standard
+
+f) GISS mixed layer model
+
+g) KPP bottom boundary layer
+
+h) Major overhaul of hybgen
+
+i) Equation of state that is quadratic in salinity
+
+j) Improved thermobaricity
+
+k) Numerous atmospheric forcing improvements
+
+l) Tidal forcing (not yet for Browning-Kreiss nesting)
+
+m) Mean archive files from running model
+
+n) Sub-region archive files from running model
+
+o) Synthetic instrumentation from running model
+
diff --git a/src_2.2.18_3_one/README.src.make b/src_2.2.18_3_one/README.src.make
new file mode 100755
index 0000000..8ab24c0
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.make
@@ -0,0 +1,17 @@
+src_2.0.01_16/README.src.newmachine:
+
+The Makefile sources ../config/$(ARCH)_$(TYPE) where ARCH defines exactly
+what machine architecture to target and TYPE is the parallelization
+strategy and precision (one, omp, mpi, mpisr, shmem). The make process
+is automated by the script Make.com, which should be used instead of
+directly invoking the make command.
+
+The source code directory name should end with _${TYPE}, where ${TYPE}
+is the parallelization type (one,omp,mpi,ompi,shmem). The script
+Make.com should be edited to define ${ARCH} appropriately for the
+machine. The executable is then created by the command:
+
+ ./Make.com >& Make.log
+
+In order for this to work, the file config/${ARCH}_${TYPE} must exist
+and must contain the machine-specific parts of Makefile (see README.config).
diff --git a/src_2.2.18_3_one/README.src.mod_xc b/src_2.2.18_3_one/README.src.mod_xc
new file mode 100755
index 0000000..024600e
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.mod_xc
@@ -0,0 +1,44 @@
+The following are one line descriptions of all HYCOM communication routines:
+
+ xcaget - convert an entire 2-D array from tiled to non-tiled layout.
+ xcaput - convert an entire 2-D array from non-tiled to tiled layout.
+ xceget - find the value of a(ia,ja) on the non-tiled 2-D grid.
+ xceput - fill a single element in the non-tiled 2-D grid.
+ xchalt - emergency stop all processes, called by one process.
+ xclget - extract a line of elements from the non-tiled 2-D grid.
+ xclput - fill a line of elements in the non-tiled 2-D grid.
+ xcmaxr - replace array a with its element-wise maximum over all tiles.
+ xcminr - replace array a with its element-wise minimum over all tiles.
+ xcspmd - initialize processor data structures, called once.
+ xcstop - stop all processes, called by all processes.
+ xcsum - sum of a 2-D array.
+ xcsumj - row-sum of a 2-D array.
+ xcsync - barrier, no processor exits until all arrive (flush stdout).
+ xctbar - sync with processors ipe1 and ipe2 (internal use only).
+ xctilr - update the tile overlap halo of a 3-D real array.
+
+ xctmri - initialize timers.
+ xctmr0 - start timer.
+ xctmr1 - add time since call to xctim0 to timer.
+ xctmrn - register name of timer.
+ xctmrp - print all active timers.
+
+With the exception of xchalt, All these routines are assumed to be called
+with identical argument lists by all processors when using SPMD message
+passing. This is not difficult to arrange, since by default all routines
+are called in this manner in a SPMD run. Most communication routines
+act as implicit barriers that syncronize processor state, i.e. when a
+processor exits a communication routine at the very least all processors
+that must communicate with it have entered the same subroutine. In
+addition the subroutine xcsync provided for cases where all processors
+must enter a critical section of code before the first processor exits.
+
+Two versions of each subroutine are provided, mod_xc_mp.F for message
+passing, and mod_xc_sm.F for a single processor. The appropriate version
+is included in mod_xc.F under control of cpp macros. The routines are
+configured as a module, and all HYCOM routines should start with
+use mod_xc to allow HYCOM communication routines to be invoked when
+required.
+
+The programs in ./TEST confirm that individual communication routines are
+working.
diff --git a/src_2.2.18_3_one/README.src.mod_za b/src_2.2.18_3_one/README.src.mod_za
new file mode 100755
index 0000000..1598b6c
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.mod_za
@@ -0,0 +1,60 @@
+The following are one line descriptions of all HYCOM I/O routines:
+
+ zagetc - get (read) one line from a text file
+
+ zaiost - initialize all array i/o.
+ zaiopn - open a file for array i/o, filename from array i/o unit.
+ zaiope - open a file for array i/o, filename from environment variable.
+ zaiopf - open a file for array i/o, filename provided.
+ zaiopi - is an array i/o unit open?
+ zaiocl - close an array i/o unit.
+ zaiofl - flush an array i/o unit.
+ zaioiq - query an array i/o unit.
+ zaiorw - rewind an array i/o unit.
+ zaiord3 - read an array (3-D).
+ zaiord - read an array.
+ zaiosk - skip an array read.
+ zaiowr3 - write an array (3-D).
+ zaiowr - write an array.
+
+All these routines are assumed to be called with identical argument lists
+by all processors when using SPMD message passing. This is not difficult
+to arrange, since by default all routines are called in this manner in a
+SPMD run. The zaio routines are used to process HYCOM ".a" files, which
+contain array data only (see below). The zagetc routine is used to
+process HYCOM ".b" plain text files. These are only opened on the
+first processor, so under MPI zagetc reads a line on the first processor
+and then broadcasts it to all other processors.
+
+Two versions of each subroutine are provided, mod_za_mp.F for message
+passing, and mod_za_sm.F for a single processor (and OpenMP). The
+appropriate version is included in mod_za.F under control of cpp
+macros. The routines are configured as a module, and all HYCOM routines
+should start with use mod_za to allow HYCOM communication routines to
+be invoked when required.
+
+A special version of each subroutine is also in ALL/libsrc/mod_za.F.
+This implements the identical set of subroutines, but for pre/post
+processing programs only. These are all single processor programs,
+and ALL/libsrc/mod_za.F is therefore similar to mod_za_sm.F except
+that the array size idm,jdm is set at run time.
+
+A related API with "za" replaced by "zb" is in ALL/libsrc/mod_zb.F.
+It is only used when reading in the full domain (via zaiord), but
+writing out a sub-domain (via zbiowr).
+
+HYCOM ".a" files contain idm*jdm 32-bit IEEE real values for each array,
+in standard fortran element order, followed by padding to a multiple of
+4096 32-bit words (16K bytes), but otherwise with no control bytes/words,
+and input values of 2.0**100 indicating a data void. Each record is
+padded to 16K bytes to potentially improve I/O performance on some machines
+by aligning record boundaries on disk block boundaries.
+
+The associated HYCOM ".b" files are plain text and typically contain a
+5-line header followed by one line for each 2-D array in the ".a" file.
+The format of the per-array line varies, but it typically use "=" to
+separate an array description from trailing numeric values. The latter
+always include the minimum and maximum value of the array as returned
+by zaiowr or zaiowr3 (which should be checked against the min/max of
+the actual array on input, returned by zaiord or zaiord3, to confirm
+that the .a and .b files are in fact associated with each other).
diff --git a/src_2.2.18_3_one/README.src.newmachine b/src_2.2.18_3_one/README.src.newmachine
new file mode 100755
index 0000000..8ab24c0
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.newmachine
@@ -0,0 +1,17 @@
+src_2.0.01_16/README.src.newmachine:
+
+The Makefile sources ../config/$(ARCH)_$(TYPE) where ARCH defines exactly
+what machine architecture to target and TYPE is the parallelization
+strategy and precision (one, omp, mpi, mpisr, shmem). The make process
+is automated by the script Make.com, which should be used instead of
+directly invoking the make command.
+
+The source code directory name should end with _${TYPE}, where ${TYPE}
+is the parallelization type (one,omp,mpi,ompi,shmem). The script
+Make.com should be edited to define ${ARCH} appropriately for the
+machine. The executable is then created by the command:
+
+ ./Make.com >& Make.log
+
+In order for this to work, the file config/${ARCH}_${TYPE} must exist
+and must contain the machine-specific parts of Makefile (see README.config).
diff --git a/src_2.2.18_3_one/README.src.newregion b/src_2.2.18_3_one/README.src.newregion
new file mode 100755
index 0000000..d1be96f
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.newregion
@@ -0,0 +1,86 @@
+src_2.1.02_22_one/README.src.newregion:
+
+The only source code file that should need changing for a new region or a
+different number of layers is dimensions.h. There are several example
+versions for different regions available:
+
+ dimensions_ATLb2.00_omp.h - 2.00 degree Atlantic, shared memory
+ dimensions_ATLb2.00_ompi.h - 2.00 degree Atlantic, distrib. memory
+ dimensions_ATLd0.32_omp.h - 0.32 degree Atlantic, shared memory
+ dimensions_ATLd0.32_ompi.h - 0.32 degree Atlantic, distrib. memory
+ dimensions_IASd0.32_omp.h - 0.32 degree Intra Americas, shared memory
+ dimensions_IASd0.32_mpi.h - 0.32 degree Intra Americas, distrib. memory
+
+Copy the appropriate version to dimensions.h, or create your own version
+for a new region. Typically, the "_omp" OpenMP version is also appropriate
+for a single processor and the "_ompi" OpenMP+MPI version can be used for
+any distributed memory configuration (MPI only or SHMEM only, as well as
+MPI+OpenMP). The user-tunable parameters are:
+
+ itdm = total grid dimension in i direction
+ jtdm = total grid dimension in j direction
+ kdm = grid dimension in k direction
+ iqr = maximum number of tiles in i direction
+ jqr = maximum number of tiles in j direction
+ idm = maximum single tile grid dimension in i direction
+ jdm = maximum single tile grid dimension in j direction
+ mxthrd = maximum number of OpenMP threads
+ kkwall = grid dimension in k direction for wall relax arrays
+ kknest = grid dimension in k direction for nest relax arrays
+ kkmy25 = grid dimension in k direction for M-Y 2.5 arrays
+
+If memory is plentifull, then kkwall,kknest,kkmy25 can all be set to
+kdm. However, if memory is in short supply then kwall and/or kknest
+can be set to 1 (if wall or nest relaxation is not being used) and
+if the Mellor-Yamada mixed layer isn't being used kkmy25 can be set
+to -1.
+
+A new source code directory and executable is always required whenever
+itdm, or jtdm, or kdm change (i.e. whenever the region size or the
+number of layers change). Note that ../topo/regional.grid.b is used
+to define the region to setup programs, and needs to be consistent with
+dimensions.h.
+
+A separate source code directory and executable is always required for
+each parallelization strategy, or TYPE, chosen (TYPE=one, or omp, or ompi,
+or mpi, or shmem). The TYPE also effects how dimensions.h is configured.
+
+When running on a shared memory machine (TYPE=one or omp) set:
+iqr=jqr=1, idm=itdm, and jdm=jtdm. Note that the same OpenMP executable
+(TYPE=omp) can be used for a range of processor counts, provided mxthrd
+is chosen appropriately (see below).
+
+When running on a distributed memory machine (TYPE=mpi or ompi or shmem)
+set: iqr and jqr to the maximum number of processors used in each
+dimension, and idm and jdm to the maximum (worse case) dimensions for
+any single tile on any targeted number of processors. Note that the
+same executable can be used for a range of processor counts, provided
+iqr,jqr,idm,jdm are all large enough for each case.
+
+The mxthrd parameter is only important when using OpenMP (TYPE=omp or
+ompi). It should be an integer multiple of the number of threads used
+at run time (i.e. of NOMP), and is typically chosen such that
+jblk=(jdm+2*nbdy+mxthrd-1)/mxthrd is about 5-10. For TYPE=omp, the
+command bin/hycom_mxthrd can be used as an aid in selecting the optimal
+mxthrd. It prints out the stripe size (jblk) and load-balance efficiency
+of all sensible mxthrd values.
+
+When iniflg=1 (blkdat.input), the initial state is based on a zonal
+climatology defined by data statements in poflat.f. These might need
+modifying for a particular region. Once again, several example versions
+for different regions are available:
+
+ poflat_ATLd.f - Atlantic to 70N, including the Med.
+ poflat_IASd.f - Intra Americas Sea
+ poflat_JESa.f - Japan/East Sea
+ poflat_F1Da.f - 1-D test case (same profile at all latitiudes)
+ poflat_F2Da.f - 2-D upwelling case (same profile at all latitiudes)
+ poflat_SYMa.f - 3-D symmetry case (same profile at all latitiudes)
+
+Note that this routine does not depend on grid resolution. Copy the
+appropriate version to poflat.f, or create your own version for a new
+region. There are examples of how to create a new version in ../relax.
+
+All other region-specific values are input at run time from blkdat.input.
+Obviously, all input bathymetry, forcing and boundary relaxation files
+are also region specific.
diff --git a/src_2.2.18_3_one/README.src.test b/src_2.2.18_3_one/README.src.test
new file mode 100755
index 0000000..d5e79d8
--- /dev/null
+++ b/src_2.2.18_3_one/README.src.test
@@ -0,0 +1,21 @@
+src_2.0.01_16/TEST/README.src.test:
+
+This directory contains stand-alone tests of MPI communication routines.
+It should not normally be needed to run HYCOM, unless there are
+indications that the MPI version is not working correctly (e.g. a failed
+named pipe comparison, see README.expt_pipe). Note that the ATLa2.00
+coastline is not a definative test of MPI communications, but these
+test cases have also been run on several other regions.
+
+To create all the executables issue the command:
+
+ ./Make_all.com >$ Make_all.log
+
+This assumes that ../hycom is up to date, and that compiled module
+information is either in *.o or *.mod. Edit Make_all.com for the
+appropriate ARCH. Note that the TYPE is taken from the source
+directory name.
+
+All the run scripts are configured for an IBM SP with the LoadLeveler
+batch system, with either 3 or 9 MPI tasks. These should be edited
+for your region and the appropriate number of MPI tasks.
diff --git a/src_2.2.18_3_one/TEST/Make_all.com b/src_2.2.18_3_one/TEST/Make_all.com
new file mode 100755
index 0000000..8bca89f
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/Make_all.com
@@ -0,0 +1,25 @@
+#
+set echo
+cd $cwd
+#
+# --- Usage: ./Make.com >& Make.log
+#
+# --- make all with TYPE from this directory's name (src_*_$TYPE/TEST).
+# --- set ARCH to the correct value for this machine.
+# --- assumes dimensions.h is correct for $TYPE.
+#
+setenv ARCH sp3GPFS
+#
+cd ..
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+cd TEST
+#
+if (! -e ../../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+else
+ cp ../mod*.[om]* .
+ foreach t ( xca xcl xcs xct zaio )
+ make $t ARCH=$ARCH TYPE=$TYPE
+ end
+endif
diff --git a/src_2.2.18_3_one/TEST/Make_arctic.com b/src_2.2.18_3_one/TEST/Make_arctic.com
new file mode 100755
index 0000000..6f08b7f
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/Make_arctic.com
@@ -0,0 +1,25 @@
+#
+set echo
+cd $cwd
+#
+# --- Usage: ./Make_arctic.com >& Make_arcticlog
+#
+# --- make arctic with TYPE from this directory's name (src_*_$TYPE/TEST).
+# --- set ARCH to the correct value for this machine.
+# --- assumes dimensions.h is correct for $TYPE.
+#
+setenv ARCH Asp4
+#
+cd ..
+setenv TYPE `echo $cwd | awk -F"_" '{print $NF}'`
+cd TEST
+#
+if (! -e ../../config/${ARCH}_${TYPE}) then
+ echo "ARCH = " $ARCH " TYPE = " $TYPE " is not supported"
+ exit 1
+else
+ cp ../mod*.[om]* .
+ foreach t ( xct_arctic )
+ make $t ARCH=$ARCH TYPE=$TYPE
+ end
+endif
diff --git a/src_2.2.18_3_one/TEST/Makefile b/src_2.2.18_3_one/TEST/Makefile
new file mode 100755
index 0000000..61521c2
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/Makefile
@@ -0,0 +1,44 @@
+#
+# --- HYCOM 1.1 TEST makefile, in subdirectory ./TEST
+#
+# --- primary HYCOM .o files are assumed to be up to date.
+#
+# --- Tunable parameters in ../../config/$(ARCH)_$(TYPE)
+#
+
+.SUFFIXES:
+.SUFFIXES: .c .F .f .o
+
+include ../../config/$(ARCH)_$(TYPE)
+
+default: test_xcl
+
+# create handlinks to ../mod*.o and to machine-specific module info files
+MODS = mod_xc.o mod_za.o
+
+# assumed up to date:
+OBJS = ../machine.o ../machi_c.o ../wtime.o
+
+xca: test_xca.o
+ $(LD) $(LDFLAGS) -o test_xca test_xca.o $(OBJS) $(MODS)
+
+xcl: test_xcl.o
+ $(LD) $(LDFLAGS) -o test_xcl test_xcl.o $(OBJS) $(MODS)
+
+xcs: test_xcs.o
+ $(LD) $(LDFLAGS) -o test_xcs test_xcs.o $(OBJS) $(MODS)
+
+xct: test_xct.o
+ $(LD) $(LDFLAGS) -o test_xct test_xct.o $(OBJS) $(MODS)
+
+xct_arctic: test_xct_arctic.o
+ $(LD) $(LDFLAGS) -o test_xct_arctic test_xct_arctic.o $(OBJS) $(MODS)
+
+zaio: test_zaio.o
+ $(LD) $(LDFLAGS) -o test_zaio test_zaio.o $(OBJS) $(MODS)
+
+test_xca.o: test_xca.f dimensions.h
+test_xcl.o: test_xcl.f dimensions.h
+test_xct.o: test_xct.f dimensions.h
+test_xct_arctic.o: test_xct_arctic.f dimensions.h
+test_zaio.o: test_zaio.f dimensions.h
diff --git a/src_2.2.18_3_one/TEST/README.src.test b/src_2.2.18_3_one/TEST/README.src.test
new file mode 100755
index 0000000..d5e79d8
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/README.src.test
@@ -0,0 +1,21 @@
+src_2.0.01_16/TEST/README.src.test:
+
+This directory contains stand-alone tests of MPI communication routines.
+It should not normally be needed to run HYCOM, unless there are
+indications that the MPI version is not working correctly (e.g. a failed
+named pipe comparison, see README.expt_pipe). Note that the ATLa2.00
+coastline is not a definative test of MPI communications, but these
+test cases have also been run on several other regions.
+
+To create all the executables issue the command:
+
+ ./Make_all.com >$ Make_all.log
+
+This assumes that ../hycom is up to date, and that compiled module
+information is either in *.o or *.mod. Edit Make_all.com for the
+appropriate ARCH. Note that the TYPE is taken from the source
+directory name.
+
+All the run scripts are configured for an IBM SP with the LoadLeveler
+batch system, with either 3 or 9 MPI tasks. These should be edited
+for your region and the appropriate number of MPI tasks.
diff --git a/src_2.2.18_3_one/TEST/dimensions.h b/src_2.2.18_3_one/TEST/dimensions.h
new file mode 100755
index 0000000..e7fd0ec
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/dimensions.h
@@ -0,0 +1,103 @@
+c-----------------------------------------------------------------------------
+c --- START OF REGION AND TILING SPECIFIC PARAMETERS
+c --- See: README.src.newregion for more details.
+c
+c --- itdm = total grid dimension in i direction
+c --- jtdm = total grid dimension in j direction
+c --- kdm = grid dimension in k direction
+ integer itdm,jtdm,kdm
+ parameter (itdm= 101,jtdm= 101,kdm=3) ! ATLb2.00
+c
+c --- iqr = maximum number of tiles in i direction
+c --- jqr = maximum number of tiles in j direction
+ integer iqr,jqr
+ parameter (iqr= 1,jqr= 1) ! single tile (TYPE=one or omp)
+c
+c --- idm = maximum single tile grid dimension in i direction
+c --- jdm = maximum single tile grid dimension in j direction
+ integer idm,jdm
+ parameter (idm=itdm,jdm=jtdm) ! single tile (TYPE=one or omp)
+c
+c --- mxthrd= maximum number of OpenMP threads
+ integer mxthrd
+ parameter (mxthrd=1) ! NOMP=0,1
+c
+c --- kkwall= grid dimension in k direction for wall relax arrays
+c --- kknest= grid dimension in k direction for nest relax arrays
+ integer kkwall,kknest
+ parameter (kkwall=kdm) ! must be 1 or kdm
+ parameter (kknest= 1) ! must be 1 or kdm
+c
+c --- kkmy25= grid dimension in k direction for M-Y 2.5 arrays
+ integer kkmy25
+ parameter (kkmy25=kdm) ! must be -1 or kdm
+c
+c --- nlgiss= size of lookup table for GISS
+ integer nlgiss
+ parameter (nlgiss=762) ! must be 1 (no GISS) or 762
+c
+c --- mxtrcr= maximum number of tracers
+ integer mxtrcr
+ parameter (mxtrcr=1)
+c
+c --- nsteps_baclin = maximum baroclinic steps per day
+ integer nsteps_baclin
+ parameter (nsteps_baclin =1440) !one minute or longer time step
+c
+c --- END OF REGION AND TILING SPECIFIC PARAMETERS
+c-----------------------------------------------------------------------------
+c
+c --- halo size
+ integer nbdy
+ parameter (nbdy=6)
+c
+c --- OpenMP will allocate jblk rows to each thread in turn
+ integer jblk
+ parameter (jblk=(jdm+2*nbdy+mxthrd-1)/mxthrd)
+c
+c --- for CCSM array dimensions
+ integer imt1,imt2,jmt1,jmt2
+ parameter (imt1=1-nbdy,imt2=idm+nbdy,
+ & jmt1=1-nbdy,jmt2=jdm+nbdy )
+c
+c --- how far out the halo is valid (margin<=nbdy)
+ integer margin
+ common/edge/ margin
+ save /edge/
+c
+c --- actual extent of this tile is (i0+1:i0+ii,j0+1:j0+jj,1:kk)
+ integer i0,j0,ii,jj
+ common/dimi/ i0,j0,ii,jj
+ save /dimi/
+ integer kk
+ parameter (kk=kdm)
+c
+c --- ijqr = maximum total number of active tiles (= ipr*jpr)
+ integer ijqr
+ parameter (ijqr=iqr*jqr)
+c
+c --- ms-1 = max. number of interruptions of any tile row or column by land
+ integer ms
+ parameter (ms=99) ! should be enough for any region
+c
+c --- information in /gindex/ keeps do loops from running into land
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & ip,iu,iv,iq, iuopn,ivopn
+ integer, dimension (1-nbdy:jdm+nbdy,ms) ::
+ & ifp,ilp,ifq,ilq,ifu,ilu,ifv,ilv
+ integer, dimension (1-nbdy:idm+nbdy,ms) ::
+ & jfp,jlp,jfq,jlq,jfu,jlu,jfv,jlv
+ integer, dimension (1-nbdy:jdm+nbdy) ::
+ & isp,isq,isu,isv
+ integer, dimension (1-nbdy:idm+nbdy) ::
+ & jsp,jsq,jsu,jsv
+ common/gindex/ ip,iu,iv,iq, iuopn,ivopn,
+ & ifp,ilp,isp,jfp,jlp,jsp,ifq,ilq,isq,jfq,jlq,jsq,
+ & ifu,ilu,isu,jfu,jlu,jsu,ifv,ilv,isv,jfv,jlv,jsv
+ save /gindex/
+c
+c --- line printer unit (stdout)
+ integer lp
+ common/linepr/ lp
+ save /linepr/
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/TEST/geopar.f b/src_2.2.18_3_one/TEST/geopar.f
new file mode 100755
index 0000000..997c492
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/geopar.f
@@ -0,0 +1,517 @@
+ subroutine geopar
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+c
+c --- set up model parameters related to geography
+c
+c --- hycom version 2.1
+c
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real dp0kf,dpm,dpms,ds0kf,dsm,dsms
+ real hmina,hminb,hmaxa,hmaxb
+ integer i,ios,j,k,ktr,l
+ character preambl(5)*79,cline*80
+c
+ real aspmax
+ parameter (aspmax=2.0) ! maximum grid aspect ratio for diffusion
+* parameter (aspmax=1.0) ! ignore grid aspect ratio in diffusion
+c
+c --- read grid location,spacing,coriolis arrays
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ write (lp,'(3a)') ' reading grid file from ',
+ & flnmgrd(1:len_trim(flnmgrd)),'.[ab]'
+ open (unit=9,file=flnmgrd(1:len_trim(flnmgrd))//'.b',
+ & status='old')
+ endif
+ call xcsync(flush_lp)
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ read(cline,*) i
+c
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ read (cline,*) j
+c
+ if (i.ne.itdm .or. j.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - wrong array size in grid file'
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(a)') cline(1:len_trim(cline))
+ endif
+ read (cline,*) mapflg
+c
+ call zaiopf(flnmgrd(1:len_trim(flnmgrd))//'.a','old', 9)
+c
+ do k= 1,11
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then
+ write (lp,'(a)') cline(1:len_trim(cline))
+ endif
+ call xcsync(flush_lp)
+c
+ if (k.eq.1) then
+ call zaiord(plon, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.2) then
+ call zaiord(plat, ip,.false., hmina,hmaxa, 9)
+ do i= 1,7
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ call zaiosk(9)
+ enddo
+ elseif (k.eq.3) then
+ call zaiord(scpx, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.4) then
+ call zaiord(scpy, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.5) then
+ call zaiord(scqx, iq,.false., hmina,hmaxa, 9)
+ elseif (k.eq.6) then
+ call zaiord(scqy, iq,.false., hmina,hmaxa, 9)
+ elseif (k.eq.7) then
+ call zaiord(scux, iu,.false., hmina,hmaxa, 9)
+ elseif (k.eq.8) then
+ call zaiord(scuy, iu,.false., hmina,hmaxa, 9)
+ elseif (k.eq.9) then
+ call zaiord(scvx, iv,.false., hmina,hmaxa, 9)
+ elseif (k.eq.10) then
+ call zaiord(scvy, iv,.false., hmina,hmaxa, 9)
+ else
+ call zaiord(corio,iq,.false., hmina,hmaxa, 9)
+ endif
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ enddo
+c
+ call zaiocl(9)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close(unit=9)
+ endif
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ i=itest
+ j=jtest
+ write (lp,'(/ a,2i5,a,f8.3,a,f12.9,2f10.2/)')
+ & ' i,j=',i+i0,j+j0,
+ & ' plat=',plat(i,j),
+ & ' corio,scux,vy=',corio(i,j),scux(i,j),scvy(i,j)
+ endif
+ call xcsync(flush_lp)
+c
+c --- read basin depth array
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ write (lp,'(3a)') ' reading bathymetry file from ',
+ & flnmdep(1:len_trim(flnmdep)),'.[ab]'
+ open (unit=9,file=flnmdep(1:len_trim(flnmdep))//'.b',
+ & status='old')
+ read ( 9,'(a79)') preambl
+ endif
+ call xcsync(flush_lp)
+ call zagetc(cline,ios, 9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close(unit=9)
+ write (lp,'(/(1x,a))') preambl,cline
+ endif
+c
+ call zaiopf(flnmdep(1:len_trim(flnmdep))//'.a','old', 9)
+ call zaiord(depths,ip,.false., hmina,hmaxa, 9)
+ call zaiocl(9)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ if (depths(i,j).gt.0.5*huge) then
+ depths(i,j) = 0.0
+ endif
+ enddo
+ enddo
+c
+c --- determine do-loop limits for u,v,p,q points, and update halo for depths
+ call bigrid(depths, mapflg, util1,util2,util3)
+ccc call prtmsk(ip,depths,util1,idm,ii,jj,0.0,1.0,
+ccc & 'bottom depth (m)')
+c
+c now safe to apply halo to arrays.
+c
+ vland = 1.0
+ call xctilr(plon, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(plat, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(corio, 1,1, nbdy,nbdy, halo_qs)
+ call xctilr(scpx, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(scpy, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(scqx, 1,1, nbdy,nbdy, halo_qs)
+ call xctilr(scqy, 1,1, nbdy,nbdy, halo_qs)
+ call xctilr(scux, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(scuy, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(scvx, 1,1, nbdy,nbdy, halo_vs)
+ call xctilr(scvy, 1,1, nbdy,nbdy, halo_vs)
+ vland = 0.0
+c
+c --- area of grid cells (length x width) at u,v,p,q points resp.
+c
+******!$OMP PARALLEL DO PRIVATE(j,i)
+******!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ scu2(i,j)=scux(i,j)*scuy(i,j)
+ scv2(i,j)=scvx(i,j)*scvy(i,j)
+ scp2(i,j)=scpx(i,j)*scpy(i,j)
+ scq2(i,j)=scqx(i,j)*scqy(i,j)
+c
+ scuxi(i,j)=1.0/max(scux(i,j),epsil)
+ scvyi(i,j)=1.0/max(scvy(i,j),epsil)
+ scp2i(i,j)=1.0/max(scp2(i,j),epsil)
+ scq2i(i,j)=1.0/max(scq2(i,j),epsil)
+c
+c --- largest grid spacing (within limits) used in all diffusion
+c --- coefficients: min(max(sc?x,sc?y),sc?x*aspmax,sc?y*aspmax)
+ aspux(i,j)=min(max(scux(i,j),scuy(i,j)),
+ & min(scux(i,j),scuy(i,j))*aspmax)
+ & /max(scux(i,j),epsil)
+ aspuy(i,j)=min(max(scux(i,j),scuy(i,j)),
+ & min(scux(i,j),scuy(i,j))*aspmax)
+ & /max(scuy(i,j),epsil)
+ aspvx(i,j)=min(max(scvx(i,j),scvy(i,j)),
+ & min(scvx(i,j),scvy(i,j))*aspmax)
+ & /max(scvx(i,j),epsil)
+ aspvy(i,j)=min(max(scvx(i,j),scvy(i,j)),
+ & min(scvx(i,j),scvy(i,j))*aspmax)
+ & /max(scvy(i,j),epsil)
+c
+ util1(i,j)=depths(i,j)*scp2(i,j)
+ enddo
+ enddo
+c
+ call xcsum(avgbot, util1,ip)
+ call xcsum(area, scp2, ip)
+ avgbot=avgbot/area
+ if (mnproc.eq.1) then
+ write (lp,'(/a,f9.1,-12p,f10.2)')
+ & ' mean basin depth (m) and area (10^6 km^2):',
+ & avgbot,area
+ endif
+ call xcsync(flush_lp)
+c
+c --- logorithmic k-dependence of dp0 (deep z's)
+ dp00 =onem*dp00
+ dp00x=onem*dp00x
+ if (isopyc) then
+ dp0k(1)=thkmin*onem
+ else
+ dp0k(1)=dp00
+ endif
+ dp0kp(1)=dp0k(1)+onem
+ dpm = dp0k(1)*qonem
+ dpms = dpm
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,135) 1,dp0k(1)*qonem,dpm,dpms
+ endif
+ 135 format('dp0k(',i2,') =',f7.2,' m',
+ & ' thkns =',f7.2,' m',
+ & ' depth =',f8.2,' m')
+ call xcsync(flush_lp)
+c
+ dp0kf=1.0
+ do k=2,kk
+ dp0kf=dp0kf*dp00f
+ if (k.le.nhybrd) then
+ dp0k(k)=min(dp00*dp0kf,dp00x)
+ else
+ dp0k(k)=0.0
+ endif
+ dp0kp(k)=dp0k(k)+onem
+ dpm = dp0k(k)*qonem
+ dpms = dpms + dpm
+ if (mnproc.eq.1) then
+ write(lp,135) k,dp0k(k)*qonem,dpm,dpms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: dp0kf = ',dp0kf, mnproc
+ write(6,*) 'geopar: dp0k = ',dp0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo
+c
+c --- logorithmic k-dependence of ds0 (shallow z-s)
+ ds00 =onem*ds00
+ ds00x=onem*ds00x
+ if (isopyc) then
+ ds0k(1)=thkmin*onem
+ else
+ ds0k(1)=ds00
+ endif
+ dsm = ds0k(1)*qonem
+ dsms = dsm
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,130) 1,ds0k(1)*qonem,dsm,dsms
+ endif
+ 130 format('ds0k(',i2,') =',f7.2,' m',
+ & ' thkns =',f7.2,' m',
+ & ' depth =',f8.2,' m')
+ call xcsync(flush_lp)
+c
+ ds0kf=1.0
+ do k=2,nsigma
+ ds0kf=ds0kf*ds00f
+ ds0k(k)=min(ds00*ds0kf,ds00x)
+ dsm = ds0k(k)*qonem
+ dsms = dsms + dsm
+ if (mnproc.eq.1) then
+ write(lp,130) k,ds0k(k)*qonem,dsm,dsms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: ds0kf = ',ds0kf, mnproc
+ write(6,*) 'geopar: ds0k = ',ds0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+c
+c --- sigma-depth scale factors
+ do k=1,nsigma
+ dssk(k)=ds0k(k)/dsms ! onem * fraction of depths in sigma layer k
+ enddo
+ do k= nsigma+1,kdm
+ ds0k(k)=dp0k(k)
+ dssk(k)=0.0 ! these layers are zero in sigma mode
+ enddo
+c
+c --- initialize some arrays
+c --- set depthu,dpu,utotn,pgfx,depthv,dpv,vtotn,pgfy to zero everywhere,
+c --- so that they can be used at "lateral neighbors" of u and v points.
+c --- similarly for pbot,dp at neighbors of q points.
+c
+!$OMP PARALLEL DO PRIVATE(j,i,k,ktr)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ p( i,j,1)=0.0
+ pu( i,j,1)=0.0
+ pv( i,j,1)=0.0
+ utotn( i,j)=0.0
+ vtotn( i,j)=0.0
+ pgfx( i,j)=0.0
+ pgfy( i,j)=0.0
+ depthu(i,j)=0.0
+ depthv(i,j)=0.0
+ pbot( i,j)=0.0
+c
+ ubavg( i,j,1)=huge
+ ubavg( i,j,2)=huge
+ ubavg( i,j,3)=huge
+ vbavg( i,j,1)=huge
+ vbavg( i,j,2)=huge
+ vbavg( i,j,3)=huge
+ utotm( i,j)=huge
+ vtotm( i,j)=huge
+ uflux( i,j)=huge
+ vflux( i,j)=huge
+ uflux1(i,j)=huge
+ vflux1(i,j)=huge
+ uflux2(i,j)=huge
+ vflux2(i,j)=huge
+ uflux3(i,j)=huge
+ vflux3(i,j)=huge
+ uja( i,j)=huge
+ ujb( i,j)=huge
+ via( i,j)=huge
+ vib( i,j)=huge
+ do k=1,kk
+ dp( i,j,k,1)=0.0
+ dp( i,j,k,2)=0.0
+ dpu(i,j,k,1)=0.0
+ dpu(i,j,k,2)=0.0
+ dpv(i,j,k,1)=0.0
+ dpv(i,j,k,2)=0.0
+c
+ u( i,j,k,1)=huge
+ u( i,j,k,2)=huge
+ v( i,j,k,1)=huge
+ v( i,j,k,2)=huge
+c
+ uflx( i,j,k)=huge
+ vflx( i,j,k)=huge
+c
+ dpav( i,j,k)=0.0
+ uflxav(i,j,k)=0.0
+ vflxav(i,j,k)=0.0
+ diaflx(i,j,k)=0.0
+c
+ do ktr= 1,ntracr
+ tracer(i,j,k,1,ktr)=0.0
+ tracer(i,j,k,2,ktr)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l)+1)
+ ubavg(i,j,1)=0.0
+ ubavg(i,j,2)=0.0
+ ubavg(i,j,3)=0.0
+ utotm (i,j)=0.0
+ uflux (i,j)=0.0
+ uflux2(i,j)=0.0
+ uflux3(i,j)=0.0
+ uja(i,j)=0.0
+ ujb(i,j)=0.0
+c
+ do k=1,kk
+ uflx(i,j,k)=0.0
+ u(i,j,k,1)=0.0
+ u(i,j,k,2)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+c
+ call xctilr(ubavg, 1, 3, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(utotm, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux2, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux3, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uja, 1, 1, nbdy,nbdy, halo_us)
+ call xctilr(ujb, 1, 1, nbdy,nbdy, halo_us)
+ call xctilr(uflx, 1, kk, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(u, 1,2*kk, nbdy,nbdy, halo_us) ! note scalar
+c
+!$OMP PARALLEL DO PRIVATE(i,l,j,k)
+!$OMP& SCHEDULE(STATIC)
+ do i=1,ii
+ do l=1,jsp(i)
+ do j=max(1,jfp(i,l)),min(jj,jlp(i,l)+1)
+ vbavg(i,j,1)=0.0
+ vbavg(i,j,2)=0.0
+ vbavg(i,j,3)=0.0
+ vtotm (i,j)=0.0
+ vflux (i,j)=0.0
+ vflux2(i,j)=0.0
+ vflux3(i,j)=0.0
+ via(i,j)=0.0
+ vib(i,j)=0.0
+c
+ do k=1,kk
+ vflx(i,j,k)=0.0
+ v(i,j,k,1)=0.0
+ v(i,j,k,2)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+c
+ call xctilr(vbavg, 1, 3, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vtotm, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux2, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux3, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(via, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vib, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflx, 1, kk, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(v, 1,2*kk, nbdy,nbdy, halo_vs) ! note scalar
+c
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> May 1997 - extended list of variables set to 'huge' on land
+c> Oct. 1999 - added code that defines the vertical distribution of dp0
+c> used in hybgen
+c> Jan. 2000 - added mapflg logic for different projections
+c> Feb. 2000 - added dp00f for logorithmic z-level spacing
+c> Mar. 2000 - added dp00s for sigma-spacing in shallow water
+c> May 2000 - conversion to SI units (still wrong corio)
+c> Feb. 2001 - removed rotated grid option
+c> Jan. 2002 - more flexible Z-sigma-Z vertical configuration
+c> Jan. 2002 - all grids now via array input
diff --git a/src_2.2.18_3_one/TEST/geopar.mai b/src_2.2.18_3_one/TEST/geopar.mai
new file mode 100755
index 0000000..bb19af2
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/geopar.mai
@@ -0,0 +1,324 @@
+Message-ID: <5137.1056811895@ajax.nrlssc.navy.mil>
+Mime-Version: 1.0
+Subject: geopar.f
+Content-Type: multipart/mixed; boundary="-"
+
+This is a MIME encoded message. Decode it with "munpack"
+or any other MIME reading software. Mpack/munpack is available
+via anonymous FTP in ftp.andrew.cmu.edu:pub/mpack/
+---
+Content-Type: application/octet-stream; name="geopar.f"
+Content-Transfer-Encoding: base64
+Content-Disposition: inline; filename="geopar.f"
+Content-MD5: lttE8MhnKQkI5OEBcTxVMA==
+
+ICAgICAgc3Vicm91dGluZSBnZW9wYXIKICAgICAgdXNlIG1vZF94YyAgISBIWUNPTSBjb21t
+dW5pY2F0aW9uIGludGVyZmFjZQogICAgICB1c2UgbW9kX3phICAhIEhZQ09NIEkvTyBpbnRl
+cmZhY2UKYwpjIC0tLSBzZXQgdXAgbW9kZWwgcGFyYW1ldGVycyByZWxhdGVkIHRvIGdlb2dy
+YXBoeQpjCmMgLS0tIGh5Y29tIHZlcnNpb24gMi4xCmMKICAgICAgaW1wbGljaXQgbm9uZQpj
+CiAgICAgIGluY2x1ZGUgJ2NvbW1vbl9ibG9ja3MuaCcKYwogICAgICByZWFsICAgICAgZHAw
+a2YsZHBtLGRwbXMsZHMwa2YsZHNtLGRzbXMKICAgICAgcmVhbCAgICAgIGhtaW5hLGhtaW5i
+LGhtYXhhLGhtYXhiCiAgICAgIGludGVnZXIgICBpLGlvcyxqLGssa3RyLGwKICAgICAgY2hh
+cmFjdGVyIHByZWFtYmwoNSkqNzksY2xpbmUqODAKYwogICAgICByZWFsICAgICAgIGFzcG1h
+eAogICAgICBwYXJhbWV0ZXIgKGFzcG1heD0yLjApICAhIG1heGltdW0gZ3JpZCBhc3BlY3Qg
+cmF0aW8gZm9yIGRpZmZ1c2lvbgoqICAgICBwYXJhbWV0ZXIgKGFzcG1heD0xLjApICAhIGln
+bm9yZSAgZ3JpZCBhc3BlY3QgcmF0aW8gaW4gIGRpZmZ1c2lvbgpjCmMgLS0tIHJlYWQgZ3Jp
+ZCBsb2NhdGlvbixzcGFjaW5nLGNvcmlvbGlzIGFycmF5cwpjCiAgICAgIGlmICAgICAobW5w
+cm9jLmVxLjEpIHRoZW4gICEgLmIgZmlsZSBmcm9tIDFzdCB0aWxlIG9ubHkKICAgICAgICB3
+cml0ZSAobHAsJygzYSknKSAnIHJlYWRpbmcgZ3JpZCBmaWxlIGZyb20gJywKICAgICAmICAg
+ICAgICAgICAgICAgICAgICBmbG5tZ3JkKDE6bGVuX3RyaW0oZmxubWdyZCkpLCcuW2FiXScK
+ICAgICAgICBvcGVuICh1bml0PTksZmlsZT1mbG5tZ3JkKDE6bGVuX3RyaW0oZmxubWdyZCkp
+Ly8nLmInLAogICAgICYgICAgICAgIHN0YXR1cz0nb2xkJykKICAgICAgZW5kaWYKICAgICAg
+Y2FsbCB4Y3N5bmMoZmx1c2hfbHApCiAgICAgIGNhbGwgemFnZXRjKGNsaW5lLGlvcywgOSkK
+ICAgICAgaWYgICAgIChpb3MubmUuMCkgdGhlbgogICAgICAgIGlmICAgICAobW5wcm9jLmVx
+LjEpIHRoZW4KICAgICAgICAgIHdyaXRlKGxwLCcoLyBhLGk0LGk5IC8pJykKICAgICAmICAg
+ICAgJ0kvTyBlcnJvciBmcm9tIHphZ2V0YywgaXVuaXQsaW9zID0gJyw5LGlvcwogICAgICAg
+IGVuZGlmICExc3QgdGlsZQogICAgICAgIGNhbGwgeGNzdG9wKCcoZ2VvcGFyKScpCiAgICAg
+ICAgICAgICAgIHN0b3AgJyhnZW9wYXIpJwogICAgICBlbmRpZgogICAgICByZWFkKGNsaW5l
+LCopIGkKYwogICAgICBjYWxsIHphZ2V0YyhjbGluZSxpb3MsIDkpCiAgICAgIGlmICAgICAo
+aW9zLm5lLjApIHRoZW4KICAgICAgICBpZiAgICAgKG1ucHJvYy5lcS4xKSB0aGVuCiAgICAg
+ICAgICB3cml0ZShscCwnKC8gYSxpNCxpOSAvKScpCiAgICAgJiAgICAgICdJL08gZXJyb3Ig
+ZnJvbSB6YWdldGMsIGl1bml0LGlvcyA9ICcsOSxpb3MKICAgICAgICBlbmRpZiAhMXN0IHRp
+bGUKICAgICAgICBjYWxsIHhjc3RvcCgnKGdlb3BhciknKQogICAgICAgICAgICAgICBzdG9w
+ICcoZ2VvcGFyKScKICAgICAgZW5kaWYKICAgICAgcmVhZCAoY2xpbmUsKikgagpjCiAgICAg
+IGlmICAgICAoaS5uZS5pdGRtIC5vci4gai5uZS5qdGRtKSB0aGVuCiAgICAgICAgaWYgICAg
+IChtbnByb2MuZXEuMSkgdGhlbgogICAgICAgIHdyaXRlKGxwLCcoLyBhIC8pJykKICAgICAm
+ICAgICdlcnJvciAtIHdyb25nIGFycmF5IHNpemUgaW4gZ3JpZCBmaWxlJwogICAgICAgIGVu
+ZGlmCiAgICAgICAgY2FsbCB4Y3N0b3AoJyhnZW9wYXIpJykKICAgICAgICAgICAgICAgc3Rv
+cCAnKGdlb3BhciknCiAgICAgIGVuZGlmCiAgICAgIGNhbGwgemFnZXRjKGNsaW5lLGlvcywg
+OSkKICAgICAgaWYgICAgIChpb3MubmUuMCkgdGhlbgogICAgICAgIGlmICAgICAobW5wcm9j
+LmVxLjEpIHRoZW4KICAgICAgICAgIHdyaXRlKGxwLCcoLyBhLGk0LGk5IC8pJykKICAgICAm
+ICAgICAgJ0kvTyBlcnJvciBmcm9tIHphZ2V0YywgaXVuaXQsaW9zID0gJyw5LGlvcwogICAg
+ICAgIGVuZGlmICExc3QgdGlsZQogICAgICAgIGNhbGwgeGNzdG9wKCcoZ2VvcGFyKScpCiAg
+ICAgICAgICAgICAgIHN0b3AgJyhnZW9wYXIpJwogICAgICBlbmRpZgogICAgICBpZiAgICAg
+KG1ucHJvYy5lcS4xKSB0aGVuCiAgICAgIHdyaXRlIChscCwnKGEpJykgY2xpbmUoMTpsZW5f
+dHJpbShjbGluZSkpCiAgICAgIGVuZGlmCiAgICAgIHJlYWQgKGNsaW5lLCopIG1hcGZsZwpj
+CiAgICAgIGNhbGwgemFpb3BmKGZsbm1ncmQoMTpsZW5fdHJpbShmbG5tZ3JkKSkvLycuYScs
+J29sZCcsIDkpCmMKICAgICAgZG8gaz0gMSwxMQogICAgICAgIGNhbGwgemFnZXRjKGNsaW5l
+LGlvcywgOSkKICAgICAgICBpZiAgICAgKGlvcy5uZS4wKSB0aGVuCiAgICAgICAgICBpZiAg
+ICAgKG1ucHJvYy5lcS4xKSB0aGVuCiAgICAgICAgICAgIHdyaXRlKGxwLCcoLyBhLGk0LGk5
+IC8pJykKICAgICAmICAgICAgICAnSS9PIGVycm9yIGZyb20gemFnZXRjLCBpdW5pdCxpb3Mg
+PSAnLDksaW9zCiAgICAgICAgICBlbmRpZiAhMXN0IHRpbGUKICAgICAgICAgIGNhbGwgeGNz
+dG9wKCcoZ2VvcGFyKScpCiAgICAgICAgICAgICAgICAgc3RvcCAnKGdlb3BhciknCiAgICAg
+ICAgZW5kaWYKICAgICAgICBpID0gaW5kZXgoY2xpbmUsJz0nKQogICAgICAgIHJlYWQgKGNs
+aW5lKGkrMTopLCopIGhtaW5iLGhtYXhiCiAgICAgICAgaWYgICAgIChtbnByb2MuZXEuMSkg
+dGhlbgogICAgICAgIHdyaXRlIChscCwnKGEpJykgY2xpbmUoMTpsZW5fdHJpbShjbGluZSkp
+CiAgICAgICAgZW5kaWYKICAgICAgICBjYWxsIHhjc3luYyhmbHVzaF9scCkKYwogICAgICAg
+IGlmICAgICAoay5lcS4xKSB0aGVuCiAgICAgICAgICBjYWxsIHphaW9yZChwbG9uLCBpcCwu
+ZmFsc2UuLCBobWluYSxobWF4YSwgOSkKICAgICAgICBlbHNlaWYgKGsuZXEuMikgdGhlbgog
+ICAgICAgICAgY2FsbCB6YWlvcmQocGxhdCwgaXAsLmZhbHNlLiwgaG1pbmEsaG1heGEsIDkp
+CiAgICAgICAgICBkbyBpPSAxLDcKICAgICAgICAgICAgY2FsbCB6YWdldGMoY2xpbmUsaW9z
+LCA5KQogICAgICAgICAgICBpZiAgICAgKGlvcy5uZS4wKSB0aGVuCiAgICAgICAgICAgICAg
+aWYgICAgIChtbnByb2MuZXEuMSkgdGhlbgogICAgICAgICAgICAgICAgd3JpdGUobHAsJygv
+IGEsaTQsaTkgLyknKQogICAgICYgICAgICAgICAgICAnSS9PIGVycm9yIGZyb20gemFnZXRj
+LCBpdW5pdCxpb3MgPSAnLDksaW9zCiAgICAgICAgICAgICAgZW5kaWYgITFzdCB0aWxlCiAg
+ICAgICAgICAgICAgY2FsbCB4Y3N0b3AoJyhnZW9wYXIpJykKICAgICAgICAgICAgICAgICAg
+ICAgc3RvcCAnKGdlb3BhciknCiAgICAgICAgICAgIGVuZGlmCiAgICAgICAgICAgIGNhbGwg
+emFpb3NrKDkpCiAgICAgICAgICBlbmRkbwogICAgICAgIGVsc2VpZiAoay5lcS4zKSB0aGVu
+CiAgICAgICAgICBjYWxsIHphaW9yZChzY3B4LCBpcCwuZmFsc2UuLCBobWluYSxobWF4YSwg
+OSkKICAgICAgICBlbHNlaWYgKGsuZXEuNCkgdGhlbgogICAgICAgICAgY2FsbCB6YWlvcmQo
+c2NweSwgaXAsLmZhbHNlLiwgaG1pbmEsaG1heGEsIDkpCiAgICAgICAgZWxzZWlmIChrLmVx
+LjUpIHRoZW4KICAgICAgICAgIGNhbGwgemFpb3JkKHNjcXgsIGlxLC5mYWxzZS4sIGhtaW5h
+LGhtYXhhLCA5KQogICAgICAgIGVsc2VpZiAoay5lcS42KSB0aGVuCiAgICAgICAgICBjYWxs
+IHphaW9yZChzY3F5LCBpcSwuZmFsc2UuLCBobWluYSxobWF4YSwgOSkKICAgICAgICBlbHNl
+aWYgKGsuZXEuNykgdGhlbgogICAgICAgICAgY2FsbCB6YWlvcmQoc2N1eCwgaXUsLmZhbHNl
+LiwgaG1pbmEsaG1heGEsIDkpCiAgICAgICAgZWxzZWlmIChrLmVxLjgpIHRoZW4KICAgICAg
+ICAgIGNhbGwgemFpb3JkKHNjdXksIGl1LC5mYWxzZS4sIGhtaW5hLGhtYXhhLCA5KQogICAg
+ICAgIGVsc2VpZiAoay5lcS45KSB0aGVuCiAgICAgICAgICBjYWxsIHphaW9yZChzY3Z4LCBp
+diwuZmFsc2UuLCBobWluYSxobWF4YSwgOSkKICAgICAgICBlbHNlaWYgKGsuZXEuMTApIHRo
+ZW4KICAgICAgICAgIGNhbGwgemFpb3JkKHNjdnksIGl2LC5mYWxzZS4sIGhtaW5hLGhtYXhh
+LCA5KQogICAgICAgIGVsc2UKICAgICAgICAgIGNhbGwgemFpb3JkKGNvcmlvLGlxLC5mYWxz
+ZS4sIGhtaW5hLGhtYXhhLCA5KQogICAgICAgIGVuZGlmCmMKICAgICAgICBpZiAgICAgKGFi
+cyhobWluYS1obWluYikuZ3QuYWJzKGhtaW5iKSoxLmUtNCAub3IuCiAgICAgJiAgICAgICAg
+ICBhYnMoaG1heGEtaG1heGIpLmd0LmFicyhobWF4YikqMS5lLTQgICAgICkgdGhlbgogICAg
+ICAgICAgaWYgICAgIChtbnByb2MuZXEuMSkgdGhlbgogICAgICAgICAgd3JpdGUobHAsJygv
+IGEgLyBhLDFwM2UxNC42IC8gYSwxcDNlMTQuNiAvKScpCiAgICAgJiAgICAgICdlcnJvciAt
+IC5hIGFuZCAuYiBmaWxlcyBub3QgY29uc2lzdGVudDonLAogICAgICYgICAgICAnLmEsLmIg
+bWluID0gJyxobWluYSxobWluYixobWluYS1obWluYiwKICAgICAmICAgICAgJy5hLC5iIG1h
+eCA9ICcsaG1heGEsaG1heGIsaG1heGEtaG1heGIKICAgICAgICAgIGVuZGlmCiAgICAgICAg
+ICBjYWxsIHhjc3RvcCgnKGdlb3BhciknKQogICAgICAgICAgICAgICAgIHN0b3AgJyhnZW9w
+YXIpJwogICAgICAgIGVuZGlmCiAgICAgIGVuZGRvCmMKICAgICAgY2FsbCB6YWlvY2woOSkK
+ICAgICAgaWYgICAgIChtbnByb2MuZXEuMSkgdGhlbiAgISAuYiBmaWxlIGZyb20gMXN0IHRp
+bGUgb25seQogICAgICAgIGNsb3NlKHVuaXQ9OSkKICAgICAgZW5kaWYKYwogICAgICBpZiAo
+aXRlc3QuZ3QuMCAuYW5kLiBqdGVzdC5ndC4wKSB0aGVuCiAgICAgICAgaT1pdGVzdAogICAg
+ICAgIGo9anRlc3QKICAgICAgICB3cml0ZSAobHAsJygvIGEsMmk1LGEsZjguMyxhLGYxMi45
+LDJmMTAuMi8pJykKICAgICAmICAgJyBpLGo9JyxpK2kwLGorajAsCiAgICAgJiAgICcgcGxh
+dD0nLHBsYXQoaSxqKSwKICAgICAmICAgJyBjb3JpbyxzY3V4LHZ5PScsY29yaW8oaSxqKSxz
+Y3V4KGksaiksc2N2eShpLGopCiAgICAgIGVuZGlmCiAgICAgIGNhbGwgeGNzeW5jKGZsdXNo
+X2xwKQpjCmMgLS0tIHJlYWQgYmFzaW4gZGVwdGggYXJyYXkKYwogICAgICBpZiAgICAgKG1u
+cHJvYy5lcS4xKSB0aGVuICAhIC5iIGZpbGUgZnJvbSAxc3QgdGlsZSBvbmx5CiAgICAgICAg
+d3JpdGUgKGxwLCcoM2EpJykgJyByZWFkaW5nIGJhdGh5bWV0cnkgZmlsZSBmcm9tICcsCiAg
+ICAgJiAgICAgICAgICAgICAgICAgICAgZmxubWRlcCgxOmxlbl90cmltKGZsbm1kZXApKSwn
+LlthYl0nCiAgICAgICAgb3BlbiAodW5pdD05LGZpbGU9ZmxubWRlcCgxOmxlbl90cmltKGZs
+bm1kZXApKS8vJy5iJywKICAgICAmICAgICAgICBzdGF0dXM9J29sZCcpCiAgICAgICAgcmVh
+ZCAoICAgICA5LCcoYTc5KScpICBwcmVhbWJsCiAgICAgIGVuZGlmCiAgICAgIGNhbGwgeGNz
+eW5jKGZsdXNoX2xwKQogICAgICBjYWxsIHphZ2V0YyhjbGluZSxpb3MsIDkpCiAgICAgIGlm
+ICAgICAoaW9zLm5lLjApIHRoZW4KICAgICAgICBpZiAgICAgKG1ucHJvYy5lcS4xKSB0aGVu
+CiAgICAgICAgICB3cml0ZShscCwnKC8gYSxpNCxpOSAvKScpCiAgICAgJiAgICAgICdJL08g
+ZXJyb3IgZnJvbSB6YWdldGMsIGl1bml0LGlvcyA9ICcsOSxpb3MKICAgICAgICBlbmRpZiAh
+MXN0IHRpbGUKICAgICAgICBjYWxsIHhjc3RvcCgnKGdlb3BhciknKQogICAgICAgICAgICAg
+ICBzdG9wICcoZ2VvcGFyKScKICAgICAgZW5kaWYKICAgICAgaSA9IGluZGV4KGNsaW5lLCc9
+JykKICAgICAgcmVhZCAoY2xpbmUoaSsxOiksKikgICBobWluYixobWF4YgogICAgICBpZiAg
+ICAgKG1ucHJvYy5lcS4xKSB0aGVuICAhIC5iIGZpbGUgZnJvbSAxc3QgdGlsZSBvbmx5CiAg
+ICAgICAgY2xvc2UodW5pdD05KQogICAgICAgIHdyaXRlIChscCwnKC8oMXgsYSkpJykgcHJl
+YW1ibCxjbGluZQogICAgICBlbmRpZgpjCiAgICAgIGNhbGwgemFpb3BmKGZsbm1kZXAoMTps
+ZW5fdHJpbShmbG5tZGVwKSkvLycuYScsJ29sZCcsIDkpCiAgICAgIGNhbGwgemFpb3JkKGRl
+cHRocyxpcCwuZmFsc2UuLCBobWluYSxobWF4YSwgOSkKICAgICAgY2FsbCB6YWlvY2woOSkK
+YwogICAgICBpZiAgICAgKGFicyhobWluYS1obWluYikuZ3QuYWJzKGhtaW5iKSoxLmUtNCAu
+b3IuCiAgICAgJiAgICAgICAgYWJzKGhtYXhhLWhtYXhiKS5ndC5hYnMoaG1heGIpKjEuZS00
+ICAgICApIHRoZW4KICAgICAgICBpZiAgICAgKG1ucHJvYy5lcS4xKSB0aGVuCiAgICAgICAg
+d3JpdGUobHAsJygvIGEgLyBhLDFwM2UxNC42IC8gYSwxcDNlMTQuNiAvKScpCiAgICAgJiAg
+ICAnZXJyb3IgLSAuYSBhbmQgLmIgZmlsZXMgbm90IGNvbnNpc3RlbnQ6JywKICAgICAmICAg
+ICcuYSwuYiBtaW4gPSAnLGhtaW5hLGhtaW5iLGhtaW5hLWhtaW5iLAogICAgICYgICAgJy5h
+LC5iIG1heCA9ICcsaG1heGEsaG1heGIsaG1heGEtaG1heGIKICAgICAgICBlbmRpZgogICAg
+ICAgIGNhbGwgeGNzdG9wKCcoZ2VvcGFyKScpCiAgICAgICAgICAgICAgIHN0b3AgJyhnZW9w
+YXIpJwogICAgICBlbmRpZgpjCiEkT01QIFBBUkFMTEVMIERPIFBSSVZBVEUoaixpKQohJE9N
+UCYgICAgICAgICBTQ0hFRFVMRShTVEFUSUMsamJsaykKICAgICAgZG8gaj0gMSxqagogICAg
+ICAgIGRvIGk9IDEsaWkKICAgICAgICAgIGlmICAgICAoZGVwdGhzKGksaikuZ3QuMC41Kmh1
+Z2UpIHRoZW4KICAgICAgICAgICAgZGVwdGhzKGksaikgPSAwLjAKICAgICAgICAgIGVuZGlm
+CiAgICAgICAgZW5kZG8KICAgICAgZW5kZG8KYwpjIC0tLSBkZXRlcm1pbmUgZG8tbG9vcCBs
+aW1pdHMgZm9yIHUsdixwLHEgcG9pbnRzLCBhbmQgdXBkYXRlIGhhbG8gZm9yIGRlcHRocwog
+ICAgICBjYWxsIGJpZ3JpZChkZXB0aHMsIG1hcGZsZywgdXRpbDEsdXRpbDIsdXRpbDMpCmNj
+YyAgICAgIGNhbGwgcHJ0bXNrKGlwLGRlcHRocyx1dGlsMSxpZG0saWksamosMC4wLDEuMCwK
+Y2NjICAgICAmICAgICAnYm90dG9tIGRlcHRoIChtKScpCmMKYyAgICAgbm93IHNhZmUgdG8g
+YXBwbHkgaGFsbyB0byBhcnJheXMuCmMKICAgICAgdmxhbmQgPSAxLjAKICAgICAgY2FsbCB4
+Y3RpbHIocGxvbiwgIDEsMSwgbmJkeSxuYmR5LCBoYWxvX3BzKQogICAgICBjYWxsIHhjdGls
+cihwbGF0LCAgMSwxLCBuYmR5LG5iZHksIGhhbG9fcHMpCiAgICAgIGNhbGwgeGN0aWxyKGNv
+cmlvLCAxLDEsIG5iZHksbmJkeSwgaGFsb19xcykKICAgICAgY2FsbCB4Y3RpbHIoc2NweCwg
+IDEsMSwgbmJkeSxuYmR5LCBoYWxvX3BzKQogICAgICBjYWxsIHhjdGlscihzY3B5LCAgMSwx
+LCBuYmR5LG5iZHksIGhhbG9fcHMpCiAgICAgIGNhbGwgeGN0aWxyKHNjcXgsICAxLDEsIG5i
+ZHksbmJkeSwgaGFsb19xcykKICAgICAgY2FsbCB4Y3RpbHIoc2NxeSwgIDEsMSwgbmJkeSxu
+YmR5LCBoYWxvX3FzKQogICAgICBjYWxsIHhjdGlscihzY3V4LCAgMSwxLCBuYmR5LG5iZHks
+IGhhbG9fdXMpCiAgICAgIGNhbGwgeGN0aWxyKHNjdXksICAxLDEsIG5iZHksbmJkeSwgaGFs
+b191cykKICAgICAgY2FsbCB4Y3RpbHIoc2N2eCwgIDEsMSwgbmJkeSxuYmR5LCBoYWxvX3Zz
+KQogICAgICBjYWxsIHhjdGlscihzY3Z5LCAgMSwxLCBuYmR5LG5iZHksIGhhbG9fdnMpCiAg
+ICAgIHZsYW5kID0gMC4wCmMKYyAtLS0gYXJlYSBvZiBncmlkIGNlbGxzIChsZW5ndGggeCB3
+aWR0aCkgYXQgdSx2LHAscSBwb2ludHMgcmVzcC4KYwoqKioqKiohJE9NUCBQQVJBTExFTCBE
+TyBQUklWQVRFKGosaSkKKioqKioqISRPTVAmICAgICAgICAgU0NIRURVTEUoU1RBVElDLGpi
+bGspCiAgICAgIGRvIGo9MS1uYmR5LGpqK25iZHkKICAgICAgICBkbyBpPTEtbmJkeSxpaStu
+YmR5CiAgICAgICAgICBzY3UyKGksaik9c2N1eChpLGopKnNjdXkoaSxqKQogICAgICAgICAg
+c2N2MihpLGopPXNjdngoaSxqKSpzY3Z5KGksaikKICAgICAgICAgIHNjcDIoaSxqKT1zY3B4
+KGksaikqc2NweShpLGopCiAgICAgICAgICBzY3EyKGksaik9c2NxeChpLGopKnNjcXkoaSxq
+KQpjCiAgICAgICAgICBzY3V4aShpLGopPTEuMC9tYXgoc2N1eChpLGopLGVwc2lsKQogICAg
+ICAgICAgc2N2eWkoaSxqKT0xLjAvbWF4KHNjdnkoaSxqKSxlcHNpbCkKICAgICAgICAgIHNj
+cDJpKGksaik9MS4wL21heChzY3AyKGksaiksZXBzaWwpCiAgICAgICAgICBzY3EyaShpLGop
+PTEuMC9tYXgoc2NxMihpLGopLGVwc2lsKQpjCmMgLS0tICAgICBsYXJnZXN0IGdyaWQgc3Bh
+Y2luZyAod2l0aGluIGxpbWl0cykgdXNlZCBpbiBhbGwgZGlmZnVzaW9uCmMgLS0tICAgICBj
+b2VmZmljaWVudHM6IG1pbihtYXgoc2M/eCxzYz95KSxzYz94KmFzcG1heCxzYz95KmFzcG1h
+eCkKICAgICAgICAgIGFzcHV4KGksaik9bWluKG1heChzY3V4KGksaiksc2N1eShpLGopKSwK
+ICAgICAmICAgICAgICAgICAgICAgICAgIG1pbihzY3V4KGksaiksc2N1eShpLGopKSphc3Bt
+YXgpCiAgICAgJiAgICAgICAgICAgICAgIC9tYXgoc2N1eChpLGopLGVwc2lsKQogICAgICAg
+ICAgYXNwdXkoaSxqKT1taW4obWF4KHNjdXgoaSxqKSxzY3V5KGksaikpLAogICAgICYgICAg
+ICAgICAgICAgICAgICAgbWluKHNjdXgoaSxqKSxzY3V5KGksaikpKmFzcG1heCkKICAgICAm
+ICAgICAgICAgICAgICAgL21heChzY3V5KGksaiksZXBzaWwpCiAgICAgICAgICBhc3B2eChp
+LGopPW1pbihtYXgoc2N2eChpLGopLHNjdnkoaSxqKSksCiAgICAgJiAgICAgICAgICAgICAg
+ICAgICBtaW4oc2N2eChpLGopLHNjdnkoaSxqKSkqYXNwbWF4KQogICAgICYgICAgICAgICAg
+ICAgICAvbWF4KHNjdngoaSxqKSxlcHNpbCkKICAgICAgICAgIGFzcHZ5KGksaik9bWluKG1h
+eChzY3Z4KGksaiksc2N2eShpLGopKSwKICAgICAmICAgICAgICAgICAgICAgICAgIG1pbihz
+Y3Z4KGksaiksc2N2eShpLGopKSphc3BtYXgpCiAgICAgJiAgICAgICAgICAgICAgIC9tYXgo
+c2N2eShpLGopLGVwc2lsKQpjCiAgICAgICAgICB1dGlsMShpLGopPWRlcHRocyhpLGopKnNj
+cDIoaSxqKQogICAgICAgIGVuZGRvCiAgICAgIGVuZGRvCmMKICAgICAgY2FsbCB4Y3N1bShh
+dmdib3QsIHV0aWwxLGlwKQogICAgICBjYWxsIHhjc3VtKGFyZWEsICAgc2NwMiwgaXApCiAg
+ICAgIGF2Z2JvdD1hdmdib3QvYXJlYQogICAgICBpZiAgICAgKG1ucHJvYy5lcS4xKSB0aGVu
+CiAgICAgIHdyaXRlIChscCwnKC9hLGY5LjEsLTEycCxmMTAuMiknKQogICAgICYgICAgICAg
+JyBtZWFuIGJhc2luIGRlcHRoIChtKSBhbmQgYXJlYSAoMTBeNiBrbV4yKTonLAogICAgICYg
+ICAgICAgYXZnYm90LGFyZWEKICAgICAgZW5kaWYKICAgICAgY2FsbCB4Y3N5bmMoZmx1c2hf
+bHApCmMKYyAtLS0gbG9nb3JpdGhtaWMgay1kZXBlbmRlbmNlIG9mIGRwMCAoZGVlcCB6J3Mp
+CiAgICAgIGRwMDAgPW9uZW0qZHAwMAogICAgICBkcDAweD1vbmVtKmRwMDB4CiAgICAgIGlm
+ICAgICAoaXNvcHljKSB0aGVuCiAgICAgICAgZHAwaygxKT10aGttaW4qb25lbQogICAgICBl
+bHNlCiAgICAgICAgZHAwaygxKT1kcDAwCiAgICAgIGVuZGlmCiAgICAgIGRwMGtwKDEpPWRw
+MGsoMSkrb25lbQogICAgICBkcG0gID0gZHAwaygxKSpxb25lbQogICAgICBkcG1zID0gZHBt
+CiAgICAgIGlmICAgICAobW5wcm9jLmVxLjEpIHRoZW4KICAgICAgd3JpdGUobHAsKikKICAg
+ICAgd3JpdGUobHAsMTM1KSAxLGRwMGsoMSkqcW9uZW0sZHBtLGRwbXMKICAgICAgZW5kaWYK
+IDEzNSAgZm9ybWF0KCdkcDBrKCcsaTIsJykgPScsZjcuMiwnIG0nLAogICAgICYgICAgICAg
+ICAgJyAgICB0aGtucyA9JyxmNy4yLCcgbScsCiAgICAgJiAgICAgICAgICAnICAgIGRlcHRo
+ID0nLGY4LjIsJyBtJykKICAgICAgY2FsbCB4Y3N5bmMoZmx1c2hfbHApCmMKICAgICAgZHAw
+a2Y9MS4wCiAgICAgIGRvIGs9MixrawogICAgICAgIGRwMGtmPWRwMGtmKmRwMDBmCiAgICAg
+ICAgaWYgICAgIChrLmxlLm5oeWJyZCkgdGhlbgogICAgICAgICAgZHAwayhrKT1taW4oZHAw
+MCpkcDBrZixkcDAweCkKICAgICAgICBlbHNlCiAgICAgICAgICBkcDBrKGspPTAuMAogICAg
+ICAgIGVuZGlmCiAgICAgICAgZHAwa3Aoayk9ZHAwayhrKStvbmVtCiAgICAgICAgZHBtICA9
+IGRwMGsoaykqcW9uZW0KICAgICAgICBkcG1zID0gZHBtcyArIGRwbQogICAgICAgIGlmICAg
+ICAobW5wcm9jLmVxLjEpIHRoZW4KICAgICAgICB3cml0ZShscCwxMzUpIGssZHAwayhrKSpx
+b25lbSxkcG0sZHBtcwogICAgICAgIGVuZGlmCiAgICAgICAgaWYgICAgIChtbnByb2MuZXEu
+LTk5KSB0aGVuICAhIGJ1Z2ZpeCB0aGF0IHByZXZlbnRzIG9wdGltaXphdGlvbgogICAgICAg
+ICAgd3JpdGUoNiwqKSAnZ2VvcGFyOiBkcDBrZiAgPSAnLGRwMGtmLCAgICBtbnByb2MKICAg
+ICAgICAgIHdyaXRlKDYsKikgJ2dlb3BhcjogZHAwayAgID0gJyxkcDBrKGspLGssbW5wcm9j
+CiAgICAgICAgZW5kaWYKICAgICAgICBjYWxsIHhjc3luYyhmbHVzaF9scCkKICAgICAgZW5k
+ZG8KYwpjIC0tLSBsb2dvcml0aG1pYyBrLWRlcGVuZGVuY2Ugb2YgZHMwIChzaGFsbG93IHot
+cykKICAgICAgZHMwMCA9b25lbSpkczAwCiAgICAgIGRzMDB4PW9uZW0qZHMwMHgKICAgICAg
+aWYgICAgIChpc29weWMpIHRoZW4KICAgICAgICBkczBrKDEpPXRoa21pbipvbmVtCiAgICAg
+IGVsc2UKICAgICAgICBkczBrKDEpPWRzMDAKICAgICAgZW5kaWYKICAgICAgZHNtICA9IGRz
+MGsoMSkqcW9uZW0KICAgICAgZHNtcyA9IGRzbQogICAgICBpZiAgICAgKG1ucHJvYy5lcS4x
+KSB0aGVuCiAgICAgIHdyaXRlKGxwLCopCiAgICAgIHdyaXRlKGxwLDEzMCkgMSxkczBrKDEp
+KnFvbmVtLGRzbSxkc21zCiAgICAgIGVuZGlmCiAxMzAgIGZvcm1hdCgnZHMwaygnLGkyLCcp
+ID0nLGY3LjIsJyBtJywKICAgICAmICAgICAgICAgICcgICAgdGhrbnMgPScsZjcuMiwnIG0n
+LAogICAgICYgICAgICAgICAgJyAgICBkZXB0aCA9JyxmOC4yLCcgbScpCiAgICAgIGNhbGwg
+eGNzeW5jKGZsdXNoX2xwKQpjCiAgICAgIGRzMGtmPTEuMAogICAgICBkbyBrPTIsbnNpZ21h
+CiAgICAgICAgZHMwa2Y9ZHMwa2YqZHMwMGYKICAgICAgICBkczBrKGspPW1pbihkczAwKmRz
+MGtmLGRzMDB4KQogICAgICAgIGRzbSAgPSBkczBrKGspKnFvbmVtCiAgICAgICAgZHNtcyA9
+IGRzbXMgKyBkc20KICAgICAgICBpZiAgICAgKG1ucHJvYy5lcS4xKSB0aGVuCiAgICAgICAg
+d3JpdGUobHAsMTMwKSBrLGRzMGsoaykqcW9uZW0sZHNtLGRzbXMKICAgICAgICBlbmRpZgog
+ICAgICAgIGlmICAgICAobW5wcm9jLmVxLi05OSkgdGhlbiAgISBidWdmaXggdGhhdCBwcmV2
+ZW50cyBvcHRpbWl6YXRpb24KICAgICAgICAgIHdyaXRlKDYsKikgJ2dlb3BhcjogZHMwa2Yg
+ID0gJyxkczBrZiwgICAgbW5wcm9jCiAgICAgICAgICB3cml0ZSg2LCopICdnZW9wYXI6IGRz
+MGsgICA9ICcsZHMwayhrKSxrLG1ucHJvYwogICAgICAgIGVuZGlmCiAgICAgICAgY2FsbCB4
+Y3N5bmMoZmx1c2hfbHApCiAgICAgIGVuZGRvCiAgICAgIGlmICAgICAobW5wcm9jLmVxLjEp
+IHRoZW4KICAgICAgd3JpdGUobHAsKikKICAgICAgZW5kaWYKYwpjIC0tLSBzaWdtYS1kZXB0
+aCBzY2FsZSBmYWN0b3JzCiAgICAgIGRvIGs9MSxuc2lnbWEKICAgICAgICBkc3NrKGspPWRz
+MGsoaykvZHNtcyAgISBvbmVtICogZnJhY3Rpb24gb2YgZGVwdGhzIGluIHNpZ21hIGxheWVy
+IGsKICAgICAgZW5kZG8KICAgICAgZG8gaz0gbnNpZ21hKzEsa2RtCiAgICAgICAgZHMwayhr
+KT1kcDBrKGspCiAgICAgICAgZHNzayhrKT0wLjAgICAgICAgICAgICEgdGhlc2UgbGF5ZXJz
+IGFyZSB6ZXJvIGluIHNpZ21hIG1vZGUKICAgICAgZW5kZG8KYwpjIC0tLSBpbml0aWFsaXpl
+IHNvbWUgYXJyYXlzCmMgLS0tIHNldCBkZXB0aHUsZHB1LHV0b3RuLHBnZngsZGVwdGh2LGRw
+dix2dG90bixwZ2Z5IHRvIHplcm8gZXZlcnl3aGVyZSwKYyAtLS0gc28gdGhhdCB0aGV5IGNh
+biBiZSB1c2VkIGF0ICJsYXRlcmFsIG5laWdoYm9ycyIgb2YgdSBhbmQgdiBwb2ludHMuCmMg
+LS0tIHNpbWlsYXJseSBmb3IgcGJvdCxkcCBhdCBuZWlnaGJvcnMgb2YgcSBwb2ludHMuCmMK
+ISRPTVAgUEFSQUxMRUwgRE8gUFJJVkFURShqLGksayxrdHIpCiEkT01QJiAgICAgICAgIFND
+SEVEVUxFKFNUQVRJQyxqYmxrKQogICAgICBkbyBqPTEtbmJkeSxqaituYmR5CiAgICAgICAg
+ZG8gaT0xLW5iZHksaWkrbmJkeQogICAgICAgICAgcCggICAgIGksaiwxKT0wLjAKICAgICAg
+ICAgIHB1KCAgICBpLGosMSk9MC4wCiAgICAgICAgICBwdiggICAgaSxqLDEpPTAuMAogICAg
+ICAgICAgdXRvdG4oIGksaik9MC4wCiAgICAgICAgICB2dG90biggaSxqKT0wLjAKICAgICAg
+ICAgIHBnZngoICBpLGopPTAuMAogICAgICAgICAgcGdmeSggIGksaik9MC4wCiAgICAgICAg
+ICBkZXB0aHUoaSxqKT0wLjAKICAgICAgICAgIGRlcHRodihpLGopPTAuMAogICAgICAgICAg
+cGJvdCggIGksaik9MC4wCmMKICAgICAgICAgIHViYXZnKCBpLGosMSk9aHVnZQogICAgICAg
+ICAgdWJhdmcoIGksaiwyKT1odWdlCiAgICAgICAgICB1YmF2ZyggaSxqLDMpPWh1Z2UKICAg
+ICAgICAgIHZiYXZnKCBpLGosMSk9aHVnZQogICAgICAgICAgdmJhdmcoIGksaiwyKT1odWdl
+CiAgICAgICAgICB2YmF2ZyggaSxqLDMpPWh1Z2UKICAgICAgICAgIHV0b3RtKCBpLGopPWh1
+Z2UKICAgICAgICAgIHZ0b3RtKCBpLGopPWh1Z2UKICAgICAgICAgIHVmbHV4KCBpLGopPWh1
+Z2UKICAgICAgICAgIHZmbHV4KCBpLGopPWh1Z2UKICAgICAgICAgIHVmbHV4MShpLGopPWh1
+Z2UKICAgICAgICAgIHZmbHV4MShpLGopPWh1Z2UKICAgICAgICAgIHVmbHV4MihpLGopPWh1
+Z2UKICAgICAgICAgIHZmbHV4MihpLGopPWh1Z2UKICAgICAgICAgIHVmbHV4MyhpLGopPWh1
+Z2UKICAgICAgICAgIHZmbHV4MyhpLGopPWh1Z2UKICAgICAgICAgIHVqYSggICBpLGopPWh1
+Z2UKICAgICAgICAgIHVqYiggICBpLGopPWh1Z2UKICAgICAgICAgIHZpYSggICBpLGopPWh1
+Z2UKICAgICAgICAgIHZpYiggICBpLGopPWh1Z2UKICAgICAgICAgIGRvIGs9MSxrawogICAg
+ICAgICAgICBkcCggaSxqLGssMSk9MC4wCiAgICAgICAgICAgIGRwKCBpLGosaywyKT0wLjAK
+ICAgICAgICAgICAgZHB1KGksaixrLDEpPTAuMAogICAgICAgICAgICBkcHUoaSxqLGssMik9
+MC4wCiAgICAgICAgICAgIGRwdihpLGosaywxKT0wLjAKICAgICAgICAgICAgZHB2KGksaixr
+LDIpPTAuMApjCiAgICAgICAgICAgIHUoICBpLGosaywxKT1odWdlCiAgICAgICAgICAgIHUo
+ICBpLGosaywyKT1odWdlCiAgICAgICAgICAgIHYoICBpLGosaywxKT1odWdlCiAgICAgICAg
+ICAgIHYoICBpLGosaywyKT1odWdlCmMKICAgICAgICAgICAgdWZseCggIGksaixrKT1odWdl
+CiAgICAgICAgICAgIHZmbHgoICBpLGosayk9aHVnZQpjCiAgICAgICAgICAgIGRwYXYoICBp
+LGosayk9MC4wCiAgICAgICAgICAgIHVmbHhhdihpLGosayk9MC4wCiAgICAgICAgICAgIHZm
+bHhhdihpLGosayk9MC4wCiAgICAgICAgICAgIGRpYWZseChpLGosayk9MC4wCmMKICAgICAg
+ICAgICAgZG8ga3RyPSAxLG50cmFjcgogICAgICAgICAgICAgIHRyYWNlcihpLGosaywxLGt0
+cik9MC4wCiAgICAgICAgICAgICAgdHJhY2VyKGksaixrLDIsa3RyKT0wLjAKICAgICAgICAg
+ICAgZW5kZG8KICAgICAgICAgIGVuZGRvCiAgICAgICAgZW5kZG8KICAgICAgZW5kZG8KISRP
+TVAgRU5EIFBBUkFMTEVMIERPCmMKISRPTVAgUEFSQUxMRUwgRE8gUFJJVkFURShqLGwsaSxr
+KQohJE9NUCYgICAgICAgICBTQ0hFRFVMRShTVEFUSUMsamJsaykKICAgICAgZG8gaj0xLGpq
+CiAgICAgICAgZG8gbD0xLGlzcChqKQogICAgICAgICAgZG8gaT1tYXgoMSxpZnAoaixsKSks
+bWluKGlpLGlscChqLGwpKzEpCiAgICAgICAgICAgIHViYXZnKGksaiwxKT0wLjAKICAgICAg
+ICAgICAgdWJhdmcoaSxqLDIpPTAuMAogICAgICAgICAgICB1YmF2ZyhpLGosMyk9MC4wCiAg
+ICAgICAgICAgIHV0b3RtIChpLGopPTAuMAogICAgICAgICAgICB1Zmx1eCAoaSxqKT0wLjAK
+ICAgICAgICAgICAgdWZsdXgyKGksaik9MC4wCiAgICAgICAgICAgIHVmbHV4MyhpLGopPTAu
+MAogICAgICAgICAgICB1amEoaSxqKT0wLjAKICAgICAgICAgICAgdWpiKGksaik9MC4wCmMK
+ICAgICAgICAgICAgZG8gaz0xLGtrCiAgICAgICAgICAgICAgdWZseChpLGosayk9MC4wCiAg
+ICAgICAgICAgICAgdShpLGosaywxKT0wLjAKICAgICAgICAgICAgICB1KGksaixrLDIpPTAu
+MAogICAgICAgICAgICBlbmRkbwogICAgICAgICAgZW5kZG8KICAgICAgICBlbmRkbwogICAg
+ICBlbmRkbwpjCiAgICAgIGNhbGwgeGN0aWxyKHViYXZnLCAgICAxLCAgIDMsIG5iZHksbmJk
+eSwgaGFsb191cykgICEgbm90ZSBzY2FsYXIKICAgICAgY2FsbCB4Y3RpbHIodXRvdG0sICAg
+IDEsICAgMSwgbmJkeSxuYmR5LCBoYWxvX3VzKSAgISBub3RlIHNjYWxhcgogICAgICBjYWxs
+IHhjdGlscih1Zmx1eCwgICAgMSwgICAxLCBuYmR5LG5iZHksIGhhbG9fdXMpICAhIG5vdGUg
+c2NhbGFyCiAgICAgIGNhbGwgeGN0aWxyKHVmbHV4MiwgICAxLCAgIDEsIG5iZHksbmJkeSwg
+aGFsb191cykgICEgbm90ZSBzY2FsYXIKICAgICAgY2FsbCB4Y3RpbHIodWZsdXgzLCAgIDEs
+ICAgMSwgbmJkeSxuYmR5LCBoYWxvX3VzKSAgISBub3RlIHNjYWxhcgogICAgICBjYWxsIHhj
+dGlscih1amEsICAgICAgMSwgICAxLCBuYmR5LG5iZHksIGhhbG9fdXMpCiAgICAgIGNhbGwg
+eGN0aWxyKHVqYiwgICAgICAxLCAgIDEsIG5iZHksbmJkeSwgaGFsb191cykKICAgICAgY2Fs
+bCB4Y3RpbHIodWZseCwgICAgIDEsICBraywgbmJkeSxuYmR5LCBoYWxvX3VzKSAgISBub3Rl
+IHNjYWxhcgogICAgICBjYWxsIHhjdGlscih1LCAgICAgICAgMSwyKmtrLCBuYmR5LG5iZHks
+IGhhbG9fdXMpICAhIG5vdGUgc2NhbGFyCmMKISRPTVAgUEFSQUxMRUwgRE8gUFJJVkFURShp
+LGwsaixrKQohJE9NUCYgICAgICAgICBTQ0hFRFVMRShTVEFUSUMpCiAgICAgIGRvIGk9MSxp
+aQogICAgICAgIGRvIGw9MSxqc3AoaSkKICAgICAgICAgIGRvIGo9bWF4KDEsamZwKGksbCkp
+LG1pbihqaixqbHAoaSxsKSsxKQogICAgICAgICAgICB2YmF2ZyhpLGosMSk9MC4wCiAgICAg
+ICAgICAgIHZiYXZnKGksaiwyKT0wLjAKICAgICAgICAgICAgdmJhdmcoaSxqLDMpPTAuMAog
+ICAgICAgICAgICB2dG90bSAoaSxqKT0wLjAKICAgICAgICAgICAgdmZsdXggKGksaik9MC4w
+CiAgICAgICAgICAgIHZmbHV4MihpLGopPTAuMAogICAgICAgICAgICB2Zmx1eDMoaSxqKT0w
+LjAKICAgICAgICAgICAgdmlhKGksaik9MC4wCiAgICAgICAgICAgIHZpYihpLGopPTAuMApj
+CiAgICAgICAgICAgIGRvIGs9MSxrawogICAgICAgICAgICAgIHZmbHgoaSxqLGspPTAuMAog
+ICAgICAgICAgICAgIHYoaSxqLGssMSk9MC4wCiAgICAgICAgICAgICAgdihpLGosaywyKT0w
+LjAKICAgICAgICAgICAgZW5kZG8KICAgICAgICAgIGVuZGRvCiAgICAgICAgZW5kZG8KICAg
+ICAgZW5kZG8KYwogICAgICBjYWxsIHhjdGlscih2YmF2ZywgICAgMSwgICAzLCBuYmR5LG5i
+ZHksIGhhbG9fdnMpICAhIG5vdGUgc2NhbGFyCiAgICAgIGNhbGwgeGN0aWxyKHZ0b3RtLCAg
+ICAxLCAgIDEsIG5iZHksbmJkeSwgaGFsb192cykgICEgbm90ZSBzY2FsYXIKICAgICAgY2Fs
+bCB4Y3RpbHIodmZsdXgsICAgIDEsICAgMSwgbmJkeSxuYmR5LCBoYWxvX3ZzKSAgISBub3Rl
+IHNjYWxhcgogICAgICBjYWxsIHhjdGlscih2Zmx1eDIsICAgMSwgICAxLCBuYmR5LG5iZHks
+IGhhbG9fdnMpICAhIG5vdGUgc2NhbGFyCiAgICAgIGNhbGwgeGN0aWxyKHZmbHV4MywgICAx
+LCAgIDEsIG5iZHksbmJkeSwgaGFsb192cykgICEgbm90ZSBzY2FsYXIKICAgICAgY2FsbCB4
+Y3RpbHIodmlhLCAgICAgIDEsICAgMSwgbmJkeSxuYmR5LCBoYWxvX3ZzKSAgISBub3RlIHNj
+YWxhcgogICAgICBjYWxsIHhjdGlscih2aWIsICAgICAgMSwgICAxLCBuYmR5LG5iZHksIGhh
+bG9fdnMpICAhIG5vdGUgc2NhbGFyCiAgICAgIGNhbGwgeGN0aWxyKHZmbHgsICAgICAxLCAg
+a2ssIG5iZHksbmJkeSwgaGFsb192cykgICEgbm90ZSBzY2FsYXIKICAgICAgY2FsbCB4Y3Rp
+bHIodiwgICAgICAgIDEsMipraywgbmJkeSxuYmR5LCBoYWxvX3ZzKSAgISBub3RlIHNjYWxh
+cgpjCiAgICAgIHJldHVybgogICAgICBlbmQKYwpjCmM+IFJldmlzaW9uIGhpc3Rvcnk6CmM+
+CmM+IE1heSAgMTk5NyAtIGV4dGVuZGVkIGxpc3Qgb2YgdmFyaWFibGVzIHNldCB0byAnaHVn
+ZScgb24gbGFuZApjPiBPY3QuIDE5OTkgLSBhZGRlZCBjb2RlIHRoYXQgZGVmaW5lcyB0aGUg
+dmVydGljYWwgZGlzdHJpYnV0aW9uIG9mIGRwMApjPiAgICAgICAgICAgICB1c2VkIGluIGh5
+YmdlbgpjPiBKYW4uIDIwMDAgLSBhZGRlZCBtYXBmbGcgbG9naWMgZm9yIGRpZmZlcmVudCBw
+cm9qZWN0aW9ucwpjPiBGZWIuIDIwMDAgLSBhZGRlZCBkcDAwZiBmb3IgbG9nb3JpdGhtaWMg
+ei1sZXZlbCBzcGFjaW5nCmM+IE1hci4gMjAwMCAtIGFkZGVkIGRwMDBzIGZvciBzaWdtYS1z
+cGFjaW5nIGluIHNoYWxsb3cgd2F0ZXIKYz4gTWF5ICAyMDAwIC0gY29udmVyc2lvbiB0byBT
+SSB1bml0cyAoc3RpbGwgd3JvbmcgY29yaW8pCmM+IEZlYi4gMjAwMSAtIHJlbW92ZWQgcm90
+YXRlZCBncmlkIG9wdGlvbgpjPiBKYW4uIDIwMDIgLSBtb3JlIGZsZXhpYmxlIFotc2lnbWEt
+WiB2ZXJ0aWNhbCBjb25maWd1cmF0aW9uCmM+IEphbi4gMjAwMiAtIGFsbCBncmlkcyBub3cg
+dmlhIGFycmF5IGlucHV0Cg==
+
+-----
diff --git a/src_2.2.18_3_one/TEST/patch.input b/src_2.2.18_3_one/TEST/patch.input
new file mode 100755
index 0000000..fc5e6c3
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/patch.input
@@ -0,0 +1,332 @@
+ npes npe mpe idm jdm ibig jbig nreg minsea maxsea avesea
+ 781 36 32 4500 3298 250 104 3 1 13010 11465
+
+ispt( 1) = 0 0 0 0 0 0 0 0
+ 1105 1230 1355 1480 1605 0 0 0
+ 0 0 0 0 0 2817 3067 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0
+iipe( 1) = 0 0 0 0 0 0 0 0
+ 125 125 125 125 224 0 0 0
+ 0 0 0 0 0 250 199 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0
+ispt( 2) = 0 0 0 0 0 0 0 0
+ 1111 1236 1361 1486 1611 1736 1861 1986
+ 2111 2361 2611 0 2800 2925 3050 3175
+ 3300 0 0 0 0 0 0 0
+ 0 0 0 0
+iipe( 2) = 0 0 0 0 0 0 0 0
+ 125 125 125 125 125 125 125 125
+ 250 250 49 0 125 125 125 125
+ 115 0 0 0 0 0 0 0
+ 0 0 0 0
+ispt( 3) = 1 0 0 0 0 0 0 0
+ 1007 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2876 3001
+ 3126 3251 3376 3501 3751 4001 0 0
+ 4454 0 0 0
+iipe( 3) = 50 0 0 0 0 0 0 0
+ 119 125 125 125 125 125 125 125
+ 125 125 125 125 125 250 125 125
+ 125 125 125 250 250 86 0 0
+ 47 0 0 0
+ispt( 4) = 1 126 376 626 876 1001 1126 1251
+ 1376 1501 1626 1751 1876 2001 2126 2251
+ 2376 2501 2626 2751 2876 3001 3126 3251
+ 3376 3501 3626 3751 3876 4001 4126 4376
+ 0 0 0 0
+iipe( 4) = 125 250 250 250 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 250 125
+ 0 0 0 0
+ispt( 5) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 4126 4251 4376
+iipe( 5) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125
+ispt( 6) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 4126 4251 4376
+iipe( 6) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125
+ispt( 7) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 4126 4251 4376
+iipe( 7) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125
+ispt( 8) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 4126 4251 4376
+iipe( 8) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125
+ispt( 9) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 4126 4251 4376
+iipe( 9) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125
+ispt( 10) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2626 2876 3001
+ 3126 3251 3376 3501 3626 3751 3876 4001
+ 4126 4251 4376 0
+iipe( 10) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 250 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 0
+ispt( 11) = 1 126 251 376 501 751 1001 1126
+ 1251 1376 1501 1626 1751 1876 2001 2126
+ 2251 2376 2501 2626 2876 3001 3126 3251
+ 3376 3501 3626 3751 3876 4001 4126 4251
+ 4376 0 0 0
+iipe( 11) = 125 125 125 125 250 250 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 250 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 0 0 0
+ispt( 12) = 1 126 251 376 0 0 935 1001
+ 1126 1251 1376 1501 1626 1751 1876 2001
+ 2126 2251 2376 2501 2626 0 2959 3084
+ 3209 3334 3459 3584 3709 0 3974 4126
+ 4251 4376 0 0
+iipe( 12) = 125 125 125 169 0 0 66 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 73 0 125 125
+ 125 125 125 125 74 0 152 125
+ 125 125 0 0
+ispt( 13) = 1 126 251 376 501 768 876 1001
+ 1126 1251 1376 1501 1626 1751 1876 2001
+ 2126 2251 2376 2501 2626 0 0 3062
+ 3126 3251 3376 3501 3626 0 0 4009
+ 4126 4251 4376 0
+iipe( 13) = 125 125 125 125 203 108 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 73 0 0 64
+ 125 125 125 125 125 0 0 117
+ 125 125 125 0
+ispt( 14) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 0 0 0
+ 3088 3250 3376 3501 3626 0 0 4059
+ 4126 4251 4376 0
+iipe( 14) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 0 0 0
+ 162 126 125 125 125 0 0 67
+ 125 125 125 0
+ispt( 15) = 1 126 251 418 626 751 876 1001
+ 1126 1251 1376 1501 1626 1751 1876 2001
+ 2126 2251 2376 2501 0 0 2936 3126
+ 3251 3376 3501 3626 0 0 4062 4126
+ 4251 4376 0 0
+iipe( 15) = 125 125 167 208 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 109 0 0 190 125
+ 125 125 125 102 0 0 64 125
+ 125 125 0 0
+ispt( 16) = 1 126 251 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2251 2376 2501 2751 2876 3001
+ 3126 3251 3376 3626 0 0 4110 4251
+ 4376 0 0 0
+iipe( 16) = 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 250 125 125 125
+ 125 125 250 74 0 0 141 125
+ 125 0 0 0
+ispt( 17) = 1 188 0 396 508 633 758 883
+ 1008 1133 1258 1383 1508 1633 1758 1883
+ 2008 2133 2258 2383 2508 2633 2758 2883
+ 3008 3133 3258 0 0 0 0 4040
+ 4251 4376 0 0
+iipe( 17) = 187 182 0 112 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 125 125 0 0 0 0 211
+ 125 125 0 0
+ispt( 18) = 0 134 0 397 626 751 876 1001
+ 1126 1251 1376 1501 1626 1751 1876 2001
+ 2126 2376 2501 2626 2751 2876 3001 3126
+ 3252 0 0 0 3996 0 4193 4376
+ 0 0 0 0
+iipe( 18) = 0 111 0 229 125 125 125 125
+ 125 125 125 125 125 125 125 125
+ 250 125 125 125 125 125 125 126
+ 157 0 0 0 86 0 183 110
+ 0 0 0 0
+ispt( 19) = 0 0 0 0 575 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 1876
+ 2001 2126 2376 2626 2751 2876 3001 3126
+ 3251 3376 0 3702 3952 0 4176 0
+ 0 0 0 0
+iipe( 19) = 0 0 0 0 51 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 250 250 125 125 125 125 125
+ 125 118 0 250 76 0 113 0
+ 0 0 0 0
+ispt( 20) = 0 0 0 0 547 751 876 1001
+ 1126 1251 1376 1501 1626 1751 1876 2001
+ 0 0 0 2590 2715 2840 2965 3090
+ 3215 3340 3465 3715 3840 0 0 0
+ 0 0 0 0
+iipe( 20) = 0 0 0 0 204 125 125 125
+ 125 125 125 125 125 125 125 98
+ 0 0 0 125 125 125 125 125
+ 125 125 250 125 240 0 0 0
+ 0 0 0 0
+ispt( 21) = 0 0 0 0 582 832 957 1082
+ 1207 1332 1457 1582 1707 1832 1957 0
+ 0 0 0 0 2650 2751 2876 3001
+ 3126 3251 3376 3501 3751 4001 0 0
+ 0 0 0 0
+iipe( 21) = 0 0 0 0 250 125 125 125
+ 125 125 125 125 125 125 69 0
+ 0 0 0 0 101 125 125 125
+ 125 125 125 250 250 97 0 0
+ 0 0 0 0
+ispt( 22) = 0 0 0 0 0 0 802 927
+ 1052 1177 1302 1427 1552 1677 1802 1927
+ 0 0 0 0 0 2691 2876 3001
+ 3126 3251 3376 3501 0 0 3958 0
+ 0 0 0 0
+iipe( 22) = 0 0 0 0 0 0 125 125
+ 125 125 125 125 125 125 125 115
+ 0 0 0 0 0 185 125 125
+ 125 125 125 125 0 0 13 0
+ 0 0 0 0
+ispt( 23) = 0 0 0 0 0 0 774 947
+ 1126 1251 1376 1501 1626 1751 1876 0
+ 0 0 2579 2835 2954 3079 3204 3329
+ 3454 3704 0 0 0 0 0 0
+ 0 0 0 0
+iipe( 23) = 0 0 0 0 0 0 173 179
+ 125 125 125 125 125 125 165 0
+ 0 0 214 119 125 125 125 125
+ 250 125 0 0 0 0 0 0
+ 0 0 0 0
+ispt( 24) = 0 0 0 0 0 0 795 1001
+ 1126 1251 1376 1501 1626 1751 1876 0
+ 0 0 0 2567 0 2835 2876 3001
+ 3126 3251 3376 3501 3626 0 0 0
+ 0 0 0 0
+iipe( 24) = 0 0 0 0 0 0 206 125
+ 125 125 125 125 125 125 107 0
+ 0 0 0 44 0 41 125 125
+ 125 125 125 125 230 0 0 0
+ 0 0 0 0
+ispt( 25) = 0 0 0 0 0 0 0 0
+ 1036 1251 1376 1626 1751 0 0 0
+ 0 2559 0 2763 2929 3126 3251 3376
+ 3501 3751 0 0 0 0 0 0
+ 0 0 0 0
+iipe( 25) = 0 0 0 0 0 0 0 0
+ 215 125 250 125 169 0 0 0
+ 0 110 0 166 197 125 125 125
+ 250 139 0 0 0 0 0 0
+ 0 0 0 0
+ispt( 26) = 0 0 0 0 0 0 0 0
+ 0 1126 1376 1626 0 0 0 0
+ 0 2542 2763 2876 3126 3251 3376 3501
+ 3626 0 0 0 0 0 0 0
+ 0 0 0 0
+iipe( 26) = 0 0 0 0 0 0 0 0
+ 0 250 250 233 0 0 0 0
+ 0 151 113 250 125 125 125 125
+ 175 0 0 0 0 0 0 0
+ 0 0 0 0
+ispt( 27) = 0 0 0 0 0 0 830 1001
+ 1126 1251 1376 0 0 0 0 0
+ 0 0 0 2529 2648 2876 0 3260
+ 3376 3501 3626 0 3847 0 0 0
+ 0 0 0 0
+iipe( 27) = 0 0 0 0 0 0 171 125
+ 125 125 83 0 0 0 0 0
+ 0 0 0 119 228 192 0 116
+ 125 125 91 0 99 0 0 0
+ 0 0 0 0
+ispt( 28) = 0 0 0 0 0 0 788 913
+ 1038 1163 1288 1413 0 0 0 0
+ 0 0 0 2517 2626 2782 3001 0
+ 3291 3376 3501 3626 3751 0 0 0
+ 0 0 0 0
+iipe( 28) = 0 0 0 0 0 0 125 125
+ 125 125 125 223 0 0 0 0
+ 0 0 0 109 156 219 72 0
+ 85 125 125 125 212 0 0 0
+ 0 0 0 0
+ispt( 29) = 0 0 0 0 0 701 826 951
+ 1076 1201 1326 1451 1576 0 0 0
+ 0 0 0 0 2529 2626 2914 3001
+ 0 3331 3376 3501 3626 3751 3876 0
+ 0 0 0 0
+iipe( 29) = 0 0 0 0 0 125 125 125
+ 125 125 125 125 94 0 0 0
+ 0 0 0 0 97 241 87 87
+ 0 45 125 125 125 125 88 0
+ 0 0 0 0
+ispt( 30) = 0 0 0 0 0 701 876 1001
+ 1126 1251 1376 1501 1626 0 0 0
+ 0 0 0 0 2749 2999 3249 3477
+ 3624 3749 3874 0 0 0 0 0
+ 0 0 0 0
+iipe( 30) = 0 0 0 0 0 175 125 125
+ 125 125 125 125 97 0 0 0
+ 0 0 0 0 250 250 228 147
+ 125 125 125 0 0 0 0 0
+ 0 0 0 0
+ispt( 31) = 0 0 0 0 0 633 751 876
+ 1001 1126 1251 1376 1501 1626 0 0
+ 0 0 0 0 2721 2971 3221 3346
+ 3471 3596 3721 3846 0 0 0 0
+ 0 0 0 0
+iipe( 31) = 0 0 0 0 0 118 125 125
+ 125 125 125 125 125 161 0 0
+ 0 0 0 0 250 250 125 125
+ 125 125 125 168 0 0 0 0
+ 0 0 0 0
+ispt( 32) = 0 0 0 376 501 626 751 876
+ 1001 1126 1251 1376 1501 1626 1751 0
+ 0 0 0 0 0 2626 2751 2876
+ 3001 3126 3251 3376 3501 3626 3751 3876
+ 4001 0 0 0
+iipe( 32) = 0 0 0 125 125 125 125 125
+ 125 125 125 125 125 125 125 0
+ 0 0 0 0 0 125 125 125
+ 125 125 125 125 125 125 125 125
+ 125 0 0 0
+
+jspt( 1) = 1 104 207 310 413 516 619 722
+ 825 928 1031 1134 1237 1340 1443 1546
+ 1650 1754 1857 1960 2063 2166 2269 2372
+ 2475 2578 2681 2784 2887 2990 3093 3196
+jjpe( 1) = 103 103 103 103 103 103 103 103
+ 103 103 103 103 103 103 103 104
+ 104 103 103 103 103 103 103 103
+ 103 103 103 103 103 103 103 103
diff --git a/src_2.2.18_3_one/TEST/stmt_fns_test.f b/src_2.2.18_3_one/TEST/stmt_fns_test.f
new file mode 100755
index 0000000..90bc3ac
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/stmt_fns_test.f
@@ -0,0 +1,158 @@
+ program test
+ implicit none
+ real qthref
+c-----------------------------------------------------------------------------
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,kappafs
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real r,s,t,prs,ylat
+ integer kkf
+c
+ real ahalf,athird,afourth
+ parameter (ahalf =1./2.)
+ parameter (athird =1./3.)
+ parameter (afourth=1./4.)
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+csig0 real c1,c2,c3,c4,c5,c6,c7
+csig0 parameter (c1=-1.36471E-01, c2= 4.68181E-02, c3= 8.07004E-01,
+csig0& c4=-7.45353E-03, c5=-2.94418E-03,
+csig0& c6= 3.43570E-05, c7= 3.48658E-05)
+csig0 real pref
+csig0 parameter (pref=0.0)
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ real c1,c2,c3,c4,c5,c6,c7
+ parameter (c1= 9.77093E+00, c2=-2.26493E-02, c3= 7.89879E-01,
+ & c4=-6.43205E-03, c5=-2.62983E-03,
+ & c6= 2.75835E-05, c7= 3.15235E-05)
+ real pref
+ parameter (pref=2000.e4)
+c
+c --- coefficients for sigma-4 (based on Brydon & Sun fit)
+csig4 real c1,c2,c3,c4,c5,c6,c7
+csig4 parameter (c1= 1.92362E+01, c2=-8.82080E-02, c3= 7.73552E-01,
+csig4& c4=-5.46858E-03, c5=-2.31866E-03,
+csig4& c6= 2.11306E-05, c7= 2.82474E-05)
+csig4 real pref
+csig4 parameter (pref=4000.e4)
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, 2/8/01
+ real, parameter, dimension(2) ::
+ & toff = (/ 0.0, 3.0 /)
+ & ,soff = (/ 34.0, 35.0 /)
+ & ,qt = (/ -2.89196E-01, -2.61829E-01 /)
+ & ,qs = (/ -1.08670E-01, -1.05131E-01 /)
+ & ,qtt = (/ 4.56626E-03, 4.29277E-03 /)
+ & ,qst = (/ 7.90504E-04, 7.71097E-04 /)
+ & ,qttt = (/ -3.03869E-05, -3.03869E-05 /)
+ & ,qpt = (/ 1.07106E-09, 1.00638E-09 /)
+ & ,qpst = (/ 1.41542E-11, 1.48599E-11 /)
+ & ,qptt = (/ -1.31384E-11, -1.31384E-11 /)
+c
+c --- auxiliary statements for finding root of 3rd degree polynomial
+ a0(s)=(c1+c3*s)/c6
+ a1(s)=(c2+c5*s)/c6
+ a2(s)=(c4+c7*s)/c6
+ cubq(s)=athird*a1(s)-(athird*a2(s))**2
+ cubr(r,s)=athird*(0.5*a1(s)*a2(s)-1.5*(a0(s)-r/c6))
+ & -(athird*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=athird*atan2(sqrt(max(0.,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (mil)
+c --- (friedrich-levitus 3rd degree polynomial fit)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (mil)
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.)*cubim(r,s)-athird*a2(s)
+c
+c --- salinity (mil) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729
+c --- kappaf1 used internally to simplify offsetting T and S.
+c --- always invoke via kappaf.
+ kappafs(ylat)=max(0.0,min(1.0,(ylat+30.0)/60.0))
+ kappaf1(t,s,prs,kkf)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*(qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) )
+ kappaf(t,s,prs,ylat)=
+ & kappafs(ylat) *
+ & kappaf1(max(-2.0,min(32.0,t))-toff(1),
+ & max(30.0,min(38.0,s))-soff(1),
+ & prs,1) +
+ & (1.0-kappafs(ylat))*
+ & kappaf1(max(-2.0,min(32.0,t))-toff(2),
+ & max(30.0,min(38.0,s))-soff(2),
+ & prs,2)
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c-----------------------------------------------------------------------------
+ qthref = 1.e3
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,0.e+7, 30.0) = ',
+ & kappaf( 0.0,35.0,0.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,0.e+7,-30.0) = ',
+ & kappaf( 0.0,35.0,0.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,0.e+7, 0.0) = ',
+ & kappaf( 0.0,35.0,0.e+7, 0.0)
+
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,4.e+7, 30.0) = ',
+ & kappaf( 0.0,35.0,4.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,4.e+7,-30.0) = ',
+ & kappaf( 0.0,35.0,4.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf( 0.0,35.0,4.e+7, 0.0) = ',
+ & kappaf( 0.0,35.0,4.e+7, 0.0)
+
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,0.e+7, 30.0) = ',
+ & kappaf( 3.0,34.0,0.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,0.e+7,-30.0) = ',
+ & kappaf( 3.0,34.0,0.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,0.e+7, 0.0) = ',
+ & kappaf( 3.0,34.0,0.e+7, 0.0)
+
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,4.e+7, 30.0) = ',
+ & kappaf( 3.0,34.0,4.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,4.e+7,-30.0) = ',
+ & kappaf( 3.0,34.0,4.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf( 3.0,34.0,4.e+7, 0.0) = ',
+ & kappaf( 3.0,34.0,4.e+7, 0.0)
+
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,0.e+7, 30.0) = ',
+ & kappaf(30.0,32.0,0.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,0.e+7,-30.0) = ',
+ & kappaf(30.0,32.0,0.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,0.e+7, 0.0) = ',
+ & kappaf(30.0,32.0,0.e+7, 0.0)
+
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,4.e+7, 30.0) = ',
+ & kappaf(30.0,32.0,4.e+7, 30.0)
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,4.e+7,-30.0) = ',
+ & kappaf(30.0,32.0,4.e+7,-30.0)
+ write(6,'(a,f9.4)') 'kappaf(30.0,32.0,4.e+7, 0.0) = ',
+ & kappaf(30.0,32.0,4.e+7, 0.0)
+ end
diff --git a/src_2.2.18_3_one/TEST/stmt_fns_test1.f b/src_2.2.18_3_one/TEST/stmt_fns_test1.f
new file mode 100755
index 0000000..90775d9
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/stmt_fns_test1.f
@@ -0,0 +1,115 @@
+ program test
+ implicit none
+ real qthref
+c-----------------------------------------------------------------------------
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real r,s,t,prs
+c
+ real ahalf,athird,afourth
+ parameter (ahalf =1./2.)
+ parameter (athird =1./3.)
+ parameter (afourth=1./4.)
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+csig0 real c1,c2,c3,c4,c5,c6,c7
+csig0 parameter (c1=-1.36471E-01, c2= 4.68181E-02, c3= 8.07004E-01,
+csig0& c4=-7.45353E-03, c5=-2.94418E-03,
+csig0& c6= 3.43570E-05, c7= 3.48658E-05)
+csig0 real pref
+csig0 parameter (pref=0.0)
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+ real c1,c2,c3,c4,c5,c6,c7
+ parameter (c1= 9.77093E+00, c2=-2.26493E-02, c3= 7.89879E-01,
+ & c4=-6.43205E-03, c5=-2.62983E-03,
+ & c6= 2.75835E-05, c7= 3.15235E-05)
+ real pref
+ parameter (pref=2000.e4)
+c
+c --- coefficients for sigma-4 (based on Brydon & Sun fit)
+csig4 real c1,c2,c3,c4,c5,c6,c7
+csig4 parameter (c1= 1.92362E+01, c2=-8.82080E-02, c3= 7.73552E-01,
+csig4& c4=-5.46858E-03, c5=-2.31866E-03,
+csig4& c6= 2.11306E-05, c7= 2.82474E-05)
+csig4 real pref
+csig4 parameter (pref=4000.e4)
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, 2/8/01
+ real toff,soff
+ parameter (toff=0.0,soff=34.0)
+c
+ real qt,qs,qtt,qst,qttt,qpt,qpst,qptt
+ parameter (qt =-2.89196E-01, qs =-1.08670E-01,
+ & qtt = 4.56626E-03, qst = 7.90504E-04,
+ & qttt=-3.03869E-05, qpt = 1.07106E-09,
+ & qpst= 1.41542E-11, qptt=-1.31384E-11)
+c
+c --- auxiliary statements for finding root of 3rd degree polynomial
+ a0(s)=(c1+c3*s)/c6
+ a1(s)=(c2+c5*s)/c6
+ a2(s)=(c4+c7*s)/c6
+ cubq(s)=athird*a1(s)-(athird*a2(s))**2
+ cubr(r,s)=athird*(0.5*a1(s)*a2(s)-1.5*(a0(s)-r/c6))
+ & -(athird*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=athird*atan2(sqrt(max(0.,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (mil)
+c --- (friedrich-levitus 3rd degree polynomial fit)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (mil)
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.)*cubim(r,s)-athird*a2(s)
+c
+c --- salinity (mil) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729
+c --- kappaf1 used internally to simplify offsetting T and S.
+c --- always invoke via kappaf.
+ kappaf1(t,s,prs)=(1.e-11*qthref)*(prs-pref)*
+ & ( s*( qs+t* qst ) +
+ & t*( qt+t*(qtt+t*qttt)+
+ & 0.5*(prs+pref)*(qpt+s*qpst+t*qptt) ) )
+ kappaf(t,s,prs)=kappaf1(max(-2.0,min(32.0,t))-toff,
+ & max(30.0,min(38.0,s))-soff,
+ & prs)
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c-----------------------------------------------------------------------------
+ qthref = 1.e3
+ write(6,*) 'kappaf( 0.0,35.0,0.e+7) = ',kappaf( 0.0,35.0,0.e+7)
+ write(6,*) 'kappaf( 3.0,34.0,0.e+7) = ',kappaf( 3.0,34.0,0.e+7)
+ write(6,*) 'kappaf(30.0,32.0,0.e+7) = ',kappaf(30.0,32.0,0.e+7)
+ write(6,*) 'kappaf( 0.0,35.0,2.e+7) = ',kappaf( 0.0,35.0,2.e+7)
+ write(6,*) 'kappaf( 3.0,34.0,2.e+7) = ',kappaf( 3.0,34.0,2.e+7)
+ write(6,*) 'kappaf(30.0,32.0,2.e+7) = ',kappaf(30.0,32.0,2.e+7)
+ write(6,*) 'kappaf( 0.0,35.0,4.e+7) = ',kappaf( 0.0,35.0,4.e+7)
+ write(6,*) 'kappaf( 3.0,34.0,4.e+7) = ',kappaf( 3.0,34.0,4.e+7)
+ write(6,*) 'kappaf(30.0,32.0,4.e+7) = ',kappaf(30.0,32.0,4.e+7)
+ end
diff --git a/src_2.2.18_3_one/TEST/test_all.com b/src_2.2.18_3_one/TEST/test_all.com
new file mode 100755
index 0000000..01fa17a
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_all.com
@@ -0,0 +1,30 @@
+#!/bin/csh
+#
+#@ job_name = test_all
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:15:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- run all test cases.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+foreach f ( test_xca test_xcl test_xcs test_xct test_zaio )
+ touch ${f}.log
+ /bin/rm ${f}.log
+ csh ${f}.com >& ${f}.log
+end
diff --git a/src_2.2.18_3_one/TEST/test_all_9.com b/src_2.2.18_3_one/TEST/test_all_9.com
new file mode 100755
index 0000000..9e39c52
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_all_9.com
@@ -0,0 +1,30 @@
+#!/bin/csh
+#
+#@ job_name = test_all_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:15:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- run all test cases.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+foreach f ( test_xca_9 test_xcl_9 test_xcs_9 test_xct_9 test_zaio_9 )
+ touch ${f}.log
+ /bin/rm ${f}.log
+ csh ${f}.com >& ${f}.log
+end
diff --git a/src_2.2.18_3_one/TEST/test_xca.com b/src_2.2.18_3_one/TEST/test_xca.com
new file mode 100755
index 0000000..62d57dc
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xca.com
@@ -0,0 +1,54 @@
+#!/bin/csh
+#
+#@ job_name = test_xca
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xcaget and xcaput, 1-d partitioning.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3x1.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x01 patch.input
+cat patch.input
+poe ./test_xca
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xca
+#
+# --- 1x3.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.01x03 patch.input
+cat patch.input
+poe ./test_xca
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xca
diff --git a/src_2.2.18_3_one/TEST/test_xca.f b/src_2.2.18_3_one/TEST/test_xca.f
new file mode 100755
index 0000000..902f0bc
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xca.f
@@ -0,0 +1,171 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+c test xcaget and xcaput.
+c
+ integer i,j,kbad,ksea,nrecl
+ real*4 depth(itdm,jtdm)
+ real aorig(itdm,jtdm),aotgt(itdm,jtdm)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & atrgt(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+ common/test/ aotgt ! required by xcaput
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+c
+c initialize.
+c
+ do j= 1,jtdm
+ do i= 1,itdm
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ aorig(i,j) = i + (j-1)*100
+ else
+ aorig(i,j) = 0.0
+ endif
+ aotgt(i,j) = 0.0
+ enddo
+ enddo
+c
+ do j= 1,jj
+ do i= 1,ii
+ atile(i,j) = aorig(i+i0,j+j0)
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'idm, jdm = ',idm, jdm
+ ksea = count( aorig(:,:).ne.0.0 )
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,*) 'aorig = ',aorig(1,1),aorig(1,2),
+ + aorig(2,1),aorig(2,2)
+ write(lp,*) 'atile = ',atile(1,1),atile(1,2),
+ + atile(2,1),atile(2,2)
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c xcaget onto one processor.
+c
+ call xcaget(aotgt,atile, 1)
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcaget(aotgt,atile, 1)'
+ kbad = count( aotgt(:,:).ne.aorig(:,:) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe1: arrays are identical'
+ else
+ write(lp,*) 'pe1: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+ if (mnproc.eq.2) then
+ kbad = count( aotgt(:,:).ne.0.0 )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe2: array is zero'
+ else
+ write(lp,*) 'pe1: array has ',kbad,' non-zeros'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c xcaput from one processor.
+c
+ call xcaput(aotgt,atrgt, 1)
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcaput(aotgt,atrgt, 1)'
+ kbad = count( atrgt(1:ii,1:jj) .ne. atile(1:ii,1:jj) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe1: arrays are identical'
+ else
+ write(lp,*) 'pe1: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+ if (mnproc.eq.2) then
+ write(lp,*) 'call xcaput(aotgt,atrgt, 1)'
+ kbad = count( atrgt(1:ii,1:jj) .ne. atile(1:ii,1:jj) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe2: arrays are identical'
+ else
+ write(lp,*) 'pe2: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c xcaget onto all processors.
+c
+ call xcaget(aotgt,atile, 0)
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcaget(aotgt,atile, 0)'
+ kbad = count( aotgt(:,:).ne.aorig(:,:) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe1: arrays are identical'
+ else
+ write(lp,*) 'pe1: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+ if (mnproc.eq.2) then
+ write(lp,*) 'call xcaget(aotgt,atile, 0)'
+ kbad = count( aotgt(:,:).ne.aorig(:,:) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe2: arrays are identical'
+ else
+ write(lp,*) 'pe2: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c xcaput from all processors.
+c
+ atrgt = 0.0
+ call xcaput(aotgt,atrgt, 0)
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcaput(aotgt,atrgt, 0)'
+ kbad = count( atrgt(1:ii,1:jj) .ne. atile(1:ii,1:jj) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe1: arrays are identical'
+ else
+ write(lp,*) 'pe1: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+ if (mnproc.eq.2) then
+ kbad = count( atrgt(1:ii,1:jj) .ne. atile(1:ii,1:jj) )
+ if (kbad.eq.0) then
+ write(lp,*) 'pe2: arrays are identical'
+ else
+ write(lp,*) 'pe2: arrays have ',kbad,' differing elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+ call xcstop('(normal)')
+ stop '(normal)'
+ end
diff --git a/src_2.2.18_3_one/TEST/test_xca_9.com b/src_2.2.18_3_one/TEST/test_xca_9.com
new file mode 100755
index 0000000..fc3fafd
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xca_9.com
@@ -0,0 +1,53 @@
+#!/bin/csh
+#
+#@ job_name = test_xca_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xcaget and xcaput, 2-d uniform or equal-ocean tiles.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3X3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03X03s patch.input
+cat patch.input
+poe ./test_xca
+#setenv NPES 9
+#mpprun -n $NPES ./test_xca
+#
+# --- 3x3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x03s patch.input
+cat patch.input
+poe ./test_xca
+#setenv NPES 9
+#mpprun -n $NPES ./test_xca
diff --git a/src_2.2.18_3_one/TEST/test_xcl.com b/src_2.2.18_3_one/TEST/test_xcl.com
new file mode 100755
index 0000000..f9cdf78
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcl.com
@@ -0,0 +1,54 @@
+#!/bin/csh
+#
+#@ job_name = test_xcl
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xclget, 1-d partitioning.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3x1.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x01 patch.input
+cat patch.input
+poe ./test_xcl
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xcl
+#
+# --- 1x3.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.01x03 patch.input
+cat patch.input
+poe ./test_xcl
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xcl
diff --git a/src_2.2.18_3_one/TEST/test_xcl.f b/src_2.2.18_3_one/TEST/test_xcl.f
new file mode 100755
index 0000000..0d027e4
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcl.f
@@ -0,0 +1,276 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+c test xclget.
+c
+ integer i,j,ksea,nrecl
+ real*4 depth(itdm,jtdm)
+ real aorig(itdm,jtdm)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ real aoi(jtdm),aoj(itdm),ati(jtdm),atj(itdm)
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+c
+c initialize.
+c
+ do j= 1,jtdm
+ do i= 1,itdm
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ aorig(i,j) = i + (j-1)*100
+ else
+ aorig(i,j) = 0.0
+ endif
+ enddo
+ enddo
+c
+ do j= 1,jj
+ do i= 1,ii
+ atile(i,j) = aorig(i+i0,j+j0)
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'idm, jdm = ',idm, jdm
+ ksea = count( aorig(:,:).ne.0.0 )
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,*) 'aorig = ',aorig(1,1),aorig(1,2),
+ + aorig(2,1),aorig(2,2)
+ write(lp,*) 'atile = ',atile(1,1),atile(1,2),
+ + atile(2,1),atile(2,2)
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c test.
+c
+ call xclget(ati,jtdm, atile,itdm/2,1,0,+1, 0)
+ call xxlget(aoi,jtdm, aorig,itdm/2,1,0,+1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(ati,jtdm, atile, itdm/2,1,0,+1)'
+ endif
+ call yycomp(aoi,ati,jtdm)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(ati,10, atile,itdm/2,jtdm/2-5,0,+1, 0)
+ call xxlget(aoi,10, aorig,itdm/2,jtdm/2-5,0,+1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(ati,10, atile, itdm/2,jtdm/2-5,0,+1)'
+ endif
+ call yycomp(aoi,ati,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(ati,jtdm, atile,itdm/2,jtdm,0,-1, 0)
+ call xxlget(aoi,jtdm, aorig,itdm/2,jtdm,0,-1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(ati,jtdm, atile, itdm/2,jtdm,0,-1)'
+ endif
+ call yycomp(aoi,ati,jtdm)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(ati,10, atile,itdm/2,jtdm/2+5,0,-1, 0)
+ call xxlget(aoi,10, aorig,itdm/2,jtdm/2+5,0,-1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(ati,10, atile, itdm/2,jtdm/2+5,0,-1)'
+ endif
+ call yycomp(aoi,ati,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,itdm, atile,1,jtdm/2,+1,0, 0)
+ call xxlget(aoj,itdm, aorig,1,jtdm/2,+1,0)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,itdm, atile, 1,jtdm/2,+1,0)'
+ endif
+ call yycomp(aoj,atj,itdm)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2-5,jtdm/2,+1,0, 0)
+ call xxlget(aoj,10, aorig,itdm/2-5,jtdm/2,+1,0)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2-5,jtdm/2,+1,0)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,itdm, atile,itdm,jtdm/2,-1,0, 0)
+ call xxlget(aoj,itdm, aorig,itdm,jtdm/2,-1,0)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,itdm, atile, itdm,jtdm/2,-1,0)'
+ endif
+ call yycomp(aoj,atj,itdm)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2+5,jtdm/2,-1,0, 0)
+ call xxlget(aoj,10, aorig,itdm/2+5,jtdm/2,-1,0)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2+5,jtdm/2,-1,0)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2+5,jtdm/2+5,-1,-1, 0)
+ call xxlget(aoj,10, aorig,itdm/2+5,jtdm/2+5,-1,-1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2+5,jtdm/2+5,-1,-1)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2+5,jtdm/2-5,-1,+1, 0)
+ call xxlget(aoj,10, aorig,itdm/2+5,jtdm/2-5,-1,+1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2+5,jtdm/2-5,-1,+1)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2-5,jtdm/2+5,+1,-1, 0)
+ call xxlget(aoj,10, aorig,itdm/2-5,jtdm/2+5,+1,-1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2-5,jtdm/2+5,+1,-1)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xclget(atj,10, atile,itdm/2-5,jtdm/2-5,+1,+1, 0)
+ call xxlget(aoj,10, aorig,itdm/2-5,jtdm/2-5,+1,+1)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xclget(atj,10, atile, itdm/2-5,jtdm/2-5,+1,+1)'
+ endif
+ call yycomp(aoj,atj,10)
+ if (mnproc.eq.1) then
+ call flush(lp)
+ endif
+c
+ call xcstop('(normal)')
+ stop '(normal)'
+ end
+ subroutine xxlget(aline,nl, a, i1,j1,ic,jc)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer nl,i1,j1,ic,jc
+ real aline(nl)
+ real a(itdm,jtdm)
+c
+c**********
+c*
+c 1) extracts the line a(i1:i1+(nl-1)*ic:ic,j1:j1+(nl-1)*jc:jc),
+c w.r.t. the 2-d grid.
+c
+c 2) ic and jc can each be -1, 0, or +1.
+c*
+c**********
+c
+ integer i
+c
+* write(lp,'(a,5i5)') 'xxlget - nl,i1,j1,ic,jc = ',nl,i1,j1,ic,jc
+ if (jc.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1+ic*(i-1),j1)
+* if (i.le.5) then
+* write(lp,'(a,3i5,f10.2)') 'xxlget - l,i,j,aline = ',
+* + i,i1+ic*(i-1),j1,aline(i)
+* endif
+ enddo
+ elseif (ic.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1,j1+jc*(i-1))
+* if (i.le.5) then
+* write(lp,'(a,3i5,f10.2)') 'xxlget - l,i,j,aline = ',
+* + i,i1,j1+jc*(i-1),aline(i)
+* endif
+ enddo
+ else
+ do i= 1,nl
+ aline(i) = a(i1+ic*(i-1),j1+jc*(i-1))
+* if (i.le.5) then
+* write(lp,'(a,3i5,f10.2)') 'xxlget - l,i,j,aline = ',
+* + i,i1+ic*(i-1),j1+jc*(i-1),
+* + aline(i)
+* endif
+ enddo
+ endif
+ return
+c end of xxlget.
+ end
+ subroutine yycomp(a,b,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer n
+ real a(n),b(n)
+c
+c**********
+c*
+c 1) tests if a and b are identical.
+c*
+c**********
+c
+ integer i,ierr
+c
+ ierr = 0
+ do 110 i= 1,n
+ if (a(i).ne.b(i)) then
+ if (mnproc.eq.1) then
+ write(lp,*) 'i,a,b = ',i,a(i),b(i)
+ endif
+ ierr = ierr + 1
+ endif
+ 110 continue
+ if (mnproc.eq.1) then
+ if (ierr.eq.0) then
+ write(lp,*) 'arrays are identical'
+ write(lp,*)
+ else
+ write(lp,*) 'arrays have ',ierr,' differing elements'
+ write(lp,*)
+ endif
+ endif
+ return
+c end of yycomp.
+ end
diff --git a/src_2.2.18_3_one/TEST/test_xcl_9.com b/src_2.2.18_3_one/TEST/test_xcl_9.com
new file mode 100755
index 0000000..01c93d9
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcl_9.com
@@ -0,0 +1,53 @@
+#!/bin/csh
+#
+#@ job_name = test_xcl_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xclget, 2-d uniform or equal-ocean tiles.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3X3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03X03s patch.input
+cat patch.input
+poe ./test_xcl
+#setenv NPES 9
+#mpprun -n $NPES ./test_xcl
+#
+# --- 3x3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x03s patch.input
+cat patch.input
+poe ./test_xcl
+#setenv NPES 9
+#mpprun -n $NPES ./test_xcl
diff --git a/src_2.2.18_3_one/TEST/test_xcs.com b/src_2.2.18_3_one/TEST/test_xcs.com
new file mode 100755
index 0000000..f901562
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcs.com
@@ -0,0 +1,54 @@
+#!/bin/csh
+#
+#@ job_name = test_xcs
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xcsum, 1-d partitioning.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3x1.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x01 patch.input
+cat patch.input
+poe ./test_xcs
+#setenv NPES 3
+#mpprun -n $NPES ./test_xcs
+#
+# --- 1x3.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.01x03 patch.input
+cat patch.input
+poe ./test_xcs
+#setenv NPES 3
+#mpprun -n $NPES ./test_xcs
diff --git a/src_2.2.18_3_one/TEST/test_xcs.f b/src_2.2.18_3_one/TEST/test_xcs.f
new file mode 100755
index 0000000..ecb2ee7
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcs.f
@@ -0,0 +1,310 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+c test xcsum.
+c
+ integer i,j,ksea,nrecl
+ integer morig(itdm,jtdm)
+ integer mtile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ real*4 depth(itdm,jtdm)
+ real aorig(itdm,jtdm)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ real amino,amint,amaxo,amaxt
+ real*8 sumo,sumt,sumjo(jtdm),sumjt(jtdm)
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+c
+c initialize.
+c
+ amino = 1.e30
+ amaxo = -1.e30
+ do j= 1,jtdm
+ do i= 1,itdm
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ morig(i,j) = 1
+ if (mod(j,2).eq.0) then
+ aorig(i,j) = i + (j-1)*100
+ else
+ aorig(i,j) = -i - (j-1)*100
+ endif
+ amino = min( amino, aorig(i,j) )
+ amaxo = max( amaxo, aorig(i,j) )
+ else
+ morig(i,j) = 0
+ aorig(i,j) = 0.0
+ endif
+ enddo
+ enddo
+c
+ amint = 1.e30
+ amaxt = -1.e30
+ do j= 1,jj
+ do i= 1,ii
+ atile(i,j) = aorig(i+i0,j+j0)
+ amint = min( amint, atile(i,j) )
+ amaxt = max( amaxt, atile(i,j) )
+ enddo
+ enddo
+c
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ if (i+i0.ge.1 .and. i+i0.le.itdm .and.
+ & j+j0.ge.1 .and. j+j0.le.jtdm ) then
+ mtile(i,j) = morig(i+i0,j+j0)
+ else
+ mtile(i,j) = 0
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'ii, jj = ',ii, jj
+ ksea = count( aorig(:,:).ne.0.0 )
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,*) 'aorig = ',aorig(1,1),aorig(1,2),
+ + aorig(2,1),aorig(2,2)
+ write(lp,*) 'atile = ',atile(1,1),atile(1,2),
+ + atile(2,1),atile(2,2)
+ write(lp,*) 'mtile = ',mtile(1,1),mtile(1,2),
+ + mtile(2,1),mtile(2,2)
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+c test xcminr and xcmaxr
+c
+ call xcminr(amint)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcminr(amint)'
+ if (abs((amint-amino)/amino).le.1.e-5) then
+ write(lp,*) 'amint,amino = ',amint,amino
+ write(lp,*) 'mins are identical (',(amint-amino)/amino,')'
+ else
+ write(lp,*) 'amint,amino = ',amint,amino
+ write(lp,*) 'min error = ',amint-amino,(amint-amino)/amino
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+ call xcmaxr(amaxt)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcmaxr(amaxt)'
+ if (abs((amaxt-amaxo)/amaxo).le.1.e-5) then
+ write(lp,*) 'amaxt,amaxo = ',amaxt,amaxo
+ write(lp,*) 'maxs are identical (',(amaxt-amaxo)/amaxo,')'
+ else
+ write(lp,*) 'amaxt,amaxo = ',amaxt,amaxo
+ write(lp,*) 'max error = ',amaxt-amaxo,(amaxt-amaxo)/amaxo
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c test xcsum and xcsumj.
+c
+ call xcsum(sumt, atile,mtile)
+ call xxsum(sumo, aorig,morig)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcsum(sumt, atile,mtile)'
+ if (abs((sumt-sumo)/sumo).le.1.e-5) then
+ write(lp,*) 'sumt,sumo = ',sumt,sumo
+ write(lp,*) 'sums are identical (',(sumt-sumo)/sumo,')'
+ else
+ write(lp,*) 'sumt,sumo = ',sumt,sumo
+ write(lp,*) 'sum error = ',sumt-sumo,(sumt-sumo)/sumo
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+ call xcsumj(sumjt, atile,mtile)
+ call xxsumj(sumjo, aorig,morig)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcsumj(sumtj, atile,mtile)'
+ i = 0
+ do j= 1,jtdm
+ if (sumjo(j).eq.0.0) then
+ if (sumjt(j).ne.0.0) then
+ write(lp,*) 'j,sumt,sumo = ',j,sumjt(j),sumjo(j)
+ write(lp,*) 'j,sum error = ',j,sumjt(j)-sumjo(j)
+ i = i + 1
+ endif
+ else
+ if (abs((sumjt(j)-sumjo(j))/sumjo(j)).gt.1.e-5) then
+ write(lp,*) 'j,sumt,sumo = ',j,sumjt(j),sumjo(j)
+ write(lp,*) 'j,sum error = ',j,sumjt(j)-sumjo(j)
+ i = i + 1
+ endif
+ endif
+ enddo
+ if (i.eq.0) then
+ write(lp,*) 'j sums are identical'
+ else
+ write(lp,*) 'j sums differ in ',i,' rows'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c new mask
+c
+ do j= 1,jtdm
+ do i= 1,itdm
+ morig(i,j) = mod(i+j,2)
+ enddo
+ enddo
+c
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ if (i+i0.ge.1 .and. i+i0.le.itdm .and.
+ & j+j0.ge.1 .and. j+j0.le.jtdm ) then
+ mtile(i,j) = morig(i+i0,j+j0)
+ else
+ mtile(i,j) = 0
+ endif
+ enddo
+ enddo
+c
+c test.
+c
+ call xcsum(sumt, atile,mtile)
+ call xxsum(sumo, aorig,morig)
+ if (mnproc.eq.1) then
+ write(lp,*) 'call xcsum(sumt, atile,mtile)'
+ if (abs((sumt-sumo)/sumo).le.1.e-5) then
+ write(lp,*) 'sumt,sumo = ',sumt,sumo
+ write(lp,*) 'sums are identical (',(sumt-sumo)/sumo,')'
+ else
+ write(lp,*) 'sumt,sumo = ',sumt,sumo
+ write(lp,*) 'sum error = ',sumt-sumo,(sumt-sumo)/sumo
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+ call xcstop('(normal)')
+ stop '(normal)'
+ end
+ subroutine xxsum(sum, a,mask)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ real*8 sum
+ real a( itdm,jtdm)
+ integer mask(itdm,jtdm)
+c
+c**********
+c*
+c 1) sum a 2-d array, where mask==1
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sum real*8 output sum of a
+c a real input source array
+c mask integer input mask array
+c*
+c**********
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8,sum8p,sum8j(jtdm)
+ integer i,i1,j
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jtdm
+ sum8 = zero8
+ do i1=1,itdm,2*nbdy+1
+ sum8p = zero8
+ do i= i1,min(i1+2*nbdy,itdm)
+ if (mask(i,j).eq.1) then
+ sum8p = sum8p + a(i,j)
+ endif
+ enddo
+ sum8 = sum8 + sum8p
+ enddo
+ sum8j(j) = sum8 ! use of sum8 minimizes false sharing of sum8j
+ enddo
+!$OMP END PARALLEL DO
+c
+c serial sum of rwo-sum loop.
+c
+ sum8 = sum8j(1)
+ do j=2,jtdm
+ sum8 = sum8 + sum8j(j)
+ enddo
+ sum = sum8
+ return
+c end of xxsum.
+ end
+ subroutine xxsumj(sumj, a,mask)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ real*8 sumj( jtdm)
+ real a( itdm,jtdm)
+ integer mask(itdm,jtdm)
+c
+c**********
+c*
+c 1) row sum a 2-d array, where mask==1
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sumj real*8 output rwo sums of a
+c a real input source array
+c mask integer input mask array
+c*
+c**********
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8,sum8p
+ integer i,i1,j
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jtdm
+ sum8 = zero8
+ do i1=1,itdm,2*nbdy+1
+ sum8p = zero8
+ do i= i1,min(i1+2*nbdy,itdm)
+ if (mask(i,j).eq.1) then
+ sum8p = sum8p + a(i,j)
+ endif
+ enddo
+ sum8 = sum8 + sum8p
+ enddo
+ sumj(j) = sum8 ! use of sum8 minimizes false sharing of sumj
+ enddo
+!$OMP END PARALLEL DO
+ return
+c end of xxsumj.
+ end
diff --git a/src_2.2.18_3_one/TEST/test_xcs_9.com b/src_2.2.18_3_one/TEST/test_xcs_9.com
new file mode 100755
index 0000000..ff0b6cc
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xcs_9.com
@@ -0,0 +1,54 @@
+#!/bin/csh
+#
+#@ job_name = test_xcs_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xcsum, 2-d uniform or equal-ocean tiles.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3X3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03X03s patch.input
+cat patch.input
+poe ./test_xcs
+#setenv NPES 9
+#mpprun -n $NPES ./test_xcs
+#
+# --- 3x3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x03s patch.input
+cat patch.input
+poe ./test_xcs
+#setenv NPES 9
+#mpprun -n $NPES ./test_xcs
diff --git a/src_2.2.18_3_one/TEST/test_xct.com b/src_2.2.18_3_one/TEST/test_xct.com
new file mode 100755
index 0000000..31979f3
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct.com
@@ -0,0 +1,54 @@
+#!/bin/csh
+#
+#@ job_name = test_xct
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xctilr, 1-d partitioning.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3x1.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x01 patch.input
+cat patch.input
+poe ./test_xct
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xct
+#
+# --- 1x3.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.01x03 patch.input
+cat patch.input
+poe ./test_xct
+#setenv NMPI 3
+#mpprun -n $NMPI ./test_xct
diff --git a/src_2.2.18_3_one/TEST/test_xct.f b/src_2.2.18_3_one/TEST/test_xct.f
new file mode 100755
index 0000000..09256c0
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct.f
@@ -0,0 +1,284 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+c test xctilr, for non-arctic tiles only (itype ignored).
+c
+ integer i,j,k,ksea,nrecl
+ real*4 depth(itdm,jtdm)
+ real aorig(itdm,jtdm,kdm)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm)
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+c
+c initialize.
+c
+ do j= 1,jtdm
+ do i= 1,itdm
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ do k= 1,kdm
+ aorig(i,j,k) = i + (j-1)*100 + (k-1)*10000
+ enddo
+ else
+ do k= 1,kdm
+ aorig(i,j,k) = 0.0
+ enddo
+ endif
+ enddo
+ enddo
+c
+ do k= 1,kdm
+ do j= 1,jj
+ do i= 1,ii
+ atile(i,j,k) = aorig(i+i0,j+j0,k)
+ enddo
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'ii, jj = ',ii, jj
+ ksea = count( aorig(:,:,1).ne.0.0 )
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,*) 'aorig1 = ',aorig(1,1,1),aorig(1,2,1),
+ + aorig(2,1,1),aorig(2,2,1)
+ write(lp,*) 'atile1 = ',atile(1,1,1),atile(1,2,1),
+ + atile(2,1,1),atile(2,2,1)
+ write(lp,*) 'aorig9 = ',aorig(1,1,9),aorig(1,2,9),
+ + aorig(2,1,9),aorig(2,2,9)
+ write(lp,*) 'atile9 = ',atile(1,1,9),atile(1,2,9),
+ + atile(2,1,9),atile(2,2,9)
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+c test.
+c
+ call xctilr(atile,1,1, 1,1, halo_ps)
+ call yytile(atile,1,1, 1,1, aorig)
+c
+ call xctilr(atile,1,1, 0,1, halo_ps)
+ call yytile(atile,1,1, 0,1, aorig)
+c
+ call xctilr(atile,1,1, 1,0, halo_ps)
+ call yytile(atile,1,1, 1,0, aorig)
+c
+ call xctilr(atile,3,9, nbdy,nbdy, halo_ps)
+ call yytile(atile,3,9, nbdy,nbdy, aorig)
+c
+ call xctilr(atile,1,kdm, nbdy,nbdy, halo_ps)
+ call yytile(atile,1,kdm, nbdy,nbdy, aorig)
+c
+ call xctilr(atile,1,kdm, 2, nbdy, halo_ps)
+ call yytile(atile,1,kdm, 2, nbdy, aorig)
+c
+ call xctilr(atile,1,kdm, nbdy, 2, halo_ps)
+ call yytile(atile,1,kdm, nbdy, 2, aorig)
+c
+ call xcstop('(normal)')
+ stop '(normal)'
+ end
+ subroutine yytile(atile,l1,ld,mh,nh, aorig)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer l1,ld,mh,nh
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+ real aorig(itdm,jtdm,ld)
+c
+c check that atile's halo is up to date.
+c
+ integer i,io,j,jo,k,mn
+ integer kbad,ksea,ke,kn,ks,kw
+c
+ if (mnproc.eq.1) then
+ write(lp,'(a,4i5)') 'call xctilr - l1,ld,mh,nh = ',
+ & l1,ld,mh,nh
+ endif
+ call xcsync(flush_lp)
+c
+ do mn= 1,ijpr
+ if (mn.eq.mnproc) then
+c
+ kbad = 0
+ do k= l1,ld
+ ke = 0
+ kw = 0
+ do i= 1,mh
+ if (nreg.eq.0) then
+ io = i0+1-i
+ else
+ io = mod(i0+1-i+itdm-1,itdm)+1
+ endif
+ do j= 1-nh,jj+nh
+ jo = j0+j
+ if ((1.le.jo .and. jo.le.jtdm) .and.
+ & (1.le.io .and. io.le.itdm) ) then
+ if (atile(1-i,j,k).ne.aorig(io,jo,k)) then
+ kw = kw + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.W = ',1-i,j,k,atile(1-i,j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'ao.W = ',io,jo,k,aorig(io,jo,k)
+ endif
+ endif
+ else
+ if (atile(1-i,j,k).ne.vland) then
+ kw = kw + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.W = ',1-i,j,k,atile(1-i,j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'land = ',io,jo,k,vland
+ endif
+ endif
+ endif
+ enddo
+ if (nreg.eq.0) then
+ io = i0+ii+i
+ else
+ io = mod(i0+ii+i-1,itdm)+1
+ endif
+ do j= 1-nh,jj+nh
+ jo = j0+j
+ if ((1.le.jo .and. jo.le.jtdm) .and.
+ & (1.le.io .and. io.le.itdm) ) then
+ if (atile(ii+i,j,k).ne.aorig(io,jo,k)) then
+ ke = ke + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.E = ',ii+i,j,k,atile(ii+i,j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'ao.E = ',io,jo,k,aorig(io,jo,k)
+ endif
+ endif
+ else
+ if (atile(ii+i,j,k).ne.vland) then
+ ke = ke + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.E = ',ii+i,j,k,atile(ii+i,j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'land = ',io,jo,k,vland
+ endif
+ endif
+ endif
+ enddo
+ enddo
+c
+ kn = 0
+ ks = 0
+ do j= 1,nh
+ jo = j0+1-j
+ do i= 1-mh,ii+mh
+ if (nreg.eq.0) then
+ io = i0+i
+ else
+ io = mod(i0+i+itdm-1,itdm)+1
+ endif
+ if ((1.le.jo .and. jo.le.jtdm) .and.
+ & (1.le.io .and. io.le.itdm) ) then
+ if (atile(i,1-j,k).ne.aorig(io,jo,k)) then
+ ks = ks + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.S = ',i,1-j,k,atile(i,1-j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'ao.S = ',io,jo,k,aorig(io,jo,k)
+ endif
+ endif
+ else
+ if (atile(i,1-j,k).ne.vland) then
+ ks = ks + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.S = ',i,1-j,k,atile(i,1-j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'land = ',io,jo,k,vland
+ endif
+ endif
+ endif
+ enddo
+ jo = j0+jj+j
+ do i= 1-mh,ii+mh
+ if (nreg.eq.0) then
+ io = i0+i
+ else
+ io = mod(i0+i+itdm-1,itdm)+1
+ endif
+ if ((1.le.jo .and. jo.le.jtdm) .and.
+ & (1.le.io .and. io.le.itdm) ) then
+ if (atile(i,jj+j,k).ne.aorig(io,jo,k)) then
+ kn = kn + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.N = ',i,jj+j,k,atile(i,jj+j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'ao.N = ',io,jo,k,aorig(io,jo,k)
+ endif
+ endif
+ else
+ if (atile(i,jj+j,k).ne.vland) then
+ kn = kn + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,f12.2)')
+ & 'at.N = ',i,jj+j,k,atile(i,jj+j,k)
+ write(lp,'(a,3i5,f12.2)')
+ & 'land = ',io,jo,k,vland
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ if (kn+ks+ke+kw.ne.0) then
+ kbad = kbad + 1
+ write(lp,6000) mproc,nproc,k,ks,kn,kw,ke
+ endif
+ enddo
+c
+ call xcsync(flush_lp)
+ endif
+ enddo ! mn=1,ijpr
+c
+ do mn= 1,ijpr
+ if (mn.eq.mnproc) then
+ if (kbad.eq.0) then
+ write(lp,6100) mproc,nproc,ld-l1+1
+ else
+ write(lp,6150) mproc,nproc,kbad,ld-l1+1
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+ return
+ 6000 format('mp,np =',2i3,' k =',i3,' ks,kn,kw,ke = ',4i4)
+ 6100 format('mp,np =',2i3,' halo correct for all',i3,' levels')
+ 6150 format('mp,np =',2i3,' halo incorrect for',i3,' of',
+ + i3,' levels')
+ end
diff --git a/src_2.2.18_3_one/TEST/test_xct_9.com b/src_2.2.18_3_one/TEST/test_xct_9.com
new file mode 100755
index 0000000..3bf4d7c
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_9.com
@@ -0,0 +1,53 @@
+#!/bin/csh
+#
+#@ job_name = test_xct_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test xctilr, 2-d uniform or equal-ocean tiles.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3X3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03X03s patch.input
+cat patch.input
+poe ./test_xct
+#setenv NPES 9
+#mpprun -n $NPES ./test_xct
+#
+# --- 3x3s.
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x03s patch.input
+cat patch.input
+poe ./test_xct
+#setenv NPES 9
+#mpprun -n $NPES ./test_xct
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic.f b/src_2.2.18_3_one/TEST/test_xct_arctic.f
new file mode 100755
index 0000000..7071dfb
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic.f
@@ -0,0 +1,500 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+c test xctilr, for arctic regions only.
+c
+ integer i,j,k,ksea,nrecl
+ real*4 depth(itdm,jtdm)
+ real aorig(itdm,jtdm)
+ real ahalo(1-nbdy:itdm+nbdy,1-nbdy:jtdm+nbdy)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm)
+c
+ integer halo_type,l
+ integer halo_t(8)
+ data halo_t / 1, 2, 3, 4, 11, 12, 13, 14 /
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+ do l= 1,8
+ halo_type = halo_t(l)
+c
+c initialize for halo type.
+c
+ do j= 1,jtdm
+ do i= 1,itdm
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ aorig(i,j) = i + (j-1)*100
+ else
+ aorig(i,j) = 0.0
+ endif
+ enddo
+ enddo
+ call arctic_fix( aorig,1, halo_type)
+ call arctic_halo(aorig,1, halo_type, ahalo)
+c
+ do k= 1,kdm
+ do j= 1,jj
+ do i= 1,ii
+ if (aorig(i+i0,j+j0).gt.0.0) then
+ atile(i,j,k) = aorig(i+i0,j+j0) + (k-1)*10000
+ elseif (aorig(i+i0,j+j0).lt.0.0) then
+ atile(i,j,k) = aorig(i+i0,j+j0) - (k-1)*10000
+ else
+ atile(i,j,k) = 0.0
+ endif
+ enddo
+ enddo
+ enddo
+ if (mnproc.eq.ijpr) then
+ write(lp,*)
+ write(lp,*) 'halo_type = ',halo_type
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'ii, jj = ',ii, jj
+ ksea = count( aorig(:,:).ne.0.0 )
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,'(a,4f12.2)') 'aorig1 = ',aorig(1, 1),aorig(ii, 1),
+ + aorig(1,jj),aorig(ii,jj)
+ write(lp,'(a,4f12.2)') 'atile1 = ',atile(1, 1,1),atile(ii, 1,1),
+ + atile(1,jj,1),atile(ii,jj,1)
+ write(lp,'(a,4f12.2)') 'aorig9 = ',aorig( 1, 1)+8*10000,
+ + aorig(ii, 1)+8*10000,
+ + aorig( 1,jj)+8*10000,
+ + aorig(ii,jj)+8*10000
+ write(lp,'(a,4f12.2)') 'atile9 = ',atile(1, 1,9),atile(ii, 1,9),
+ + atile(1,jj,9),atile(ii,jj,9)
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+c test.
+c
+ call zztile(atile,1,1)
+ call xctilr(atile,1,1, 1,1, halo_type)
+ call yytile(atile,1,1, 1,1, halo_type, ahalo)
+c
+ call zztile(atile,1,1)
+ call xctilr(atile,1,1, 0,1, halo_type)
+ call yytile(atile,1,1, 0,1, halo_type, ahalo)
+c
+ call zztile(atile,1,1)
+ call xctilr(atile,1,1, 1,0, halo_type)
+ call yytile(atile,1,1, 1,0, halo_type, ahalo)
+c
+ call zztile(atile,1,1)
+ call xctilr(atile,1,1, nbdy,nbdy, halo_type)
+ call yytile(atile,1,1, nbdy,nbdy, halo_type, ahalo)
+c
+ call zztile(atile,3,9)
+ call xctilr(atile,3,9, nbdy,nbdy, halo_type)
+ call yytile(atile,3,9, nbdy,nbdy, halo_type, ahalo)
+c
+ call zztile(atile,1,kdm)
+ call xctilr(atile,1,kdm, nbdy,nbdy, halo_type)
+ call yytile(atile,1,kdm, nbdy,nbdy, halo_type, ahalo)
+c
+ call zztile(atile,1,kdm)
+ call xctilr(atile,1,kdm, 2, nbdy, halo_type)
+ call yytile(atile,1,kdm, 2, nbdy, halo_type, ahalo)
+c
+ call zztile(atile,1,kdm)
+ call xctilr(atile,1,kdm, nbdy, 2, halo_type)
+ call yytile(atile,1,kdm, nbdy, 2, halo_type, ahalo)
+c
+ enddo !l
+c
+ call xcstop('(normal)')
+ stop '(normal)'
+ end
+ subroutine arctic_fix(aorig,ld, halo_type)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer ld,halo_type
+ real aorig(itdm,jtdm,ld)
+c
+c make top edge consistent for arctic patch
+c
+ real s
+ integer i,io,j,jo,k
+c
+ if (halo_type.lt.10) then
+ s = 1.0 !scalar
+ else
+ s = -1.0 !vector
+ endif
+c
+ do k= 1,ld
+ j = jtdm
+ if (halo_type.eq.1 .or. halo_type.eq.11) then !p-grid
+ jo = jtdm-1
+ do i= 1,itdm
+ io = itdm-mod(i-1,itdm)
+ aorig(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.2 .or. halo_type.eq.12) then !q-grid
+ jo = jtdm
+ do i= 1,itdm/2
+ io = mod(itdm-(i-1),itdm)+1
+ aorig(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.3 .or. halo_type.eq.13) then !u-grid
+ jo = jtdm-1
+ do i= 1,itdm
+ io = mod(itdm-(i-1),itdm)+1
+ aorig(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.4 .or. halo_type.eq.14) then !v-grid
+ jo = jtdm
+ do i= 1,itdm/2
+ io = itdm-mod(i-1,itdm)
+ aorig(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ endif !halo_type
+ enddo !k
+ return
+ end
+ subroutine arctic_halo(aorig,ld, halo_type, ahalo)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer ld,halo_type
+ real aorig(itdm,jtdm,ld)
+ real ahalo(1-nbdy:itdm+nbdy,1-nbdy:jtdm+nbdy,ld)
+c
+c copy aorig into ahalo including the halo.
+c
+ real s
+ integer i,io,j,jo,k
+c
+ if (halo_type.lt.10) then
+ s = 1.0 !scalar
+ else
+ s = -1.0 !vector
+ endif
+c
+ do k= 1,ld
+ do j= 1,jtdm
+ do i= 1,itdm
+ ahalo(i,j,k) = aorig(i,j,k)
+ enddo
+ enddo
+ do j= 1-nbdy,0
+ do i= 1,itdm
+ ahalo(i,j,k) = 0.0 !southern boundary is closed
+ enddo
+ enddo
+c
+ do j= jtdm+1,jtdm+nbdy
+ if (halo_type.eq.1 .or. halo_type.eq.11) then !p-grid
+ jo = jtdm-1-(j-jtdm)
+ do i= 1,itdm
+ io = itdm-mod(i-1,itdm)
+ ahalo(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.2 .or. halo_type.eq.12) then !q-grid
+ jo = jtdm-(j-jtdm)
+ do i= 1,itdm
+ io = mod(itdm-(i-1),itdm)+1
+ ahalo(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.3 .or. halo_type.eq.13) then !u-grid
+ jo = jtdm-1-(j-jtdm)
+ do i= 1,itdm
+ io = mod(itdm-(i-1),itdm)+1
+ ahalo(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ elseif (halo_type.eq.4 .or. halo_type.eq.14) then !v-grid
+ jo = jtdm-(j-jtdm)
+ do i= 1,itdm
+ io = itdm-mod(i-1,itdm)
+ ahalo(i,j,k) = s*aorig(io,jo,k)
+ enddo !i
+ endif !halo_type
+ enddo !j
+c
+ do j= 1-nbdy,jtdm+nbdy
+ do i= 1-nbdy,0
+ io = itdm+i
+ ahalo(i,j,k) = ahalo(io,j,k) !periodic
+ enddo
+ do i= itdm+1,itdm+nbdy
+ io = i-itdm
+ ahalo(i,j,k) = ahalo(io,j,k) !periodic
+ enddo
+ enddo
+ enddo !k
+ return
+ end
+ subroutine yytile(atile,l1,ld,mh,nh, ht, ahalo)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer l1,ld,mh,nh,ht
+ real atile(1-nbdy:idm +nbdy,1-nbdy:jdm +nbdy,ld)
+ real ahalo(1-nbdy:itdm+nbdy,1-nbdy:jtdm+nbdy)
+c
+c check that atile's halo is up to date.
+c based on ahalo being correct in interior and in the halo.
+c
+ real o
+ integer i,io,j,jo,k,mn
+ integer kbad,ksea,ke,kn,ks,kw
+c
+ if (mnproc.eq.1) then
+ write(lp,'(a,4i5,i3)') 'call xctilr - l1,ld,mh,nh,ht = ',
+ & l1,ld,mh,nh,ht
+ endif
+ call xcsync(flush_lp)
+c
+ do mn= 1,ijpr
+ if (mn.eq.mnproc) then
+c
+ kbad = 0
+ do k= l1,ld
+ o = (k-1)*10000
+ do i= 1,ii
+ io = i0+i
+ do j= 1,jj
+ jo = j0+j
+ if (ahalo(io,jo).eq.0.0) then
+ if (atile(i,j,k).ne.0.0) then
+ kbad = kbad + 1
+ endif
+ elseif (ahalo(io,jo).gt.0.0 .and.
+ & atile(i,j,k).ne.ahalo(io,jo)+o) then
+ kbad = kbad + 1
+ elseif (ahalo(io,jo).lt.0.0 .and.
+ & atile(i,j,k).ne.ahalo(io,jo)-o) then
+ kbad = kbad + 1
+ endif
+ enddo !j
+ enddo !i
+ enddo !k
+ if (kbad.ne.0) then
+ write(6,'(a,2i3,a)') 'mp,np =',mproc,nproc,
+ & ' tile interior incorrect'
+ endif
+c
+ kbad = 0
+ do k= l1,ld
+ o = (k-1)*10000
+ ke = 0
+ kw = 0
+ do i= 1,mh
+ io = i0+(1-i)
+ do j= 1-nh,jj+nh
+ jo = j0+j
+ if (ahalo(io,jo).eq.0.0) then
+ if (atile(1-i,j,k).ne.0.0) then
+ kw = kw + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.W = ',1-i,j,k,atile(1-i,j,k),0.0
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.W = ',io,jo,k,0.0,atile(1-i,j,k)
+ endif
+ endif
+ elseif (ahalo(io,jo).gt.0.0 .and.
+ & atile(1-i,j,k).ne.ahalo(io,jo)+o) then
+ kw = kw + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.W = ',1-i,j,k,atile(1-i,j,k),ahalo(io,jo)+o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.W = ',io,jo,k,ahalo(io,jo)+o,atile(1-i,j,k)
+ endif
+ elseif (ahalo(io,jo).lt.0.0 .and.
+ & atile(1-i,j,k).ne.ahalo(io,jo)-o) then
+ kw = kw + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.W = ',1-i,j,k,atile(1-i,j,k),ahalo(io,jo)-o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.W = ',io,jo,k,ahalo(io,jo)-o,atile(1-i,j,k)
+ endif
+ endif
+ enddo !j
+ io = i0+(ii+i)
+ do j= 1-nh,jj+nh
+ jo = j0+j
+ if (ahalo(io,jo).eq.0.0) then
+ if (atile(ii+i,j,k).ne.0.0) then
+ ke = ke + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.E = ',ii+i,j,k,atile(ii+i,j,k),0.0
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.E = ',io,jo,k,0.0,atile(ii+i,j,k)
+ endif
+ endif
+ elseif (ahalo(io,jo).gt.0.0 .and.
+ & atile(ii+i,j,k).ne.ahalo(io,jo)+o) then
+ ke = ke + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.E = ',ii+i,j,k,atile(ii+i,j,k),ahalo(io,jo)+o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.E = ',io,jo,k,ahalo(io,jo)+o,atile(ii+i,j,k)
+ endif
+ elseif (ahalo(io,jo).lt.0.0 .and.
+ & atile(ii+i,j,k).ne.ahalo(io,jo)-o) then
+ ke = ke + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.E = ',ii+i,j,k,atile(ii+i,j,k),ahalo(io,jo)-o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.E = ',io,jo,k,ahalo(io,jo)-o,atile(ii+i,j,k)
+ endif
+ endif
+ enddo !j
+ enddo !i
+c
+ kn = 0
+ ks = 0
+ do j= 1,nh
+ jo = j0+(1-j)
+ do i= 1-mh,ii+mh
+ io = i0+i
+ if (ahalo(io,jo).eq.0.0) then
+ if (atile(i,1-j,k).ne.0.0) then
+ ks = ks + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.S = ',i,1-j,k,atile(i,1-j,k),0.0
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.S = ',io,jo,k,0.0,atile(i,1-j,k)
+ endif
+ endif
+ elseif (ahalo(io,jo).gt.0.0 .and.
+ & atile(i,1-j,k).ne.ahalo(io,jo)+o) then
+ ks = ks + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.S = ',i,1-j,k,atile(i,1-j,k),ahalo(io,jo)+o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.S = ',io,jo,k,ahalo(io,jo)+o,atile(i,1-j,k)
+ endif
+ elseif (ahalo(io,jo).lt.0.0 .and.
+ & atile(i,1-j,k).ne.ahalo(io,jo)-o) then
+ ks = ks + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.S = ',i,1-j,k,atile(i,1-j,k),ahalo(io,jo)-o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.S = ',io,jo,k,ahalo(io,jo)-o,atile(i,1-j,k)
+ endif
+ endif
+ enddo
+ jo = j0+jj+j
+ do i= 1-mh,ii+mh
+ io = i0+i
+ if (ahalo(io,jo).eq.0.0) then
+ if (atile(i,jj+j,k).ne.0.0) then
+ kn = kn + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.N = ',i,jj+j,k,atile(i,jj+j,k),0.0
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.N = ',io,jo,k,0.0,atile(i,jj+j,k)
+ endif
+ endif
+ elseif (ahalo(io,jo).gt.0.0 .and.
+ & atile(i,jj+j,k).ne.ahalo(io,jo)+o) then
+ kn = kn + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.N = ',i,jj+j,k,atile(i,jj+j,k),ahalo(io,jo)+o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.N = ',io,jo,k,ahalo(io,jo)+o,atile(i,jj+j,k)
+ endif
+ elseif (ahalo(io,jo).lt.0.0 .and.
+ & atile(i,jj+j,k).ne.ahalo(io,jo)-o) then
+ kn = kn + 1
+ if (k.eq.l1) then
+ write(lp,'(a,3i5,2f12.2)')
+ & 'at.N = ',i,jj+j,k,atile(i,jj+j,k),ahalo(io,jo)-o
+ write(lp,'(a,3i5,2f12.2)')
+ & 'ao.N = ',io,jo,k,ahalo(io,jo)-o,atile(i,jj+j,k)
+ endif
+ endif
+ enddo
+ enddo
+ if (kn+ks+ke+kw.ne.0) then
+ kbad = kbad + 1
+ write(lp,6000) mproc,nproc,k,ks,kn,kw,ke
+ endif
+ enddo
+c
+ endif ! mn.eq.mnproc
+ call xcsync(flush_lp)
+ enddo ! mn=1,ijpr
+c
+ do mn= 1,ijpr
+ if (mn.eq.mnproc) then
+ if (kbad.eq.0) then
+ write(lp,6100) mproc,nproc,ld-l1+1
+ else
+ write(lp,6150) mproc,nproc,kbad,ld-l1+1
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+ return
+ 6000 format('mp,np =',2i3,' k =',i3,' ks,kn,kw,ke = ',4i4)
+ 6100 format('mp,np =',2i3,' halo correct for all',i3,' levels')
+ 6150 format('mp,np =',2i3,' halo incorrect for',i3,' of',
+ + i3,' levels')
+ end
+ subroutine zztile(atile,l1,ld)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer l1,ld
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+c
+c set the tiles halo to -1.
+c
+ integer i,j,k
+c
+ do k= l1,ld
+ do j= 1,jj
+ do i= 1,nbdy
+ atile(ii+i,j,k) = -1.0
+ atile( 1-i,j,k) = -1.0
+ enddo !i
+ enddo !j
+ do j= 1,nbdy
+ do i= 1-nbdy,ii+nbdy
+ atile(i,jj+j,k) = -1.0
+ atile(i, 1-j,k) = -1.0
+ enddo !i
+ enddo !j
+ enddo !k
+ return
+ end
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic_01.com b/src_2.2.18_3_one/TEST/test_xct_arctic_01.com
new file mode 100755
index 0000000..9f60272
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic_01.com
@@ -0,0 +1,12 @@
+#!/bin/csh
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- test xctilr, single cpu
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_GLBa10.0_06.a regional.depth.a
+./test_xct_arctic
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic_08.com b/src_2.2.18_3_one/TEST/test_xct_arctic_08.com
new file mode 100755
index 0000000..0dac457
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic_08.com
@@ -0,0 +1,37 @@
+#!/bin/csh
+#
+#@ job_name = test_xct_arctic_08
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = csss,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 8
+#@ node_usage = not_shared
+#@ resources = ConsumableCpus(1) ConsumableMemory(500mb)
+#@ wall_clock_limit = 0:30:00
+#@ account_no = NRLSS018
+#@ class = debug
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- test xctilr, single cpu
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_GLBa10.0_06.a regional.depth.a
+cp ../../topo/partit/depth_GLBa10.0_06.008u patch.input
+#
+# AIX
+#
+ setenv MP_SHARED_MEMORY yes
+ setenv MP_SINGLE_THREAD yes
+ setenv MP_EAGER_LIMIT 65536
+# list where the MPI job will run
+ env MP_LABELIO=YES poe hostname
+ poe ./test_xct_arctic
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic_1x2.com b/src_2.2.18_3_one/TEST/test_xct_arctic_1x2.com
new file mode 100755
index 0000000..9615017
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic_1x2.com
@@ -0,0 +1,37 @@
+#!/bin/csh
+#
+#@ job_name = test_xct_arctic_1x2
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = csss,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 2
+#@ node_usage = not_shared
+#@ resources = ConsumableCpus(1) ConsumableMemory(500mb)
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = debug
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- test xctilr, single cpu
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_GLBa10.0_06.a regional.depth.a
+cp ../../topo/partit/depth_GLBa10.0_06.01X02 patch.input
+#
+# AIX
+#
+ setenv MP_SHARED_MEMORY yes
+ setenv MP_SINGLE_THREAD yes
+ setenv MP_EAGER_LIMIT 65536
+# list where the MPI job will run
+ env MP_LABELIO=YES poe hostname
+ poe ./test_xct_arctic
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic_2x1.com b/src_2.2.18_3_one/TEST/test_xct_arctic_2x1.com
new file mode 100755
index 0000000..f37c504
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic_2x1.com
@@ -0,0 +1,37 @@
+#!/bin/csh
+#
+#@ job_name = test_xct_arctic_2x1
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = csss,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 2
+#@ node_usage = not_shared
+#@ resources = ConsumableCpus(1) ConsumableMemory(500mb)
+#@ wall_clock_limit = 0:05:00
+#@ account_no = NRLSS018
+#@ class = debug
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- test xctilr, single cpu
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_GLBa10.0_06.a regional.depth.a
+cp ../../topo/partit/depth_GLBa10.0_06.02X01 patch.input
+#
+# AIX
+#
+ setenv MP_SHARED_MEMORY yes
+ setenv MP_SINGLE_THREAD yes
+ setenv MP_EAGER_LIMIT 65536
+# list where the MPI job will run
+ env MP_LABELIO=YES poe hostname
+ poe ./test_xct_arctic
diff --git a/src_2.2.18_3_one/TEST/test_xct_arctic_781.com b/src_2.2.18_3_one/TEST/test_xct_arctic_781.com
new file mode 100755
index 0000000..8d0e8a7
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_xct_arctic_781.com
@@ -0,0 +1,37 @@
+#!/bin/csh
+#
+#@ job_name = test_xct_arctic_781
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = csss,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 98
+#@ total_tasks = 781
+#@ node_usage = not_shared
+#@ resources = ConsumableCpus(1) ConsumableMemory(500mb)
+#@ wall_clock_limit = 0:30:00
+#@ account_no = NRLSSC1J
+#@ class = block2
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+# --- test xctilr, single cpu
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_GLBa0.08_05.a regional.depth.a
+cp ../../topo/partit/depth_GLBa0.08_05.781 patch.input
+#
+# AIX
+#
+ setenv MP_SHARED_MEMORY yes
+ setenv MP_SINGLE_THREAD yes
+ setenv MP_EAGER_LIMIT 65536
+# list where the MPI job will run
+ env MP_LABELIO=YES poe hostname
+ poe ./test_xct_arctic
diff --git a/src_2.2.18_3_one/TEST/test_zaio.com b/src_2.2.18_3_one/TEST/test_zaio.com
new file mode 100755
index 0000000..d316bc5
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_zaio.com
@@ -0,0 +1,66 @@
+#!/bin/csh
+#
+#@ job_name = test_zaio
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 1
+#@ total_tasks = 3
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:10:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test zaiod and zaiowr, 1-d partitioning.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ATLa2.00_01.a regional.depth.a
+#
+# --- 3x1.
+#
+touch fort.029
+/bin/rm -f fort.029*
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x01 patch.input
+cat patch.input
+poe ./test_zaio
+#setenv NPES 3
+#mpprun -n $NPES ./test_zaio
+#
+ls -oF fort.029*
+cmp fort.029 fort.029a
+#
+# --- 1x3.
+#
+touch fort.029
+/bin/rm -f fort.029*
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.01x03 patch.input
+cat patch.input
+poe ./test_zaio
+#setenv NPES 3
+#mpprun -n $NPES ./test_zaio
+#
+ls -oF fort.029*
+cmp fort.029 fort.029a
diff --git a/src_2.2.18_3_one/TEST/test_zaio.f b/src_2.2.18_3_one/TEST/test_zaio.f
new file mode 100755
index 0000000..75a5f08
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_zaio.f
@@ -0,0 +1,245 @@
+ program testxc
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+c
+ logical, parameter :: lregion = .true. ! input regional.depth?
+c
+ real*4 spval4
+ parameter (spval4=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+c test array I/O.
+c
+ integer i,ierr,irec,j,jerr,l,ksea,nrecl
+ integer mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ real aorig(itdm,jtdm)
+ real atile(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ real ao(itdm),at(itdm),atmax,atmin,vsave
+ real*4 b4(n2drec),depth(itdm,jtdm)
+c
+c --- machine-specific initialization
+c
+ call machine
+c
+c --- initialize SPMD processsing
+c
+ call xcspmd
+c
+c Initialize array I/O.
+c
+ call zaiost
+c
+c read in land/sea map?
+c
+ if (lregion) then
+ inquire(iolength=nrecl) depth
+c
+ open( unit=11, file='regional.depth.a',
+ & form='unformatted', action='read',
+ & access='direct', recl=nrecl)
+ read( unit=11, rec=1) depth
+ close(unit=11)
+ else
+ depth = 1.0
+ endif
+c
+c initialize.
+c
+ do i= 1,n2drec
+ b4(i) = spval4
+ enddo
+c
+ l = 0
+ ksea = 0
+ do j= 1,jtdm
+ do i= 1,itdm
+ l = l + 1
+ if (depth(i,j).gt.0.0 .and. depth(i,j).lt.2.0**99) then
+ aorig(i,j) = i + (j-1)*100
+ b4(l) = aorig(i,j)
+ ksea = ksea + 1
+ else
+ aorig(i,j) = spval4
+ endif
+ enddo
+ enddo
+c
+ do j= 1,jj
+ do i= 1,ii
+ atile(i,j) = aorig(i+i0,j+j0)
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*) 'itdm,jtdm = ',itdm,jtdm
+ write(lp,*) 'idm, jdm = ',idm, jdm
+ write(lp,*) 'sea, land = ',ksea,itdm*jtdm-ksea
+ write(lp,*) 'aorig = ',aorig(1,1),aorig(1,2),
+ + aorig(2,1),aorig(2,2)
+ write(lp,*) 'atile = ',atile(1,1),atile(1,2),
+ + atile(2,1),atile(2,2)
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c create test file.
+c
+ if (mnproc.eq.1) then
+ inquire(iolength=nrecl) b4
+ open( unit=29, file='fort.029',
+ & form='unformatted',
+ & status='new',
+ & action='write',
+ & access='direct',
+ & recl=nrecl)
+ write(unit=29, rec=1) b4
+ write(unit=29, rec=2) b4
+ close(unit=29, status='keep')
+ endif
+c
+ call xcsync(flush_lp)
+c
+c tiled i/o on test file.
+c
+ call zaiopf('fort.029', 'old', 929)
+ call zaiopn( 'new', 29)
+ do irec= 1,2
+c
+ atile(:,:) = 0.0
+c
+c read.
+c
+ call xcsync(flush_lp)
+ if (mnproc.eq.1) then
+ write(lp,*) 'reading record ',irec
+ endif
+ call xcsync(flush_lp)
+ call zaiord(atile, mask,.false., atmin,atmax, 929)
+ call xcsync(flush_lp)
+ if (mnproc.eq.1) then
+ write(lp,*) ' read complete ',atmin,atmax
+ endif
+ call xcsync(flush_lp)
+c
+c test.
+c
+ jerr = 0
+ do j= 1,jtdm
+ vsave = vland
+ vland = spval4
+ call xclget(at,itdm, atile,1,j,+1,0, 0)
+ vland = vsave
+ call xxlget(ao,itdm, aorig,1,j,+1,0)
+ call yycomp(ao,at,itdm ,ierr)
+ if (ierr.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,*) ' yycomp - j,ierr = ',j,ierr
+ endif
+ endif
+ call xcsync(flush_lp)
+ jerr = jerr + ierr
+ enddo
+ if (mnproc.eq.1) then
+ if (jerr.eq.0) then
+ write(6,*) ' read successfull'
+ else
+ write(6,*) ' read generated ',jerr,' bad elements'
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c write.
+c
+ if (mnproc.eq.1) then
+ write(6,*) 'writing record ',irec
+ endif
+ call xcsync(flush_lp)
+ call zaiowr(atile, mask,.false., atmin,atmax, 29, .false.)
+ call xcsync(flush_lp)
+ if (mnproc.eq.1) then
+ write(6,*) ' write complete',atmin,atmax
+ endif
+ call xcsync(flush_lp)
+ enddo
+c
+c close.
+c
+ call zaiocl( 29)
+ call zaiocl(929)
+c
+ call xcstop('(normal')
+ stop '(normal)'
+ end
+ subroutine xxlget(aline,nl, a, i1,j1,ic,jc)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer nl,i1,j1,ic,jc
+ real aline(nl)
+ real a(itdm,jtdm)
+c
+c**********
+c*
+c 1) extracts the line a(i1:i1+(nl-1)*ic:ic,j1:j1+(nl-1)*jc:jc),
+c w.r.t. the 2-d grid.
+c
+c 2) ic and jc can each be -1, 0, or +1.
+c*
+c**********
+c
+ integer i
+c
+* write(lp,'(a,5i5)') 'xxlget - nl,i1,j1,ic,jc = ',nl,i1,j1,ic,jc
+ if (jc.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1+ic*(i-1),j1)
+ enddo
+ elseif (ic.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1,j1+jc*(i-1))
+ enddo
+ else
+ do i= 1,nl
+ aline(i) = a(i1+ic*(i-1),j1+jc*(i-1))
+ enddo
+ endif
+ return
+c end of xxlget.
+ end
+ subroutine yycomp(a,b,n, ierr)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer n,ierr
+ real a(n),b(n)
+c
+c**********
+c*
+c 1) tests if a and b are identical.
+c*
+c**********
+c
+ integer i
+c
+ ierr = 0
+ do 110 i= 1,n
+ if (a(i).ne.b(i)) then
+ if (mnproc.eq.1 .and. mod(ierr,20).eq.0) then
+ write(lp,*) 'i,a,b = ',i,a(i),b(i)
+ endif
+ ierr = ierr + 1
+ endif
+ 110 continue
+* if (mnproc.eq.1) then
+* if (ierr.eq.0) then
+* write(lp,*) 'arrays are identical'
+* write(lp,*)
+* else
+* write(lp,*) 'arrays have ',ierr,' differing elements'
+* write(lp,*)
+* endif
+* endif
+ return
+c end of yycomp.
+ end
diff --git a/src_2.2.18_3_one/TEST/test_zaio_9.com b/src_2.2.18_3_one/TEST/test_zaio_9.com
new file mode 100755
index 0000000..8c97f2e
--- /dev/null
+++ b/src_2.2.18_3_one/TEST/test_zaio_9.com
@@ -0,0 +1,66 @@
+#!/bin/csh
+#
+#@ job_name = test_zaio_9
+#@ output = $(job_name).log
+#@ error = $(job_name).log
+#@ restart = yes
+#@ job_type = parallel
+#@ network.MPI = css0,not_shared,US
+#@ environment = MP_EUILIB=us
+#@ node = 3
+#@ total_tasks = 9
+#@ node_usage = not_shared
+#@ wall_clock_limit = 0:10:00
+#@ account_no = NRLSS018
+#@ class = batch
+#@ queue
+#
+set echo
+set time = 1
+set timestamp
+#
+setenv MP_SHARED_MEMORY yes
+setenv MP_SINGLE_THREAD yes
+setenv MP_EAGER_LIMIT 65536
+#setenv MP_EUILIB us
+#setenv MP_EUIDEVICE css0
+#
+# --- test zaiod and zaiowr, 2-d uniform or equal-ocean tiles.
+#
+cd ~/hycom/ATLa2.00/src_2.0.01_16_ompi/TEST
+#
+touch regional.depth.a
+/bin/rm regional.depth.a
+ln -s ../../topo/depth_ALTa2.00_01.a regional.depth.a
+#
+# --- 3X3s.
+#
+touch fort.029
+/bin/rm -f fort.029*
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03X03s patch.input
+cat patch.input
+poe ./test_zaio
+#setenv NPES 9
+#mpprun -n $NPES ./test_zaio
+#
+ls -oF fort.029*
+cmp fort.029 fort.029a
+#
+# --- 3x3s.
+#
+touch fort.029
+/bin/rm -f fort.029*
+#
+touch patch.input
+/bin/rm patch.input
+ln -s ../../topo/partit/depth_ATLa2.00_01.03x03s patch.input
+cat patch.input
+poe ./test_zaio
+#setenv NPES 9
+#mpprun -n $NPES ./test_zaio
+#
+ls -oF fort.029*
+cmp fort.029 fort.029a
diff --git a/src_2.2.18_3_one/archiv.f b/src_2.2.18_3_one/archiv.f
new file mode 100755
index 0000000..2abf9ec
--- /dev/null
+++ b/src_2.2.18_3_one/archiv.f
@@ -0,0 +1,575 @@
+ subroutine archiv(n, kkout, iyear,iday,ihour, intvl)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer n, kkout, iyear,iday,ihour
+ real sssc,sstc
+ character intvl*3
+c
+ include 'stmt_fns.h'
+c
+c --- write an archive file.
+c
+ character*80 cformat
+ integer i,j,k,ktr,l,ldot,nop,nopa
+ real coord,xmin,xmax
+c
+ ldot = index(flnmarc,'.',back=.true.)
+ if (ldot.eq.0) then
+ if (mnproc.eq.1) then
+ write (lp,*) 'need decimal point in flnmarc'
+ write (lp,*) 'flnmarc = ',trim(flnmarc)
+ endif
+ call xcstop('(flnmarc)')
+ stop '(flnmarc)'
+ endif
+ ldot = min(ldot,len(flnmarc)-11) !need 11 characters for archive date
+c
+ if ((kkout.eq.1 .and. dsurfq.ge.1.0/24.0) .or.
+ & (kkout.gt.1 .and. diagfq.ge.1.0/24.0) ) then
+c --- indicate the archive date
+ write(flnmarc(ldot+1:ldot+11),'(i4.4,a1,i3.3,a1,i2.2)')
+ & iyear,'_',iday,'_',ihour
+ ldot=ldot+11
+ else
+c --- indicate the archive time step
+ write(flnmarc(ldot+1:ldot+11),'(i11.11)') nstep
+ ldot=ldot+11
+ endif
+ nopa=13
+ nop =13+uoff
+c
+c --- no .[ab] files for 1-D cases (<=6x6) or for dsur1p surface cases.
+c
+ if (max(itdm,jtdm).gt.6 .and.
+ & .not.(dsur1p .and. kkout.eq.1)) then !not 1-D output
+c
+ call zaiopf(flnmarc(1:ldot)//'.a', 'new', nopa)
+ if (mnproc.eq.1) then
+ open (unit=nop,file=flnmarc(1:ldot)//'.b',status='new') !uoff+13
+ write(nop,116) ctitle,iversn,iexpt,yrflag,itdm,jtdm
+ call flush(nop)
+ endif !1st tile
+ 116 format (a80/a80/a80/a80/
+ & i5,4x,'''iversn'' = hycom version number x10'/
+ & i5,4x,'''iexpt '' = experiment number x10'/
+ & i5,4x,'''yrflag'' = days in year flag'/
+ & i5,4x,'''idm '' = longitudinal array size'/
+ & i5,4x,'''jdm '' = latitudinal array size'/
+ & 'field time step model day',
+ & ' k dens min max')
+c
+c --- surface fields
+c
+ coord=0.
+c
+ call zaiowr(montg1,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+c --- identify the equation of state on the first record
+ write (nop,117) 'montg1 ',nstep,time,sigver,thbase,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(srfhgt,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'srfhgt ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ if (sshflg.ne.0) then
+c --- write out steric SSH.
+ call zaiowr(steric,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'steric ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ endif !sshflg
+c
+ call zaiowr(surflx,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'surflx ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(salflx,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'salflx ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+c
+ call zaiowr(dpbl,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'bl_dpth ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(dpmixl(1-nbdy,1-nbdy,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'mix_dpth',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ if (iceflg.ne.0) then
+ call zaiowr(covice,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'covice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(thkice,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'thkice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(temice,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'temice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ endif !write ice fields
+c
+c --- depth averaged fields
+c
+ call zaiowr(ubavg(1-nbdy,1-nbdy,n),iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'u_btrop ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(vbavg(1-nbdy,1-nbdy,n),iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'v_btrop ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+c
+c --- layer loop.
+c
+ do 75 k=1,kkout
+ coord=sigma(k)
+ call zaiowr(u(1-nbdy,1-nbdy,k,n),iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'u-vel. ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(v(1-nbdy,1-nbdy,k,n),iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'v-vel. ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(dp(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'thknss ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(temp(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'temp ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(saln(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'salin ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+c
+c --- no tracers or diffusion for single layer case
+c
+ if (kkout.gt.1) then
+ do ktr= 1,ntracr
+ call zaiowr(tracer(1-nbdy,1-nbdy,k,n,ktr),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'tracer ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !ktr
+ if (difout) then
+ call zaiowr(vcty(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'viscty ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(dift(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 't-diff ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(difs(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 's-diff ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ endif !difout
+ endif !kkout>1
+ 75 continue
+c
+ 117 format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
+c
+c --- output time-averaged mass fluxes, if required
+c
+ if (.not. (mxlkpp .or. mxlmy .or. mxlgiss) .and. kkout.eq.kk) then
+ do k=1,kk
+ coord=sigma(k)
+ call zaiowr(diaflx(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,118) 'diafx',intvl,nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ 118 format (a5,a3,' =',i11,f11.3,i3,f7.3,1p2e16.7)
+ enddo
+ endif !diaflx
+c
+ close (unit=nop)
+ call zaiocl(nopa)
+c
+ call xcsync(no_flush)
+c
+ endif !not 1-D
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ if (relaxf .and. sstflg.le.1) then
+ sstc = twall(itest,jtest,1,lc0)*wc0+
+ & twall(itest,jtest,1,lc1)*wc1+
+ & twall(itest,jtest,1,lc2)*wc2+
+ & twall(itest,jtest,1,lc3)*wc3
+ else !synoptic observed sst
+ sstc = seatmp(itest,jtest,l0)*w0+
+ & seatmp(itest,jtest,l1)*w1+
+ & seatmp(itest,jtest,l2)*w2+
+ & seatmp(itest,jtest,l3)*w3
+ endif
+ sssc = swall(itest,jtest,1,lc0)*wc0+
+ & swall(itest,jtest,1,lc1)*wc1+
+ & swall(itest,jtest,1,lc2)*wc2+
+ & swall(itest,jtest,1,lc3)*wc3
+ open (unit=nop,file=flnmarc(1:ldot)//'.txt',status='new') !uoff+13
+ write (nop,'(3a / a,6i7,2f8.1,i7,i7.4,i7.3,i7.2)')
+ & '## expt idm jdm kdm',
+ & ' itest jtest lontst lattst',
+ & ' yrflag year day hr',
+ & '##',iexpt, itdm, jtdm, kdm,
+ & ittest,jttest,
+ & mod(plon(itest,jtest),360.0),plat(itest,jtest),
+ & yrflag, iyear, iday, ihour
+ write (nop,'(7a / a,f10.3, f8.2,4f8.1, 2f9.2,2f8.4,
+ & f9.5,4f9.3, 2f8.3, 3f8.3, 4f8.2)')
+ & '## model-day',
+ & ' srfhgt sswflx mixflx surflx sstflx',
+ & ' E-P sssE-P bhtflx buoflx',
+ & ' ustar hekman dpbbl dpbl dpmixl',
+ & ' tclim sclim',
+ & ' tmix smix thmix umix vmix',
+ & ' ubavg vbavg',
+ & '#',time, !model-day
+ & srfhgt(itest,jtest)*100.0/g, !cm
+ & sswflx(itest,jtest), !W/m**2
+ & mixflx(itest,jtest), !W/m**2
+ & surflx(itest,jtest), !W/m**2
+ & sstflx(itest,jtest), !W/m**2
+ & salflx(itest,jtest)*thref*8.64E7/saln(itest,jtest,1,n),!mm/day
+ & sssflx(itest,jtest)*thref*8.64E7/saln(itest,jtest,1,n),!mm/day
+ & bhtflx(itest,jtest)*1.e6, !1.e6*m**2/sec**3
+ & buoflx(itest,jtest)*1.e6, !1.e6*m**2/sec**3
+ & ustar(itest,jtest), !m/s?
+ & min(hekman(itest,jtest), 9999.999), !m
+ & min( dpbbl(itest,jtest) *qonem, 9999.999), !m
+ & min( dpbl(itest,jtest) *qonem, 9999.999), !m
+ & min(dpmixl(itest,jtest,n)*qonem, 9999.999), !m
+ & sstc, !degC
+ & sssc, !psu
+ & tmix(itest,jtest), !degC
+ & smix(itest,jtest), !psu
+ & thmix(itest,jtest)+thbase, !SigmaT
+ & max(-999.99,min(999.99,
+ & (umix(itest,jtest)+ubavg(itest,jtest,n))*100.0)), !cm/s
+ & max(-999.99,min(999.99,
+ & (vmix(itest,jtest)+vbavg(itest,jtest,n))*100.0)), !cm/s
+ & max(-999.99,min(999.99,
+ & ubavg(itest,jtest,n)*100.0)), !cm/s
+ & max(-999.99,min(999.99,
+ & vbavg(itest,jtest,n)*100.0)) !cm/s
+ if (iceflg.ne.0) then
+ write (nop,'(2a / a,f10.3, 3f8.2,2f8.1,f9.2)')
+ & '## model-day',
+ & ' covice thkice temice flxice fswice iceE-P',
+ & '#',time, !model-day
+ & covice(itest,jtest)*100.0, !%
+ & thkice(itest,jtest), !m
+ & temice(itest,jtest), !degC
+ & flxice(itest,jtest), !W/m**2
+ & fswice(itest,jtest), !W/m**2
+ & sflice(itest,jtest)*thref*8.64E7/saln(itest,jtest,1,n) !mm/day
+ endif !iceflg
+ if (ntracr.eq.0) then
+ write(cformat,'(a)')
+ & '(3a / (i4,2f8.2,3f8.3,f9.3,f10.3,2f8.2))'
+ else
+ write(cformat,'(a,i2,a,i2,a)')
+ & '(3a,', ntracr,
+ & 'a / (i4,2f8.2,3f8.3,f9.3,f10.3,2f8.2,', ntracr,
+ & 'f8.3))'
+ endif
+ write (nop,cformat)
+ & '# k',
+ & ' utot vtot temp saln dens',
+ & ' thkns dpth viscty t-diff',
+ & (' tracer',ktr=1,ntracr),
+ & (k,
+ & max(-999.99,min(999.99,
+ & (u(itest,jtest,k,n)+ubavg(itest,jtest,n))*100.0)), !cm/s
+ & max(-999.99,min(999.99,
+ & (v(itest,jtest,k,n)+vbavg(itest,jtest,n))*100.0)), !cm/s
+ & temp(itest,jtest,k,n), !degC
+ & saln(itest,jtest,k,n), !psu
+ & th3d(itest,jtest,k,n)+thbase, !SigmaT
+ & dp(itest,jtest,k,n)*qonem, !m
+ & (p(itest,jtest,k+1)+p(itest,jtest,k))*0.5*qonem, !m
+ & vcty(itest,jtest,k+1)*1.e4, !m**2/s*2
+ & dift(itest,jtest,k+1)*1.e4, !m**2/s*2
+ & (tracer(itest,jtest,k,n,ktr),ktr=1,ntracr), !0-999?
+ & k=1,kk)
+ close (unit=nop)
+ endif !test point tile
+c
+ call xcsync(no_flush)
+cccc
+cccc --- output to line printer
+cccc
+ccc call prtmsk(ip,srfhgt,util3,idm,ii,jj,0.,100.0/g,
+ccc . 'sea surface height (cm)')
+ccc if(mxlkpp) call prtmsk(ip,dpbl,util3,idm,ii,jj,0.,1.*qonem,
+ccc . 'turb. b.l. depth (m)')
+ccc call prtmsk(ip,dpmixl,util3,idm,ii,jj,0.,1.*qonem,
+ccc . 'mixed layer depth (m)')
+ccc call prtmsk(ip,tmix,util3,idm,ii,jj,0.,10.,
+ccc . 'mix.layer temp. (.1 deg)')
+ccc call prtmsk(ip,smix,util3,idm,ii,jj,35.,100.,
+ccc . 'mx.lay. salin. (.01 mil)')
+ccc!$OMP PARALLEL DO PRIVATE(j,l,i)
+ccc!$OMP& SCHEDULE(STATIC,jblk)
+ccc do j=1-margin,jj+margin
+ccc do l=1,isu(j)
+ccc do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ccc util1(i,j)=umix(i,j)+ubavg(i,j,n)
+ccc enddo
+ccc enddo
+ccc do l=1,isv(j)
+ccc do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ccc util2(i,j)=vmix(i,j)+vbavg(i,j,n)
+ccc enddo
+ccc enddo
+ccc enddo
+ccc!$OMP END PARALLEL DO
+ccc call prtmsk(iu(2,1),util1(2,1),util3,idm,ii-2,jj,0.,1000.,
+ccc . 'mix.layer u vel. (mm/s)')
+ccc call prtmsk(iv(1,2),util2(1,2),util3,idm,ii,jj-2,0.,1000.,
+ccc . 'mix.layer v vel. (mm/s)')
+ccc call prtmsk(iu(2,1),ubavg(2,1,n),util3,idm,ii-2,jj,0.,1000.,
+ccc . 'barotrop. u vel. (mm/s)')
+ccc call prtmsk(iv(2,1),vbavg(1,2,n),util3,idm,ii,jj-2,0.,1000.,
+ccc . 'barotrop. v vel. (mm/s)')
+ return
+ end subroutine archiv
+
+ subroutine archiv_tile(n, kkout, iyear,iday,ihour, intvl)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer n, kkout, iyear,iday,ihour
+ real sssc,sstc
+ character intvl*3
+c
+ include 'stmt_fns.h'
+c
+c --- write a partial archive file on a tile by tile basis.
+c
+ character*12 cdir
+ character*80 cformat
+ logical lexist
+ integer i,j,k,ktr,l,ldot,nop,nopa
+ real coord,xmin,xmax
+c
+c --- only write archive when the corresponing directory exists
+c
+ write(cdir,'(a6,i5.5,a1)') 'ARCHT/',mnproc,'/'
+ inquire(file=cdir(1:11),exist=lexist)
+ if (.not.lexist) then
+ call xcsync(no_flush) !called on all tiles, see end of routine
+ return
+ endif
+c
+ ldot = index(flnmarct,'.',back=.true.)
+ if (ldot.eq.0) then
+ if (mnproc.eq.1) then
+ write (lp,*) 'need decimal point in flnmarct'
+ write (lp,*) 'flnmarct = ',trim(flnmarct)
+ endif
+ call xchalt('(flnmarct)')
+ stop '(flnmarct)'
+ endif
+ ldot = min(ldot,len(flnmarct)-11) !need 11 characters for archive date
+c
+ if (tilefq.ge.1.0/24.0) then
+c --- indicate the archive date
+ write(flnmarct(ldot+1:ldot+11),'(i4.4,a1,i3.3,a1,i2.2)')
+ & iyear,'_',iday,'_',ihour
+ ldot=ldot+11
+ else
+c --- indicate the archive time step
+ write(flnmarct(ldot+1:ldot+11),'(i11.11)') nstep
+ ldot=ldot+11
+ endif
+ nopa=13
+ nop =13+uoff
+c
+ call ztiopf(cdir//flnmarct(1:ldot)//'.A', 'new', nopa)
+ open (unit=nop,file=cdir//flnmarct(1:ldot)//'.B',status='new') !uoff+13
+ write(nop,116) ctitle,iversn,iexpt,yrflag,i0+1,j0+1,ii,jj
+ call flush(nop)
+ 116 format (a80/a80/a80/a80/
+ & i5,4x,'''iversn'' = hycom version number x10'/
+ & i5,4x,'''iexpt '' = experiment number x10'/
+ & i5,4x,'''yrflag'' = days in year flag'/
+ & i5,4x,'''i1 '' = longitudinal array starting index'/
+ & i5,4x,'''j1 '' = latitudinal array starting index'/
+ & i5,4x,'''ii '' = longitudinal array size'/
+ & i5,4x,'''jj '' = latitudinal array size'/
+ & 'field time step model day',
+ & ' k dens min max')
+c
+c --- surface fields
+c
+ coord=0.
+c
+ call ztiowr(montg1,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+c --- identify the equation of state on the first record
+ write (nop,117) 'montg1 ',nstep,time,sigver,thbase,xmin,xmax
+ call flush(nop)
+ call ztiowr(srfhgt,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'srfhgt ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ if (sshflg.ne.0) then
+c --- write out steric SSH.
+ call ztiowr(steric,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'steric ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !sshflg
+c
+ call ztiowr(surflx,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'surflx ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(salflx,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'salflx ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+c
+ call ztiowr(dpbl,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'bl_dpth ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(dpmixl(1-nbdy,1-nbdy,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'mix_dpth',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ if (iceflg.ne.0) then
+ call ztiowr(covice,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'covice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(thkice,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'thkice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(temice,ip,.true., xmin,xmax, nopa, .false.)
+ write (nop,117) 'temice ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !write ice fields
+c
+c --- depth averaged fields
+c
+ call ztiowr(ubavg(1-nbdy,1-nbdy,n),iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'u_btrop ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(vbavg(1-nbdy,1-nbdy,n),iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'v_btrop ',nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+c
+c --- layer loop.
+c
+ do 75 k=1,kkout
+ coord=sigma(k)
+ call ztiowr(u(1-nbdy,1-nbdy,k,n),iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'u-vel. ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(v(1-nbdy,1-nbdy,k,n),iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'v-vel. ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(dp(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'thknss ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(temp(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'temp ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(saln(1-nbdy,1-nbdy,k,n),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'salin ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ do ktr= 1,ntracr
+ call ztiowr(tracer(1-nbdy,1-nbdy,k,n,ktr),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'tracer ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ enddo !ktr
+ if (difout) then
+ call ztiowr(vcty(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 'viscty ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(dift(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 't-diff ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ call ztiowr(difs(1-nbdy,1-nbdy,k+1),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ write (nop,117) 's-diff ',nstep,time,k,coord,xmin,xmax
+ call flush(nop)
+ endif
+ 75 continue
+c
+ 117 format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
+c
+ close (unit=nop)
+ call ztiocl(nopa)
+c
+ call xcsync(no_flush) !called on all tiles, see lexist above
+ return
+ end subroutine archiv_tile
+c>
+c> Revision history
+c>
+c> Nov 2002 - additional surface data in .txt output
+c> Jun 2006 - dsur1p for .txt only surface output
+c> Jun 2006 - archi .txt output
+c> May 2007 - no diaflx output for K-profile based mixed layer models
+c> May 2007 - removed mixed layer fields and th3d from the archive file
+c> Feb 2008 - optionally added steric SSH to the archive file
+c> Jun 2008 - added archiv_tile for per-tile archive output
diff --git a/src_2.2.18_3_one/barotp.f b/src_2.2.18_3_one/barotp.f
new file mode 100755
index 0000000..fee0d25
--- /dev/null
+++ b/src_2.2.18_3_one/barotp.f
@@ -0,0 +1,408 @@
+ subroutine barotp(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+c
+c --- micom version 2.8
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ------------------------------------------------------------------------
+c --- advance barotropic equations.
+c --- on entry: -n- is time t-dt, -m- is time t
+c --- on exit: -m- is time t, -n- is time t+dt
+c --- time level 3 is only used internally (n and m are always 1 or 2).
+c
+c --- LeapFrog version based on:
+c --- Y. Morel, Baraille, R., Pichon A. (2007) "Time splitting and
+c --- linear stability of the slow part of the barotropic component",
+c --- Ocean Modeling (submitted)
+c --- ------------------------------------------------------------------------
+c
+ logical lpipe_barotp
+ parameter (lpipe_barotp=.false.)
+ logical ldebug_barotp
+ parameter (ldebug_barotp=.false.)
+c
+ real q,pbudel,pbvdel,utndcy,vtndcy
+ real*8 sump
+ integer i,j,l,lll,ml,nl,mn,lstep1,mbdy
+c
+ mbdy = 6
+c
+ call xctilr(utotn( 1-nbdy,1-nbdy ),1, 1, 6,6, halo_uv)
+ call xctilr(vtotn( 1-nbdy,1-nbdy ),1, 1, 6,6, halo_vv)
+c
+ if (lpipe .and. lpipe_barotp) then
+c --- compare two model runs.
+ call pipe_compare_sym2(utotn, iu,'barotp:utotn',
+ & vtotn, iv,'barotp:vtotn')
+ call pipe_compare_sym1(pvtrop,iq,'barotp:pvtrp')
+ endif
+c
+c --- explicit time integration of barotropic flow (forward-backward scheme)
+c --- in order to combine forward-backward scheme with leapfrog treatment of
+c --- coriolis term, v-eqn must be solved before u-eqn every other time step
+c
+ if (btrlfr .and. delt1.ne.baclin) then !not on very 1st time step
+C --- start at time level t-dt and go to t+dt.
+ lstep1 = lstep + lstep !more stable, but also more expensive
+ else
+C --- start at time level t and go to t+dt.
+ lstep1 = lstep !original, less stable, method
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do i=1,ii
+ pbavg(i,j,n) = pbavg(i,j,m)
+ ubavg(i,j,n) = ubavg(i,j,m)
+ vbavg(i,j,n) = vbavg(i,j,m)
+ enddo !i
+ enddo !j
+ endif !btrlfr
+c
+ do 840 lll=1,lstep1,2
+c
+ call xctilr(pbavg( 1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_ps)
+ call xctilr(ubavg( 1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_uv)
+ call xctilr(vbavg( 1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_vv)
+c
+ if (lpipe .and. lpipe_barotp) then
+ call pipe_compare_sym1(
+ & pbavg(1-nbdy,1-nbdy,nl),ip,'barot+:pbavn')
+ call pipe_compare_sym2(
+ & ubavg(1-nbdy,1-nbdy,nl),iu,'barot+:ubavn',
+ & vbavg(1-nbdy,1-nbdy,nl),iv,'barot+:vbavn')
+ call pipe_compare_sym1(
+ & pbavg(1-nbdy,1-nbdy,ml),ip,'barot+:pbavm')
+ call pipe_compare_sym2(
+ & ubavg(1-nbdy,1-nbdy,ml),iu,'barot+:ubavm',
+ & vbavg(1-nbdy,1-nbdy,ml),iv,'barot+:vbavm')
+ endif
+c
+c --- odd minor time step.
+c
+ ml=n
+ nl=3
+c
+c --- continuity equation
+c
+c --- rhs: pbavg, ubavg+, vbavg+
+c --- lhs: pbavg
+c
+ margin = mbdy - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,pbudel,pbvdel)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pbudel = ubavg(i+1,j,ml)*(depthu(i+1,j)*scuy(i+1,j))
+ & -ubavg(i ,j,ml)*(depthu(i ,j)*scuy(i ,j))
+ pbvdel = vbavg(i,j+1,ml)*(depthv(i,j+1)*scvx(i,j+1))
+ & -vbavg(i,j ,ml)*(depthv(i,j )*scvx(i,j ))
+ pbavg(i,j,nl)=
+ & ((1.-wbaro)*pbavg(i,j,ml)+
+ & wbaro *pbavg(i,j,nl) )-
+ & (1.+wbaro)*dlt*(pbudel + pbvdel)*scp2i(i,j)
+ enddo
+ enddo
+ enddo
+c
+ mn=ml
+c
+c --- u momentum equation, 1st
+c
+c --- rhs: pbavg+, vbavg+, pvtrop+
+c --- lhs: ubavg
+c
+ margin = margin - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,utndcy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ utndcy=-thref*(pbavg(i,j,nl)-pbavg(i-1,j,nl))*scuxi(i,j)+
+ & ((vbavg(i ,j, mn)*depthv(i ,j)
+ & +vbavg(i ,j+1,mn)*depthv(i ,j+1))+
+ & (vbavg(i-1,j, mn)*depthv(i-1,j)
+ & +vbavg(i-1,j+1,mn)*depthv(i-1,j+1)))*
+ & (0.125*(pvtrop(i,j)+pvtrop(i,j+1)))
+c
+ ubavg(i,j,nl)=
+ & ((1.-wbaro)*ubavg(i,j,ml)+
+ & wbaro *ubavg(i,j,nl))+
+ & (1.+wbaro)*dlt*(utndcy+utotn(i,j))
+c
+* if (ldebug_barotp .and. i.eq.itest.and.j.eq.jtest) then
+* write (lp,'(i9,2i5,i3,3x,a,5f7.3)')
+* & nstep,i+i0,j+j0,lll,
+* & 'u_old,u_new,p_grad,corio,u_star =',
+* & ubavg(i,j,ml),ubavg(i,j,nl),
+* & -thref*(pbavg(i,j,nl)-pbavg(i-1,j,nl))*scuxi(i,j)*dlt,
+* & (vbavg(i ,j, mn)*depthv(i ,j)
+* & +vbavg(i ,j+1,mn)*depthv(i ,j+1)
+* & +vbavg(i-1,j, mn)*depthv(i-1,j)
+* & +vbavg(i-1,j+1,mn)*depthv(i-1,j+1))
+* & *(pvtrop(i,j)+pvtrop(i,j+1))
+* & *.125 * dlt,utotn(i,j) * dlt
+* endif
+ enddo
+ enddo
+ enddo
+c
+ mn = nl
+c
+c --- v momentum equation, 2nd
+c --- rhs: pbavg+, ubavg+, pvtrop+
+c --- lhs: vbavg
+c
+ margin = margin - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,vtndcy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vtndcy=-thref*(pbavg(i,j,nl)-pbavg(i,j-1,nl))*scvyi(i,j)-
+ & ((ubavg(i, j ,mn)*depthu(i, j )
+ & +ubavg(i+1,j ,mn)*depthu(i+1,j ))+
+ & (ubavg(i, j-1,mn)*depthu(i, j-1)
+ & +ubavg(i+1,j-1,mn)*depthu(i+1,j-1)))*
+ & (0.125*(pvtrop(i,j)+pvtrop(i+1,j)))
+c
+ vbavg(i,j,nl)=
+ & ((1.-wbaro)*vbavg(i,j,ml)+
+ & wbaro *vbavg(i,j,nl))+
+ & (1.+wbaro)*dlt*(vtndcy+vtotn(i,j))
+c
+* if (ldebug_barotp .and. i.eq.itest.and.j.eq.jtest) then
+* write (lp,'(i9,2i5,i3,3x,a,5f7.3)')
+* & nstep,i+i0,j+j0,lll,
+* & 'v_old,v_new,p_grad,corio,v_star =',
+* & vbavg(i,j,ml),vbavg(i,j,nl),
+* & -thref*(pbavg(i,j,nl)-pbavg(i,j-1,nl))*scvyi(i,j)*dlt,
+* & -(ubavg(i, j ,mn)*depthu(i,j )
+* & +ubavg(i+1,j ,mn)*depthu(i+1,j )
+* & +ubavg(i, j-1,mn)*depthu(i,j-1)
+* & +ubavg(i+1,j-1,mn)*depthu(i+1,j-1))
+* & *(pvtrop(i,j)+pvtrop(i+1,j))
+* & *.125 * dlt, vtotn(i,j) * dlt
+* endif
+ enddo
+ enddo
+ enddo
+c
+ if (ldebug_barotp) then
+ call xcsync(flush_lp)
+ endif
+c
+ if (lbflag.eq.1) then
+ call latbdp(nl)
+ elseif (lbflag.eq.2) then
+ call latbdt(nl,lll)
+ elseif (lbflag.eq.3) then
+ call latbdf(nl,lll)
+ endif
+c
+ if (lpipe .and. lpipe_barotp) then
+ call pipe_compare_sym1(
+ & pbavg(1-nbdy,1-nbdy,nl),ip,'barot+:pbavn')
+ call pipe_compare_sym2(
+ & ubavg(1-nbdy,1-nbdy,nl),iu,'barot+:ubavn',
+ & vbavg(1-nbdy,1-nbdy,nl),iv,'barot+:vbavn')
+ call pipe_compare_sym1(
+ & pbavg(1-nbdy,1-nbdy,ml),ip,'barot+:pbavm')
+ call pipe_compare_sym2(
+ & ubavg(1-nbdy,1-nbdy,ml),iu,'barot+:ubavm',
+ & vbavg(1-nbdy,1-nbdy,ml),iv,'barot+:vbavm')
+ endif
+c
+c --- even minor time step.
+c
+ ml=3
+ nl=n
+c
+c --- continuity equation
+c
+c --- rhs: pbavg, ubavg+, vbavg+
+c --- lhs: pbavg
+c
+ margin = mbdy - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,pbudel,pbvdel)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pbudel = ubavg(i+1,j,ml)*(depthu(i+1,j)*scuy(i+1,j))
+ & -ubavg(i ,j,ml)*(depthu(i ,j)*scuy(i ,j))
+ pbvdel = vbavg(i,j+1,ml)*(depthv(i,j+1)*scvx(i,j+1))
+ & -vbavg(i,j ,ml)*(depthv(i,j )*scvx(i,j ))
+ pbavg(i,j,nl)=
+ & ((1.-wbaro)*pbavg(i,j,ml)+
+ & wbaro *pbavg(i,j,nl) )-
+ & (1.+wbaro)*dlt*(pbudel + pbvdel)*scp2i(i,j)
+ enddo
+ enddo
+ enddo
+c
+ mn=ml
+c
+c --- v momentum equation, 1st
+c
+c --- rhs: pbavg+, ubavg+, pvtrop+
+c --- lhs: vbavg
+c
+ margin = margin - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,vtndcy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vtndcy=-thref*(pbavg(i,j,nl)-pbavg(i,j-1,nl))*scvyi(i,j)-
+ & ((ubavg(i, j ,mn)*depthu(i, j )
+ & +ubavg(i+1,j ,mn)*depthu(i+1,j ))+
+ & (ubavg(i, j-1,mn)*depthu(i, j-1)
+ & +ubavg(i+1,j-1,mn)*depthu(i+1,j-1)))*
+ & (0.125*(pvtrop(i,j)+pvtrop(i+1,j)))
+c
+ vbavg(i,j,nl)=
+ & ((1.-wbaro)*vbavg(i,j,ml)+
+ & wbaro *vbavg(i,j,nl))+
+ & (1.+wbaro)*dlt*(vtndcy+vtotn(i,j))
+c
+* if (ldebug_barotp .and. i.eq.itest.and.j.eq.jtest) then
+* write (lp,'(i9,2i5,i3,3x,a,5f7.3)')
+* & nstep,i+i0,j+j0,lll+1,
+* & 'v_old,v_new,p_grad,corio,v_star =',
+* & vbavg(i,j,ml),vbavg(i,j,nl),
+* & -thref*(pbavg(i,j,nl)-pbavg(i,j-1,nl))*scvyi(i,j)*dlt,
+* & -(ubavg(i, j ,mn)*depthu(i,j )
+* & +ubavg(i+1,j ,mn)*depthu(i+1,j )
+* & +ubavg(i, j-1,mn)*depthu(i,j-1)
+* & +ubavg(i+1,j-1,mn)*depthu(i+1,j-1))
+* & *(pvtrop(i,j)+pvtrop(i+1,j))
+* & *.125 * dlt, vtotn(i,j) * dlt
+* endif
+ enddo
+ enddo
+ enddo
+c
+ mn=nl
+c
+c --- u momentum equation, 2nd
+c
+c --- rhs: pbavg+, vbavg+, pvtrop+
+c --- lhs: ubavg
+c
+ margin = margin - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,utndcy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ utndcy=-thref*(pbavg(i,j,nl)-pbavg(i-1,j,nl))*scuxi(i,j)+
+ & ((vbavg(i ,j, mn)*depthv(i ,j)
+ & +vbavg(i ,j+1,mn)*depthv(i ,j+1))+
+ & (vbavg(i-1,j, mn)*depthv(i-1,j)
+ & +vbavg(i-1,j+1,mn)*depthv(i-1,j+1)))*
+ & (0.125*(pvtrop(i,j)+pvtrop(i,j+1)))
+c
+ ubavg(i,j,nl)=
+ & ((1.-wbaro)*ubavg(i,j,ml)+
+ & wbaro *ubavg(i,j,nl))+
+ & (1.+wbaro)*dlt*(utndcy+utotn(i,j))
+c
+* if (ldebug_barotp .and. i.eq.itest.and.j.eq.jtest) then
+* write (lp,'(i9,2i5,i3,3x,a,5f7.3)')
+* & nstep,i+i0,j+j0,lll+1,
+* & 'u_old,u_new,p_grad,corio,u_star =',
+* & ubavg(i,j,ml),ubavg(i,j,nl),
+* & -thref*(pbavg(i,j,nl)-pbavg(i-1,j,nl))*scuxi(i,j)*dlt,
+* & (vbavg(i ,j, mn)*depthv(i ,j)
+* & +vbavg(i ,j+1,mn)*depthv(i ,j+1)
+* & +vbavg(i-1,j, mn)*depthv(i-1,j)
+* & +vbavg(i-1,j+1,mn)*depthv(i-1,j+1))
+* & *(pvtrop(i,j)+pvtrop(i,j+1))
+* & *.125 * dlt,utotn(i,j) * dlt
+* endif
+ enddo
+ enddo
+ enddo
+c
+ if (ldebug_barotp) then
+ call xcsync(flush_lp)
+ endif
+c
+ if (lbflag.eq.1) then
+ call latbdp(nl)
+ elseif (lbflag.eq.2) then
+ call latbdt(nl,lll+1)
+ elseif (lbflag.eq.3) then
+ call latbdf(nl,lll+1)
+ endif
+c
+ 840 continue ! lll=1,lstep1,2
+c
+ if (lbflag.eq.1) then
+c
+c --- correct mean height.
+c --- this should not be required - so there may be a bug in the bc.
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,sump)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j) = pbavg(i,j,nl)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+ call xcsum(sump, util1,ip)
+ q = sump/area
+c
+c --- rhs: pbavg
+c --- lhs: pbavg
+c
+ margin = 0
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pbavg(i,j,1) = pbavg(i,j,1) - q
+ pbavg(i,j,2) = pbavg(i,j,2) - q
+ pbavg(i,j,3) = pbavg(i,j,3) - q
+ enddo
+ enddo
+ enddo
+ endif
+ if (lpipe .and. lpipe_barotp) then
+ call pipe_compare(pbavg(1-nbdy,1-nbdy,1), ip,'barotp:pbav1')
+ call pipe_compare(pbavg(1-nbdy,1-nbdy,2), ip,'barotp:pbav2')
+ call pipe_compare(pbavg(1-nbdy,1-nbdy,3), ip,'barotp:pbav3')
+ endif
+c
+ return
+ end subroutine barotp
+c
+c
+c> Revision history:
+c>
+c> Mar. 1995 - changed vertical velocity averaging interval from 10 cm to 1 m
+c> (loops 33,35)
+c> Mar. 1995 - changed order of loop nesting in loop 842
+c> July 1997 - eliminated 3-D arrays -uold,vold- (used in time smoothing)
+c> Aug. 1997 - transferred loops preceding loop 840 to momeq2.f
+c> Jan. 2000 - added latbdp for lateral boundary ports
+c> Aug. 2001 - two barotropic time steps per loop, for halo efficiency
+c> Nov. 2006 - added lbflag==3 (latbdf) and thref_bt (mod_tides)
+c> Nov. 2006 - removed thref_bt (and mod_tides)
+c> Apr. 2007 - added btrlfr: leapfrog time step; see also momtum
diff --git a/src_2.2.18_3_one/bigrid.f b/src_2.2.18_3_one/bigrid.f
new file mode 100755
index 0000000..54796f1
--- /dev/null
+++ b/src_2.2.18_3_one/bigrid.f
@@ -0,0 +1,461 @@
+ subroutine bigrid(depth, mapflg, util1,util2,util3)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & depth,util1,util2,util3
+ integer mapflg
+c
+c --- set loop bounds for irregular basin in c-grid configuration
+c --- q,u,v,p are vorticity, u-velocity, v-velocity, and mass points, resp.
+c --- 'depth' = basin depth array, zero values indicate land
+c
+ integer nchar
+ parameter (nchar=120)
+ logical lperiod,larctic,lfplane
+c
+ integer i,j,nzero,isec,ifrst,ilast
+ real rnfill,aline(nchar)
+ real depmax
+ character char3*3
+c
+ character fmt*13
+ data fmt/'(i4,1x,120i1)'/
+c
+c --- is the domain periodic in longitude?
+ depmax=0.0
+ if (i0+ii.eq.itdm) then
+ do j= 1,jj
+ depmax=max(depmax,depth(ii,j))
+ enddo
+ endif
+ call xcmaxr(depmax)
+ lperiod=depmax.gt.0.0
+c
+c --- is the domain periodic in latitude?
+c --- only allowed on f-plane or full globe (across the arctic).
+ depmax=0.0
+ if (j0+jj.eq.jtdm) then
+ do i= 1,ii
+ depmax=max(depmax,depth(i,jj))
+ enddo
+ endif
+ call xcmaxr(depmax)
+ larctic=depmax.gt.0.0 .and. mapflg.ne.4
+ lfplane=depmax.gt.0.0 .and. mapflg.eq.4
+c
+c --- is this consistent with nreg (from mod_xc)?
+ if (larctic) then
+ if (.not.lperiod) then
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'arctic domain, but non-periodic'
+ call flush(lp)
+ endif
+ call xcstop('(bigrid)')
+ stop '(bigrid)'
+ else
+ nreg = 2
+ endif
+ elseif (lperiod) then
+ if (nreg.eq.-1) then ! TYPE=one or TYPE=omp
+ if (lfplane) then
+ nreg = 3 ! periodic/f-plane
+ else
+ nreg = 1 ! periodic/closed
+ endif
+ elseif (nreg.eq. 0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'periodic domain, but with nreg.eq.0'
+ call flush(lp)
+ endif
+ call xcstop('(bigrid)')
+ stop '(bigrid)'
+ endif
+ else
+ if (nreg.eq.-1) then ! TYPE=one or TYPE=omp
+ if (lfplane) then
+ nreg = 4 ! closed/f-plane
+ else
+ nreg = 0 ! closed/closed
+ endif
+ elseif (nreg.ne. 0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'closed domain, but with nreg.ne.0'
+ call flush(lp)
+ endif
+ call xcstop('(bigrid)')
+ stop '(bigrid)'
+ endif
+ endif
+c
+ if (mnproc.eq.1) then
+ write(lp,'(/a,i2)') 'bigrid: nreg =',nreg
+ if (.not.lperiod) then
+ if (lfplane) then
+ write(lp,'(a/)') 'bigrid: infinate closed basin'
+ elseif (.not.larctic) then
+ write(lp,'(a/)') 'bigrid: closed basin'
+ else
+ write(lp,'(a/)') 'bigrid: closed basin, arctic overlap'
+ endif
+ else
+ if (lfplane) then
+ write(lp,'(a/)') 'bigrid: doubly infinate basin'
+ elseif (.not.larctic) then
+ write(lp,'(a/)') 'bigrid: periodic basin'
+ else
+ write(lp,'(a/)') 'bigrid: global basin, arctic overlap'
+ endif
+ endif
+ call flush(lp)
+ endif
+c
+c --- nreg is defined, so now safe to update halo
+ call xctilr(depth,1,1, nbdy,nbdy, halo_ps)
+c
+c --- allow for non-periodic and non-arctic boundaries (part I).
+ if (.not.lfplane .and. j0.eq.0) then
+c --- south boundary is all land.
+ do j=1-nbdy,0
+ do i=1-nbdy,ii+nbdy
+ depth(i,j) = 0.0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lfplane .and. .not.larctic .and. j0+jj.eq.jtdm) then
+c --- north boundary is all land.
+ do j=jj+1,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ depth(i,j) = 0.0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lperiod .and. i0.eq.0) then
+c --- west boundary is all land.
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,0
+ depth(i,j) = 0.0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lperiod .and. i0+ii.eq.itdm) then
+c --- east boundary is all land.
+ do j=1-nbdy,jj+nbdy
+ do i=ii+1,ii+nbdy
+ depth(i,j) = 0.0
+ enddo
+ enddo
+ endif
+c
+c --- detect (and abort on) single-width inlets and 1-point seas.
+ rnfill=0.0
+ do j=1,jj
+ do i=1,ii
+ nzero=0
+ if (depth(i,j).gt.0.0) then
+ if (depth(i-1,j).le.0.0) nzero=nzero+1
+ if (depth(i+1,j).le.0.0) nzero=nzero+1
+ if (depth(i,j-1).le.0.0) nzero=nzero+1
+ if (depth(i,j+1).le.0.0) nzero=nzero+1
+************if (nzero.ge.3) then
+ if (nzero.eq.4) then
+ write (lp,'(a,i4,a,i4,a,i1,a)')
+ & 'error - dh(',i0+i,',',j0+j,') has ',
+ & nzero,' land nieghbours'
+ rnfill=rnfill+1.0
+ elseif (nzero.eq.3) then
+ write (lp,'(a,i4,a,i4,a,i1,a)')
+ & 'warning - dh(',i0+i,',',j0+j,') has ',
+ & nzero,' land nieghbours'
+* rnfill=rnfill+1.0 !only a warning, don't update rnfill
+ end if
+ end if
+ enddo
+ enddo
+ call xcsync(flush_lp)
+ call xcmaxr(rnfill)
+ if (rnfill.gt.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'Must correct bathymetry before running HYCOM'
+ call flush(lp)
+ endif
+ call xcstop('(bigrid)')
+ stop '(bigrid)'
+ endif
+c
+c --- start out with masks as land everywhere
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jdm+nbdy
+ do i=1-nbdy,idm+nbdy
+ ip(i,j)=0
+ iq(i,j)=0
+ iu(i,j)=0
+ iv(i,j)=0
+ enddo
+ enddo
+c
+c --- mass points are defined where water depth is greater than zero
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ if (depth(i,j).gt.0.) then
+ ip(i,j)=1
+ endif
+ enddo
+ enddo
+c
+c --- u,v points are located halfway between any 2 adjoining mass points
+c --- 'interior' q points require water on all 4 sides.
+c --- 'promontory' q points require water on 3 (or at least 2
+c --- diametrically opposed) sides
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do i=1,ii
+ if (ip(i-1,j).gt.0.and.ip(i,j).gt.0) then
+ iu(i,j)=1
+ endif
+ if (ip(i,j-1).gt.0.and.ip(i,j).gt.0) then
+ iv(i,j)=1
+ endif
+ if (min(ip(i,j),ip(i-1,j),ip(i,j-1),ip(i-1,j-1)).gt.0) then
+ iq(i,j)=1
+ elseif ((ip(i ,j).gt.0.and.ip(i-1,j-1).gt.0).or.
+ & (ip(i-1,j).gt.0.and.ip(i ,j-1).gt.0) ) then
+ iq(i,j)=1
+ endif
+ util1(i,j)=iu(i,j)
+ util2(i,j)=iv(i,j)
+ util3(i,j)=iq(i,j)
+ enddo
+ enddo
+ call xctilr(util1,1,1, nbdy,nbdy, halo_us)
+ call xctilr(util2,1,1, nbdy,nbdy, halo_vs)
+ call xctilr(util3,1,1, nbdy,nbdy, halo_qs)
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ iu(i,j)=util1(i,j)
+ iv(i,j)=util2(i,j)
+ iq(i,j)=util3(i,j)
+ enddo
+ enddo
+c
+c --- allow for non-periodic and non-arctic boundaries (part II).
+ if (.not.lfplane .and. j0.eq.0) then
+c --- south boundary is all land.
+ do j=1-nbdy,0
+ do i=1-nbdy,ii+nbdy
+ iq(i,j) = 0
+ iu(i,j) = 0
+ iv(i,j) = 0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lfplane .and. .not.larctic .and. j0+jj.eq.jtdm) then
+c --- north boundary is all land.
+ do j=jj+1,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ iq(i,j) = 0
+ iu(i,j) = 0
+ iv(i,j) = 0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lperiod .and. i0.eq.0) then
+c --- west boundary is all land.
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,0
+ iq(i,j) = 0
+ iu(i,j) = 0
+ iv(i,j) = 0
+ enddo
+ enddo
+ endif
+c
+ if (.not.lperiod .and. i0+ii.eq.itdm) then
+c --- east boundary is all land.
+ do j=1-nbdy,jj+nbdy
+ do i=ii+1,ii+nbdy
+ iq(i,j) = 0
+ iu(i,j) = 0
+ iv(i,j) = 0
+ enddo
+ enddo
+ endif
+c
+c --- determine loop bounds for vorticity points, including interior and
+c --- promontory points
+ call indxi(iq,ifq,ilq,isq)
+ call indxj(iq,jfq,jlq,jsq)
+c
+c --- determine loop indices for mass and velocity points
+ call indxi(ip,ifp,ilp,isp)
+ call indxj(ip,jfp,jlp,jsp)
+ call indxi(iu,ifu,ilu,isu)
+ call indxj(iu,jfu,jlu,jsu)
+ call indxi(iv,ifv,ilv,isv)
+ call indxj(iv,jfv,jlv,jsv)
+c
+c --- write out -ip- array, if it is not too big
+c --- data are written in strips nchar points wide
+ if (max(itdm,jtdm).le.2*nchar) then
+ util1(1:ii,1:jj) = ip(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'ip array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(10*nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+ endif ! small region
+c
+ return
+ end
+c
+c
+ subroutine indxi(ipt,if,il,is)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & ipt
+ integer, dimension (1-nbdy:jdm+nbdy,ms) ::
+ & if,il
+ integer, dimension (1-nbdy:jdm+nbdy) ::
+ & is
+c
+c --- input array ipt contains 1 at grid point locations, 0 elsewhere
+c --- output is arrays if, il, is where
+c --- if(j,k) gives row index of first point in column j for k-th section
+c --- il(j,k) gives row index of last point
+c --- is(j) gives number of sections in column j (maximum: ms)
+c
+ integer i,j,k,last
+c
+ do j=1-nbdy,jj+nbdy
+ is(j) = 0
+ do k=1,ms
+ if(j,k) = 0
+ il(j,k) = 0
+ end do
+c
+ k=1
+ last = ipt(1-nbdy,j)
+ if (last .eq. 1) then
+ if(j,k) = 1-nbdy
+ endif
+ do i=2-nbdy,ii+nbdy
+ if (last .eq. 1 .and. ipt(i,j) .eq. 0) then
+ il(j,k) = i-1
+ k = k+1
+ elseif (last .eq. 0 .and. ipt(i,j) .eq. 1) then
+ if (k .gt. ms) then
+ write(lp,'(a,i5)') 'indxi problem on proc ',mnproc
+ write(lp,'(a,2i5)')
+ & ' error in indxi -- ms too small at i,j =',i0+i,j0+j
+ call xchalt('(indxi)')
+ stop '(indxi)'
+ endif
+ if(j,k) = i
+ endif
+ last = ipt(i,j)
+ enddo
+ if (last .eq. 1) then
+ il(j,k) = ii+nbdy
+ is(j) = k
+ else
+ is(j) = k-1
+ endif
+ enddo
+ call xcsync(no_flush)
+ return
+ end
+c
+ subroutine indxj(jpt,jf,jl,js)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & jpt
+ integer, dimension (1-nbdy:idm+nbdy,ms) ::
+ & jf,jl
+ integer, dimension (1-nbdy:idm+nbdy) ::
+ & js
+c
+c --- input array jpt contains 1 at grid point locations, 0 elsewhere
+c --- output is arrays jf, jl, js where
+c --- jf(i,k) gives column index of first point in row i for k-th section
+c --- jl(i,k) gives column index of last point
+c --- js(i) gives number of sections in row i (maximum: ms)
+c
+ integer i,j,k,last
+c
+ do i=1-nbdy,ii+nbdy
+ js(i) = 0
+ do k=1,ms
+ jf(i,k) = 0
+ jl(i,k) = 0
+ end do
+c
+ k=1
+ last = jpt(i,1-nbdy)
+ if (last .eq. 1) then
+ jf(i,k) = 1-nbdy
+ endif
+ do j=2-nbdy,jj+nbdy
+ if (last .eq. 1 .and. jpt(i,j) .eq. 0) then
+ jl(i,k) = j-1
+ k = k+1
+ elseif (last .eq. 0 .and. jpt(i,j) .eq. 1) then
+ if (k .gt. ms) then
+ write(lp,'(a,i5)') 'indxj problem on proc ',mnproc
+ write(lp,'(a,2i5)')
+ & ' error in indxj -- ms too small at i,j =',i0+i,j0+j
+ call xchalt('(indxj)')
+ stop '(indxj)'
+ endif
+ jf(i,k) = j
+ endif
+ last = jpt(i,j)
+ enddo
+ if (last .eq. 1) then
+ jl(i,k) = jj+nbdy
+ js(i) = k
+ else
+ js(i) = k-1
+ endif
+ enddo
+ call xcsync(no_flush)
+ return
+ end
+c>
+c> Revision history
+c>
+c> Nov 2000 - error stop on single-width inlets and 1-point seas
+c> Oct 2008 - warning on single-width inlets
diff --git a/src_2.2.18_3_one/blkdat.F b/src_2.2.18_3_one/blkdat.F
new file mode 100755
index 0000000..dda97e3
--- /dev/null
+++ b/src_2.2.18_3_one/blkdat.F
@@ -0,0 +1,2051 @@
+ subroutine blkdat
+#if defined(USE_CCSM3)
+ use ccsm3_io ! CCSM3 I/O interface, includes common_blocks.h
+ use mod_xc, ! HYCOM communication interface
+ & only: xcstop, xcsync, mnproc
+#else
+ use mod_xc ! HYCOM communication interface
+#endif
+ use mod_incupd ! HYCOM incremental update (for data assimilation)
+ use mod_floats ! HYCOM synthetic floats, drifters and moorings
+ use mod_tides ! HYCOM tides
+ implicit none
+c
+#if ! defined(USE_CCSM3)
+ include 'common_blocks.h'
+#endif
+c
+ real day1,hybrlx,cplifq
+ integer k,kdmblk,mlflag,thflag,trcflg1
+ character sigfmt*26
+c
+ include 'stmt_fns.h'
+c
+c --- initialize common variables.
+c
+#if defined(USE_CCSM3)
+ flnminp = flnmpard
+#else
+ flnminp = './'
+#endif
+ open(unit=uoff+99,file=trim(flnminp)//'blkdat.input') !on all nodes
+c
+c --- 'lp' = logical unit number for printer output
+ lp = 6
+c
+c --- 'g' = gravitational acceleration (m/s**2)
+c --- 'thref' = reference value of specific volume (m**3/kg)
+ g = 9.806
+ thref = 1.0e-3
+c
+c --- layer thicknesses in units of pressure:
+ tenm = 98060.0 ! g/thref *10.0
+ onem = 9806.0 ! g/thref
+ tencm = 980.6 ! g/thref * 0.1
+ onecm = 98.06 ! g/thref * 0.01
+ onemm = 9.806 ! g/thref * 0.001
+c
+ qonem = 1.0/onem ! thref/g
+ qthref = 1.0/thref
+c
+c --- pi-related values
+ pi = 4.d0*atan(1.d0)
+ radian=pi/180.0
+c
+c --- four lines (80-characters) describing the simulation
+ read( uoff+99,'(a80/a80/a80/a80)') ctitle
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,'(a80/a80/a80/a80)') ctitle
+ call flush(lp)
+ endif !1st tile
+c
+c --- 'iversn' = hycom version number x10
+c --- 'iexpt' = experiment number x10
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(iversn,'iversn')
+ call blkini(iexpt, 'iexpt ')
+c
+ if (iversn.lt.22 .or. iversn.gt.22) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3,a,i3 /)')
+ & 'error - iversn must be between',22,' and',22
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+c
+c --- 'idm ' = longitudinal array size
+c --- 'jdm ' = latitudinal array size
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(itest ,'idm ')
+ call blkini(jtest ,'jdm ')
+c
+ if (itest.ne.itdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i5 /)')
+ & 'error - expected idm =',itdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (jtest.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i5 /)')
+ & 'error - expected jdm =',jtdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+c
+c --- 'itest,jtest' = grid point where detailed diagnostics are desired
+c --- itest=jtest=0 turns off all detailed diagnostics
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(ittest,'itest ')
+ call blkini(jttest,'jtest ')
+c
+ if (ittest.gt.itdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i5 /)')
+ & 'error - maximum itest is',itdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (jttest.gt.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i5 /)')
+ & 'error - maximum jtest is',jtdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+c
+c --- map global ittest,jttest to local itest,jtest
+ if (ittest.gt.i0 .and. ittest.le.i0+ii .and.
+ & jttest.gt.j0 .and. jttest.le.j0+jj ) then
+ itest = ittest - i0
+ jtest = jttest - j0
+ else
+ itest = -99
+ jtest = -99
+ endif
+c
+* if (mnproc.eq.1) then
+* write(lp,*)
+* endif !1st tile
+* call xcsync(flush_lp)
+* do k= 1,ijpr
+* if (mnproc.eq.k) then
+* write(lp,'(a,3i5)') 'mnproc,[ij]test =',mnproc,itest,jtest
+* endif
+* call xcsync(flush_lp)
+* enddo !k
+c
+c --- 'kdm ' = number of layers
+c --- 'nhybrd' = number of hybrid levels (0=all isopycnal)
+c --- 'nsigma' = number of sigma levels (nhybrd-nsigma z-levels)
+c --- 'dp00' = deep z-level spacing minimum thickness (m)
+c --- 'dp00x' = deep z-level spacing maximum thickness (m)
+c --- 'dp00f' = deep z-level spacing stretching factor (1.0=const.z)
+c --- 'ds00' = shallow z-level spacing minimum thickness (m)
+c --- 'ds00x' = shallow z-level spacing maximum thickness (m)
+c --- 'ds00f' = shallow z-level spacing stretching factor (1.0=const.z)
+c --- 'dp00i' = deep iso-pycnal spacing minimum thickness (m)
+c --- 'isotop' = shallowest depth for isopycnal layers (m), <0 from file
+c
+c --- the above specifies a vertical coord. that is isopycnal or:
+c --- near surface z in deep water, based on dp00,dp00x,dp00f
+c --- near surface z in shallow water, based on ds00,ds00x,ds00f and nsigma
+c --- sigma between them, based on ds00,ds00x,ds00f and nsigma
+c
+c --- d[ps].k/d[ps].1 = d[ps]00f**(k-1) unless limited by d[ps]00x.
+c --- if d[ps]00f>1, d[ps]00x (> d[ps]00) is the maximum thickness.
+c --- if d[ps]00f<1, d[ps]00x (< d[ps]00) is the minimum thickness.
+c
+c --- near the surface (i.e. shallower than isotop), layers are always fixed
+c --- depth (z or sigma). layer 1 is always fixed, so isotop=0.0 is not
+c --- allowed. if isotop<0.0 then isotop(1:idm,1:jdm) is a spacially
+c --- varying array, input from the file iso.top.[ab].
+c
+c --- away from the surface, the minimum layer thickness is dp00i.
+c --- to recover original hybrid behaviour, set dp00i=dp00x
+c --- for z-only, sigma-only or sigma-z only, set dp00i=dp00x
+c
+c --- for z-only set nsigma=0 (and ds00,ds00x,ds00f=dp00,dp00x,dp00f)
+c --- for sigma-z (shallow-deep) use a very small ds00
+c --- (pure sigma-z also has ds00f=dp00f and ds00x=dp00x*ds00/dp00)
+c --- for z-sigma (shallow-deep) use a very large dp00 (not recommended)
+c --- for sigma-only set nsigma=kdm, dp00 large, and ds00 small
+c
+c --- for an entirely fixed vertical coordinate (no isopycnal layers), set
+c --- isotop large or make all target densities (sigma(k), below) very small.
+c
+c --- or, in place of 'dp00','dp00x','dp00f','ds00','ds00x','ds00f' specify:
+c --- 'dp0k ' = layer k deep z-level spacing minimum thickness (m)
+c --- k=1,kdm; dp0k must be zero for k>nhybrd
+c --- 'ds0k ' = layer k shallow z-level spacing minimum thickness (m)
+c --- k=1,nsigma
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(kdmblk,'kdm ')
+ call blkini(nhybrd,'nhybrd')
+ call blkini(nsigma,'nsigma')
+ call blkinr2(dp00,k,
+ & 'dp00 ','(a6," =",f10.4," m")',
+ & 'dp0k ','(a6," =",f10.4," m")' )
+ if (k.eq.1) then !dp00
+ call blkinr(dp00x, 'dp00x ','(a6," =",f10.4," m")')
+ call blkinr(dp00f, 'dp00f ','(a6," =",f10.4," ")')
+ call blkinr(ds00, 'ds00 ','(a6," =",f10.4," m")')
+ call blkinr(ds00x, 'ds00x ','(a6," =",f10.4," m")')
+ call blkinr(ds00f, 'ds00f ','(a6," =",f10.4," ")')
+ else !dp0k
+ dp0k(1) = dp00
+ dp00 = -1.0 !signal that dp00 is not input
+ do k=2,kdm
+ call blkinr(dp0k(k), 'dp0k ','(a6," =",f10.4," m")')
+c
+ if (k.gt.nhybrd .and. dp0k(k).ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - dp0k must be zero for k>nhybrd'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !k>nhybrd&dp0k(k)!=0
+ enddo !k
+ do k=1,nsigma
+ call blkinr(ds0k(k), 'ds0k ','(a6," =",f10.4," m")')
+ enddo !k
+ endif !dp00:dp0k
+ call blkinr(dp00i, 'dp00i ','(a6," =",f10.4," m")')
+ call blkinr(isotop,'isotop','(a6," =",f10.4," m")')
+c
+c --- isopycnal (MICOM-like) iff nhybrd is 0
+ isopyc = nhybrd .eq. 0
+ hybrid = .not. isopyc
+ if (hybrid .and. nsigma.le.1) then
+ nsigma=1
+ if (dp00.lt.0.0) then
+ ds0k(1) = dp0k(1)
+ endif
+ endif
+c
+ if (kdmblk.ne.kdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - expected kdm =',kdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (nhybrd.gt.kdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - maximum nhybrd is kdm =',kdm
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (nsigma.gt.nhybrd) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - maximum nsigma is nhybrd =',nhybrd
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (dp00.ge.0.0) then
+ if (isopyc .and. max(dp00,dp00x).ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - must have dp00x==dp00==0.0 for isopycnal case'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (dp00f.eq.1.0 .and. dp00.ne.dp00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - must have dp00x==dp00 for dp00f==1.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (dp00f.gt.1.0 .and. dp00.ge.dp00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - dp00x must be > dp00 for dp00f>1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (dp00f.lt.1.0 .and. dp00.le.dp00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - dp00x must be < dp00 for dp00f<1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (ds00.gt.dp00) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - must have ds00 <= dp00'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (ds00.le.0.0 .and. .not.isopyc) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - must have ds00>0.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (ds00f.eq.1.0 .and. ds00.ne.ds00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - must have ds00x==ds00 for ds00f==1.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (ds00f.gt.1.0 .and. ds00.ge.ds00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - ds00x must be > ds00 for ds00f>1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (ds00f.lt.1.0 .and. ds00.le.ds00x) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - ds00x must be < ds00 for ds00f<1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ if (isotop.eq.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - isotop cannot be 0.0 (layer 1 never isopycnal)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error
+ endif !dp00 used
+c
+c --- 'saln0' = initial salinity value (psu), only used for iniflg<2
+c --- 'locsig' = locally-referenced potential density for stability (0=F,1=T)
+c --- 'kapref' = thermobaric reference state (-1=input,0=none,1,2,3=constant)
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+c --- 'thflag' = reference pressure flag (0=Sigma-0, 2=Sigma-2)
+c --- this is a check on the compile-time stmt_funcs.h setup.
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinr(saln0, 'saln0 ','(a6," =",f10.4," psu")')
+ call blkinl(locsig,'locsig')
+ call blkini(kapref,'kapref')
+ call blkini(thflag,'thflag')
+c --- kapnum is number of thermobaric reference states (1 or 2)
+ if (kapref.ne.-1) then
+ kapnum=1
+ else
+ kapnum=2
+ endif
+c
+ if (kapref.lt.-1 .or. kapref.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i1 /)')
+ & 'error - kapref must be between -1 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !kapref error
+ if (thflag.eq.0) then
+ if (sigver.eq.1) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'equation of state is 7-term sigma-0'
+ call flush(lp)
+ endif !1st tile
+ elseif (sigver.eq.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'equation of state is 9-term sigma-0'
+ call flush(lp)
+ endif !1st tile
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - thflag not consistent with sig()'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !7-term:9-term:error
+ elseif (thflag.eq.2) then
+ if (sigver.eq.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'equation of state is 7-term sigma-2'
+ call flush(lp)
+ endif !1st tile
+ elseif (sigver.eq.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'equation of state is 9-term sigma-2'
+ call flush(lp)
+ endif !1st tile
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - thflag not consistent with sig()'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !7-term:9-term:error
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - thflag must be 0 or 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !thflag
+ if (thflag.eq.0) then
+ sigfmt = '(a6," =",f10.4," sigma-0")'
+ elseif (thflag.eq.2) then
+ sigfmt = '(a6," =",f10.4," sigma-2")'
+ endif
+c
+c --- 'thbase' = reference density (sigma units)
+ call blkinr(thbase,'thbase',sigfmt)
+c
+c --- 'vsigma' = spacially varying isopycnal layer target densities (0=F,1=T)
+c --- if true, target densities input from file iso.sigma.[ab]
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinl(vsigma,'vsigma')
+c
+c --- 'sigma ' = isopycnal layer target densities (sigma units)
+ do k=1,kdm
+ call blkinr(sigma(k),'sigma ',sigfmt)
+c
+ if (k.gt.1) then
+ if (sigma(k).le.sigma(k-1)) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - sigma is not stabally stratified'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !sigma(k).le.sigma(k-1)
+ endif !k>1
+ enddo !k
+c
+c --- 'iniflg' = initial state flag (0=level,1=zonal,2=climatology)
+c --- 'jerlv0' = initial jerlov water type (1 to 5; 0 to use kpar)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(iniflg,'iniflg')
+ call blkini(jerlv0,'jerlv0')
+c
+ if (iniflg.lt.0 .or. iniflg.gt.3) then !inicon==3 ok, for old .inputs
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - iniflg must be between 0 and 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (jerlv0.lt.0 .or. jerlv0.gt.5) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - jerlv0 must be 0 or between 1 and 5'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- red and blue light extinction coefficients (1/pressure units)
+c --- for jerlov water types 1 to 5 - fraction of penetrating red light
+ betard(1) = 1.0/( 0.35*onem)
+ betard(2) = 1.0/( 0.6 *onem)
+ betard(3) = 1.0/( 1.0 *onem)
+ betard(4) = 1.0/( 1.5 *onem)
+ betard(5) = 1.0/( 1.4 *onem)
+ betabl(1) = 1.0/(23.0 *onem)
+ betabl(2) = 1.0/(20.0 *onem)
+ betabl(3) = 1.0/(17.0 *onem)
+ betabl(4) = 1.0/(14.0 *onem)
+ betabl(5) = 1.0/( 7.9 *onem)
+ redfac(1) = 0.58
+ redfac(2) = 0.62
+ redfac(3) = 0.67
+ redfac(4) = 0.77
+ redfac(5) = 0.78
+c
+c --- 'yrflag' = days in year flag (0=360,1=366,2=366Jan1,3=actual)
+c --- 'sshflg' = diagnostic SSH flag (0=SSH,1=SSH&stericSSH)
+c --- note that sshflg==1 implies reading relax.ssh.a
+c --- 'dsurfq' = number of days between model diagnostics at the surface
+c --- (-ve to output only the .txt file at itest,jtest)
+c --- 'diagfq' = number of days between model diagnostics
+c --- (-ve same as -diagfq but always write archive at end)
+c --- 'tilefq' = number of days between model diagnostics on selected tiles
+c --- 'meanfq' = number of days between model diagnostics (time averaged)
+c --- (1.0 with tidflg>0 implies daily 25-hour average)
+c --- 'rstrfq' = number of days between model restart output
+c --- (-ve same as -rstrfq but no restart at end)
+c --- 'bnstfq' = number of days between baro nesting archive input
+c --- (0.0 if lbflag is not 2)
+c --- 'nestfq' = number of days between 3-d nesting archive input
+c --- (0.0 turns off relaxation to 3-d nesting input)
+c --- 'cplifq' = number of days (or time steps) between sea ice coupling
+c --- (positive days or negative time steps)
+c --- 'baclin' = baroclinic time step (seconds), int. divisor of 86400
+c --- 'batrop' = barotropic time step (seconds), int. divisor of baclin/2
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(yrflag,'yrflag')
+ call blkini(sshflg,'sshflg')
+ call blkinr(dsurfq,'dsurfq','(a6," =",f10.4," days")')
+ call blkinr(diagfq,'diagfq','(a6," =",f10.4," days")')
+ call blkinr(tilefq,'tilefq','(a6," =",f10.4," days")')
+ call blkinr(meanfq,'meanfq','(a6," =",f10.4," days")')
+ call blkinr(rstrfq,'rstrfq','(a6," =",f10.4," days")')
+ call blkinr(bnstfq,'bnstfq','(a6," =",f10.4," days")')
+ call blkinr(nestfq,'nestfq','(a6," =",f10.4," days")')
+ call blkinr(cplifq,'cplifq','(a6," =",f10.4,
+ & " days (-ve time steps)")')
+ call blkinr(baclin,'baclin','(a6," =",f10.4," sec")')
+ call blkinr(batrop,'batrop','(a6," =",f10.4," sec")')
+c
+ dsur1p = dsurfq .lt. 0.0
+ if (dsur1p) then
+ dsurfq = -dsurfq
+ endif
+c
+ arcend = diagfq.lt.0.0
+ diagfq = abs(diagfq)
+c
+ if (cplifq.ge.0.0) then
+ icefrq = nint( cplifq*(86400.0/baclin) )
+ else
+ icefrq = nint(-cplifq)
+ endif
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,'(a,i10)') 'icefrq =',icefrq
+ endif !1st tile
+c
+ if (yrflag.lt.0 .or. yrflag.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - yrflag must be between 0 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (yrflag.le.1) then ! monthly forcing
+ if (abs(nint(86400.0/baclin)-86400.0/baclin).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - baclin not an integer divisor of 24 hours'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old baclin = ',baclin
+ baclin = 86400.0/nint(86400.0/baclin)
+* write(lp,*) 'new baclin = ',baclin
+ endif
+ else ! high frequency forcing
+ if (abs(nint(21600.0/baclin)-21600.0/baclin).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - baclin not an integer divisor of 6 hours'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old baclin = ',baclin
+ baclin = 21600.0/nint(21600.0/baclin)
+* write(lp,*) 'new baclin = ',baclin
+ endif
+ endif
+ if (abs(nint(0.5*baclin/batrop)-
+ & 0.5*baclin/batrop ).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - batrop not an integer divisor of baclin/2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old batrop = ',batrop
+ batrop = baclin/nint(baclin/batrop)
+* write(lp,*) 'new batrop = ',batrop
+ endif
+ if (abs(nint((dsurfq*86400.d0)/baclin)-
+ & (dsurfq*86400.d0)/baclin ).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - ',
+ & 'dsurfq is not a whole number of baroclinic time steps'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old dsurfq = ',dsurfq
+ dsurfq = nint((dsurfq*86400.d0)/baclin)*(baclin/86400.d0)
+* write(lp,*) 'new dsurfq = ',dsurfq
+ endif
+ if (abs(nint((diagfq*86400.d0)/baclin)-
+ & (diagfq*86400.d0)/baclin ).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - ',
+ & 'diagfq is not a whole number of baroclinic time steps'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old diagfq = ',diagfq
+ diagfq = nint((diagfq*86400.d0)/baclin)*(baclin/86400.d0)
+* write(lp,*) 'new diagfq = ',diagfq
+ endif
+ if (abs(nint((tilefq*86400.d0)/baclin)-
+ & (tilefq*86400.d0)/baclin ).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - ',
+ & 'tilefq is not a whole number of baroclinic time steps'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old tilefq = ',tilefq
+ tilefq = nint((tilefq*86400.d0)/baclin)*(baclin/86400.d0)
+* write(lp,*) 'new tilefq = ',tilefq
+ endif
+ if (abs(nint((meanfq*86400.d0)/baclin)-
+ & (meanfq*86400.d0)/baclin ).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - ',
+ & 'meanfq is not a whole number of baroclinic time steps'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old meanfq = ',meanfq
+ meanfq = nint((meanfq*86400.d0)/baclin)*(baclin/86400.d0)
+* write(lp,*) 'new meanfq = ',meanfq
+ endif
+ if (kknest.ne.kdm .and. nestfq.gt.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - kknest (dimensions.h) must be kdm when nesting'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- 'incflg' = incremental update flag (0=no, 1=yes, 2=full-velocity)
+c --- 'incstp' = no. timesteps for full update (1=full insertion)
+c --- 'incupf' = number of days of incremental updating input
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(incflg, 'incflg')
+ call blkini(incstp, 'incstp')
+ call blkini(incupf, 'incupf')
+c
+c --- 'wbaro ' = barotropic time smoothing weight
+c --- 'btrlfr' = leapfrog barotropic time step (0=F,1=T)
+c --- 'btrmas' = barotropic is mass conserving (0=F,1=T)
+c --- 'hybrlx' = HYBGEN: inverse relaxation coefficient (time steps)
+c (1.0 for no relaxation)
+c --- 'hybiso' = HYBGEN: Use PCM if layer is within hybiso of target density
+c (0.0 for no PCM; large to recover pre-2.2.09 behaviour)
+c --- 'hybmap' = HYBGEN: remapper flag (0=PCM, 1=PLM, 2=PPM, 3=WENO-like)
+c --- 'hybflg' = HYBGEN: generator flag (0=T&S, 1=th&S, 2=th&T)
+c --- 'advflg' = thermal advection flag (0=T&S, 1=th&S, 2=th&T)
+c --- 'advtyp' = scalar advection type (0=PCM, 1=MPDATA, 2=FCT2, 4=FCT4)
+c --- 'momtyp' = momentum advection type (2=2nd order, 4=4th order)
+c --- 'slip' = +1 for free-slip, -1 for non-slip boundary conditions
+c --- 'visco2' = deformation-dependent Laplacian viscosity factor
+c --- 'visco4' = deformation-dependent biharmonic viscosity factor
+c --- 'facdf4' = speed-dependent biharmonic viscosity factor
+c --- 'veldf2' = diffusion velocity (m/s) for Laplacian momentum dissipation
+c --- (negative to input spacially varying diffusion velocity)
+c --- 'veldf4' = diffusion velocity (m/s) for biharmonic momentum dissipation
+c --- (negative to input spacially varying diffusion velocity)
+c --- 'thkdf2' = diffusion velocity (m/s) for Laplacian thickness diffusion
+c --- 'thkdf4' = diffusion velocity (m/s) for biharmonic thickness diffusion
+c --- (negative to input spacially varying diffusion velocity)
+c --- 'temdf2' = diffusion velocity (m/s) for Laplacian temp/saln diffusion
+c --- 'temdfc' = temp diffusion conservation (0.0,1.0 all dens,temp resp.)
+c --- 'vertmx' = diffusion velocity (m/s) for mom.mixing at mix.layr.base
+c --- (vertmx only used in MICOM-like isopycnal mode)
+c --- 'cbar' = rms flow speed (m/s) for bottom friction
+c --- 'cb' = coefficient of quadratic bottom friction
+!!Alex add linear bottom drag cbar2
+c --- 'cbar2 ' = linear bottom drag
+c --- 'drglim' = limiter for explicit friction (1.0 no limiter, 0.0 implicit)
+c --- 'drgscl' = scale factor for tidal drag (0.0 for no tidal drag)
+c --- 'thkdrg' = thickness of bottom boundary layer for tidal drag (m)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinr(wbaro ,'wbaro ','(a6," =",f10.4," ")')
+ call blkinl(btrlfr,'btrlfr')
+ call blkinl(btrmas,'btrmas')
+ call blkinr(hybrlx,'hybrlx','(a6," =",f10.4," time steps")')
+ call blkinr(hybiso,'hybiso','(a6," =",f10.4," kg/m^3")')
+ call blkini(hybmap,'hybmap')
+ call blkini(hybflg,'hybflg')
+ call blkini(advflg,'advflg')
+ call blkini(advtyp,'advtyp')
+ call blkini(momtyp,'momtyp')
+ call blkinr(slip, 'slip ',
+ & '(a6," =",f10.4," (-1=no-slip, +1=free-slip)")')
+ call blkinr(visco2,'visco2','(a6," =",f10.4," ")')
+ call blkinr(visco4,'visco4','(a6," =",f10.4," ")')
+ call blkinr(facdf4,'facdf4','(a6," =",f10.4," ")')
+ call blkinr(veldf2,'veldf2','(a6," =",f10.4," m/s")')
+ call blkinr(veldf4,'veldf4','(a6," =",f10.4," m/s")')
+ call blkinr(thkdf2,'thkdf2','(a6," =",f10.4," m/s")')
+ call blkinr(thkdf4,'thkdf4','(a6," =",f10.4,
+ & " m/s (-ve if variable)")')
+ call blkinr(temdf2,'temdf2','(a6," =",f10.4," m/s")')
+ call blkinr(temdfc,'temdfc',
+ & '(a6," =",f10.4," (0.0,1.0 conserve dens,temp resp.)")')
+ call blkinr(vertmx,'vertmx','(a6," =",f10.4," m/s")')
+ call blkinr(cbar, 'cbar ','(a6," =",f10.4," m/s")')
+ call blkinr(cb, 'cb ','(a6," =",f10.4," ")')
+!!Alex add linear bottom drag cbar2
+ call blkinr(cbar2, 'cbar2 ','(a6," =",f10.4," ")')
+
+ call blkinr(drglim,'drglim','(a6," =",f10.4," ")')
+ call blkinr(drgscl,'drgscl','(a6," =",f10.4," ")')
+ call blkinr(thkdrg,'thkdrg','(a6," =",f10.4," m")')
+c
+ if (hybrlx.lt.1.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - hybrlx must be at least 1.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ qhybrlx = 1.0/hybrlx
+c
+ if (btrmas) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - btrmas (.true.) not yet implemented'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ isopcm = hybiso.gt.0.0 !use PCM for isopycnal layers?
+ if (hybmap.lt.0 .or. hybmap.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - hybmap must be ',
+ & '0 (PCM) or 1 (PLM) or 2 (PPM) or 3 (WENO-like)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (hybflg.lt.0 .or. hybflg.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - hybflg must be 0 (T&S) or 1 (th&S) or 2 (th&T)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (advflg.lt.0 .or. advflg.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - advflg must be 0 (T&S) or 1 (th&S) or 2 (th&T)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (advflg.eq.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - advflg==2 (th&T) not yet implemented'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (advtyp.ne.0 .and. advtyp.ne.1 .and.
+ & advtyp.ne.2 .and. advtyp.ne.4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - advtyp must be 0,1,2,4',
+ & ' (PCM,MPDATA,FCT2,FCT4)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (momtyp.ne.2 .and. momtyp.ne.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - montyp must be 2 or 4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (momtyp.eq.2) then
+ if (facdf4.ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - facdf4 must be 0.0 for montyp==2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ endif
+ if (momtyp.eq.4) then
+ if (visco2.ne.0.0 .or. veldf2.ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - visco2 and veldf2 must be 0.0 for montyp==4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ endif
+ if (slip.ne.-1.0 .and. slip.ne.1.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - slip must be -1.0 (no-slip) or +1.0 (free-slip)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (thkdf2.ne.0.0 .and. thkdf4.ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - only one of thkdf2 and thkdf4 can be non-zero'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (isopyc .and. temdfc.ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - isopycnal mode must have temdfc=0.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (temdfc.lt.0.0 .or. temdfc.gt.1.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - temdfc must be between 0.0 and 1.0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- 'thkbot' = thickness of bottom boundary layer (m)
+c --- 'sigjmp' = minimum density jump across interfaces (kg/m**3)
+c --- 'tmljmp' = equivalent temperature jump across mixed-layer (degC)
+c --- 'thkmls' = reference mixed-layer thickness for SSS relaxation (m)
+c --- 'thkmlt' = reference mixed-layer thickness for SST relaxation (m)
+c --- 'thkriv' = nominal thickness of river inflow (m)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinr(thkbot,'thkbot','(a6," =",f10.4," m")')
+ call blkinr(sigjmp,'sigjmp','(a6," =",f10.4," kg/m**3")')
+ call blkinr(tmljmp,'tmljmp','(a6," =",f10.4," degC")')
+ call blkinr(thkmls,'thkmls','(a6," =",f10.4," m")')
+ call blkinr(thkmlt,'thkmlt','(a6," =",f10.4," m")')
+ call blkinr(thkriv,'thkriv','(a6," =",f10.4," m")')
+c
+c --- 'thkfrz' = maximum thickness of near-surface freezing zone (m)
+c --- 'iceflg' = sea ice model flag (0=none,1=energy loan,1>coupled/esmf)
+c --- 2=2-way,3=no IO stress, 4=3+no ocean currents
+c --- also, icmflg=3 for ENLN relaxed to coupler ice concentration
+c --- 'tfrz_0' = ice melting point (degC) at S=0psu
+c --- 'tfrz_s' = gradient of ice melting point (degC/psu)
+c --- 'ticegr' = ENLN: vertical temperature gradient inside ice (deg/m)
+c --- (0.0 to get ice surface temp. from atmos. surtmp)
+c --- 'hicemn' = ENLN: minimum ice thickness (m)
+c --- 'hicemx' = ENLN: maximum ice thickness (m)
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinr(thkfrz,'thkfrz','(a6," =",f10.4," m")')
+ call blkini(iceflg,'iceflg')
+ icegln = iceflg.eq.1 !ENLN, but see icmflg.eq.3 below
+c
+ if (iceflg.lt.0 .or. iceflg.gt.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - iceflg must be between 0 and 4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- to recover original ENLN model use:
+c --- tfrz_0=-1.8, tfrz_s=0.0, ticegr=2.0, hicemn=0.5, hicemx=10.0.
+c --- for freezing point linear in S, typically use:
+c --- tfrz_0=0.0, tfrz_s=-0.054, ticegr=0.0, hicemn=0.5, hicemx=10.0.
+c
+ call blkinr(tfrz_0,'tfrz_0','(a6," =",f10.4," degC")')
+ call blkinr(tfrz_s,'tfrz_s','(a6," =",f10.4," degC/psu")')
+ call blkinr(ticegr,'ticegr','(a6," =",f10.4," degC/m")')
+ call blkinr(hicemn,'hicemn','(a6," =",f10.4," m")')
+ call blkinr(hicemx,'hicemx','(a6," =",f10.4," m")')
+c
+c --- 'ntracr' = number of tracers (0=none,negative to initialize)
+c --- 'trcflg' = tracer flags (one digit per tracer, most sig. replicated)
+c --- 0: passive, 100% at surface
+c --- 1: passive, psudo-silicate
+c --- 2: passive, temperature
+c --- 3: passive
+c --- 4-8: unused
+c --- 9: default biology (NPZ-3,NPZD-4,Chai-9)
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(ntracr,'ntracr')
+ trcrin = ntracr.gt.0 ! positive from restart, otherwise initialize
+ trcout = ntracr.ne.0
+ ntracr = abs(ntracr)
+c
+ if (ntracr.gt.mxtrcr) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3, a /)')
+ & 'error - maximum ntracr is',mxtrcr,
+ & ' (recompile with larger mxtrcr)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ call blkini(trcflg1,'trcflg')
+ do k= 1,ntracr
+ trcflg(k) = mod(trcflg1,10) ! least significant decimal digit
+ if (trcflg1.ge.10) then
+ trcflg1 = trcflg1/10 ! shift by one decimal digit
+ else
+ ! replicate last decimal digit across remaining tracers
+ endif
+ if (mnproc.eq.1) then
+ write(lp,'(a,i3,i2)') ' k,trcflg =',k,trcflg(k)
+ endif !1st tile
+ if (trcflg(k).gt.3 .and. trcflg(k).lt.9) then !not 0,1,2,3,9
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3 /)')
+ & 'error - unknown tracer type for tracer',k
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ enddo !k
+c
+c --- 'tsofrq' = number of time steps between anti-drift offset calcs
+c --- 'tofset' = temperature anti-drift offset (degC/century)
+c --- 'sofset' = salnity anti-drift offset (psu/century)
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(tsofrq,'tsofrq')
+ call blkinr(tofset,'tofset','(a6," =",f10.4," degC/century")')
+ call blkinr(sofset,'sofset','(a6," =",f10.4," psu/century")')
+c
+c --- convert from per century to per second.
+ tofset = tofset / (100.d0*365.d0*86400.d0)
+ sofset = sofset / (100.d0*365.d0*86400.d0)
+c
+c --- 'mlflag' = mixed layer flag (0=none,1=KPP,2-3=KTa-b,4=PWP,5=MY2.5,6=GISS)
+c --- 'mxlkpp' = KPP: activate mixed layer model (mlflag==1)
+c --- 'mxlkrt' = KT: MICOM or HYCOM Kraus-Turner (mlflag==2,3)
+c --- 'mxlkta' = KT: activate original mixed layer model (mlflag==2)
+c --- 'mxlktb' = KT: activate alternative mixed layer model (mlflag==3)
+c --- 'mxlpwp' = PWP: activate mixed layer model (mlflag==4)
+c --- 'mxlmy ' = MY: activate mixed layer model (mlflag==5)
+c --- 'mxlgiss' = GISS: activate mixed layer model (mlflag==6)
+c --- 'pensol' = KT/PWP activate penetrating solar radiation (0=F,1=T)
+c --- 'dtrate' = KT: maximum permitted m.l. detrainment rate (m/day)
+c --- 'thkmin' = KT/PWP: minimum mixed-layer thickness (m)
+c --- 'dypflg' = KT/PWP: diapycnal mixing flag (0=none,1=KPP,2=explicit)
+c --- always none (0) for MY/GISS and explicit (2) for PWP
+c --- 'mixfrq' = KT/PWP: number of time steps between diapycnal mixing calcs
+c --- 'diapyc' = KT/PWP: diapycnal diffusivity x buoyancy freq. (m**2/s**2)
+c --- 'rigr' = PWP: critical gradient richardson number
+c --- 'ribc' = PWP: critical bulk richardson number
+c --- 'rinfty' = KPP: maximum gradient richardson number (shear inst.)
+c --- 'ricr' = KPP: critical bulk richardson number
+c --- 'bldmin' = KPP: minimum surface boundary layer thickness (m)
+c --- 'bldmax' = KPROF: maximum surface boundary layer thickness (m)
+c --- 'cekman' = KPP/KT: scale factor for Ekman depth
+c --- 'cmonob' = KPP: scale factor for Monin-Obukov depth
+c --- 'bblkpp' = KPP: activate bottom boundary layer (0=F,1=T)
+c --- 'shinst' = KPP: activate shear instability mixing (0=F,1=T)
+c --- 'dbdiff' = KPP: activate double diffusion mixing (0=F,1=T)
+c --- 'nonloc' = KPP: activate nonlocal b. layer mixing (0=F,1=T)
+c --- 'latdiw' = KPROF: activate lat.depen.int.wav mixing (0=F,1=T)
+c --- 'botdiw' = GISS: activate bot.enhan.int.wav mixing (0=F,1=T)
+c --- 'difout' = KPROF: output visc/diff coffs in archive (0=F,1=T)
+c --- 'difsmo' = KPROF: number of layers with horiz smooth diff coeffs
+c --- 'difm0' = KPP: max viscosity due to shear instability (m**2/s)
+c --- 'difs0' = KPP: max diffusivity due to shear instability (m**2/s)
+c --- 'difmiw' = KPP/MY: background/internal wave viscosity (m**2/s)
+c --- 'difsiw' = KPP/MY: background/internal wave diffusivity (m**2/s)
+c --- 'dsfmax' = KPP: salt fingering diffusivity factor (m**2/s)
+c --- 'rrho0' = KPP: salt fingering rp=(alpha*delT)/(beta*delS)
+c --- 'cs' = KPP: value for nonlocal flux term
+c --- 'cstar' = KPP: value for nonlocal flux term
+c --- 'cv' = KPP: buoyancy frequency ratio (0.0 to use a fn. of N)
+c --- 'c11' = KPP: value for turb velocity scale
+c --- 'hblflg' = KPP: b. layer interpolation flag (0=con.,1=lin.,2=quad.)
+c --- 'niter' = KPP: iterations for semi-implicit soln. (2 recomended)
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(mlflag,'mlflag')
+c
+ if (mlflag.lt.0 .or. mlflag.gt.6) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - mlflag must be between 0 and 6'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (isopyc .and. mlflag.ne.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - isopycnal mode requires KT mixed layer (mlflag=2)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ mxlkta = mlflag.eq.2 .and. hybrid
+ mxlktb = mlflag.eq.3 .and. hybrid
+ mxlkrt = mlflag.eq.2 .or. mlflag.eq.3
+ call blkinl(pensol,'pensol')
+ call blkinr(dtrate,'dtrate','(a6," =",f10.4," m/day")')
+ call blkinr(thkmin,'thkmin','(a6," =",f10.4," m")')
+ call blkini(dypflg,'dypflg')
+ call blkini(mixfrq,'mixfrq')
+ call blkinr(diapyc,'diapyc','(a6," =",f10.4," m**2/s**2")')
+c
+ if (isopyc .and. pensol) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - isopycnal mode not consistent with pensol'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (dypflg.lt.0 .or. dypflg.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - dypflg must be between 0 and 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if ((mxlkta .or. mxlktb) .and.
+ & dypflg.ne.0 .and. thkriv.gt.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - thkriv>0 not consistent with KT unless dypflg=1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ mxlmy = mlflag.eq.5
+c
+ if (mxlmy) then
+ if (kkmy25.ne.kdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - kkmy25 (dimensions.h) must be kdm when mlflag==5'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ elseif (dypflg.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'warning - dypflg reset to 0 for M-Y 2.5'
+ call flush(lp)
+ endif !1st tile
+ dypflg = 0
+ endif
+ endif
+c
+ mxlgiss = mlflag.eq.6
+c
+ if (mxlgiss) then
+ if (nlgiss.ne.762) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - nlgiss (dimensions.h) must be 762 when mlflag==6'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ elseif (dypflg.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'warning - dypflg reset to 0 for GISS'
+ call flush(lp)
+ endif !1st tile
+ dypflg = 0
+ endif
+ endif
+c
+ mxlpwp = mlflag.eq.4
+ call blkinr(rigc ,'rigr ','(a6," =",f10.4," ")')
+ call blkinr(ribc ,'ribc ','(a6," =",f10.4," ")')
+ call blkinr(qrinfy,'rinfty','(a6," =",f10.4," ")')
+ qrinfy = 1.0/qrinfy
+ call blkinr(ricr ,'ricr ','(a6," =",f10.4," ")')
+c
+ if (mxlpwp .and. dypflg.ne.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'warning - dypflg reset to 2 for PWP mixed layer'
+ call flush(lp)
+ endif !1st tile
+ dypflg = 2
+ endif
+c
+ if (mxlpwp .and. thkriv.gt.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - thkriv>0 not consistent with PWP mixed layer'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ call blkinr(bldmin,'bldmin','(a6," =",f10.4," m")')
+ call blkinr(bldmax,'bldmax','(a6," =",f10.4," m")')
+c
+ call blkinr(cekman,'cekman','(a6," =",f10.4," ")')
+ call blkinr(cmonob,'cmonob','(a6," =",f10.4," ")')
+c
+ mxlkpp = mlflag.eq.1
+ call blkinl(bblkpp,'bblkpp')
+ call blkinl(shinst,'shinst')
+ call blkinl(dbdiff,'dbdiff')
+ call blkinl(nonloc,'nonloc')
+ call blkinl(latdiw,'latdiw')
+ call blkinl(botdiw,'botdiw')
+ call blkinl(difout,'difout')
+ call blkini(difsmo,'difsmo') !now an integer
+ call blkinr(difm0 ,'difm0 ','(a6," =",f10.4," m**2/s")')
+ call blkinr(difs0 ,'difs0 ','(a6," =",f10.4," m**2/s")')
+ call blkinr(difmiw,'difmiw','(a6," =",f10.4," m**2/s")')
+ call blkinr(difsiw,'difsiw','(a6," =",f10.4," m**2/s")')
+ call blkinr(dsfmax,'dsfmax','(a6," =",f10.4," m**2/s")')
+ call blkinr(rrho0 ,'rrho0 ','(a6," =",f10.4," ")')
+ call blkinr(cs ,'cs ','(a6," =",f10.4," ")')
+ call blkinr(cstar ,'cstar ','(a6," =",f10.4," ")')
+ call blkinr(cv ,'cv ','(a6," =",f10.4," ")')
+ call blkinr(c11 ,'c11 ','(a6," =",f10.4," ")')
+ call blkini(hblflg,'hblflg')
+ call blkini(niter ,'niter ')
+c
+ if (hblflg.lt.0 .or. hblflg.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ 2a /)')
+ & 'error - hblflg must be',
+ & ' 0 (constant) or 1 (linear) or 2 (quadratic)'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (mxlgiss) then
+ if (botdiw .and. .not.latdiw) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - botdiw requires latdiw'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ endif !mxlgiss
+c
+ if (mxlkpp) then
+c --- for KPP, diapyc and vertmx are not used
+ dypflg = 0
+ diapyc = 0.0
+ vertmx = 0.0
+ endif
+ if (mxlmy) then
+c --- for M-Y, diapyc and vertmx are not used
+ diapyc = 0.0
+ vertmx = 0.0
+ endif
+ if (mxlgiss) then
+c --- for GISS, diapyc and vertmx are not used
+ diapyc = 0.0
+ vertmx = 0.0
+ endif
+ if (mxlpwp) then
+c --- for PWP, vertmx is not used
+ vertmx = 0.0
+ endif
+ if (mxlkta .or. mxlktb) then
+c --- for HYCOM KT, vertmx is not currently used
+ vertmx = 0.0
+ endif
+c
+ if (dypflg.eq.2) then
+ if (max(tofset,sofset).gt.0.0) then
+ if (diapyc.le.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - diapyc must be positive if [ts]ofset is'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ elseif (mixfrq.ne.tsofrq) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - mixfrq and tsofrq must be equal'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !error checks
+ endif ![ts]ofset>0.0
+ endif !dypflg.eq.2
+c
+c --- 'fltflg' = FLOATS: synthetic float flag (0=no; 1=yes)
+c --- 'nfladv' = FLOATS: advect every nfladv bacl. time steps (even, >=4)
+c --- 'nflsam' = FLOATS: output (0=every nfladv steps; >0=# of days)
+c --- 'intpfl' = FLOATS: horiz. interp. (0=2nd order+bilinear; 1=bilinear)
+c --- 'iturbv' = FLOATS: add horiz. turb. advection velocity (0=no; 1=yes)
+c --- 'ismpfl' = FLOATS: sample water properties at float (0=no; 1=yes)
+c --- 'tbvar' = FLOATS: horizontal turbulent velocity variance scale
+c --- 'tdecri' = FLOATS: inverse decorrelation time scale
+c
+ call blkini(fltflg,'fltflg')
+ synflt = fltflg.ge.1
+ call blkini(nfladv,'nfladv')
+ call blkini(nflsam,'nflsam')
+ call blkini(intpfl,'intpfl')
+ call blkini(iturbv,'iturbv')
+ turbvel = iturbv.ge.1
+ call blkini(ismpfl,'ismpfl')
+ samplfl = ismpfl.ge.1
+ call blkinr(tbvar ,'tbvar ','(a6," =",f10.4," m**2/s**2")')
+ call blkinr(tdecri,'tdecri','(a6," =",f10.4," 1/day")')
+c
+c --- 'lbflag' = lateral barotropic bndy flag (0=none,1=port,2=nest,3=flather)
+c --- 'tidflg' = TIDES: tidal forcing flag (0=none,1=open-bdy,2=bdy&body)
+c --- open boundary for lbflag==3 only at present
+c --- 'tidcon' = TIDES: 1 digit per constituent (Q1K2P1N2O1K1S2M2), 0=off,1=on
+c --- 'tidsal' = TIDES: scalar self attraction and loading factor
+c --- 'tidgen' = TIDES: generic time (0=F,1=T)
+c --- 'tidrmp' = TIDES: ramp time (days)
+c --- 'tid_t0' = TIDES: origin for ramp time (model day)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(lbflag, 'lbflag')
+ call blkini(tidflg, 'tidflg')
+ call blkini(tidcon, 'tidcon')
+ call blkinr(tidsal, 'tidsal','(a6," =",f10.4," ")')
+ call blkinl(tidgen, 'tidgen')
+ call blkinr(ramp_time ,'tidrmp','(a6," =",f10.4," days")')
+ call blkin8(ramp_orig ,'tid_t0','(a6," =",f10.4," model day")') !real*8
+c
+ if (tidflg.lt.0 .or. tidflg.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - tidflg must be between 0 and 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (tidflg.eq.2 .and. .not.tidgen .and. yrflag.ne.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - tidgen must be .true. for yrflag.ne.3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (tidflg.gt.0) then
+ if (abs(nint(3600.0/baclin)-3600.0/baclin).gt.0.01) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - baclin not an integer divisor of 1 hour'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ else ! make it exact
+* write(lp,*) 'old baclin = ',baclin
+ baclin = 3600.0/nint(3600.0/baclin)
+* write(lp,*) 'new baclin = ',baclin
+ endif
+ endif
+c
+c --- weights for time smoothing
+ wuv1 = 0.75
+ wuv2 = 0.125
+ wts1 = 0.875
+ wts2 = 0.0625
+c
+c --- 'spcifh' = specific heat of sea water (j/kg/deg)
+c --- 'epsil' = small nonzero number used to prevent division by zero
+ spcifh=3990.
+ epsil =1.0e-11
+c
+c --- 'clmflg' = climatology frequency flag (6=bimonthly,12=monthly)
+c --- 'wndflg' = wind stress input flag (0=none,1=u&v-grid,2,3=p-grid)
+c --- (=3 to calculate wind speed from wind stress)
+!!Alex add pstrsi for bb86 config
+c --- 'pstrsi' = depth over which the wind is apply (m) (> 0. for bb86 only )
+c --- 'ustflg' = ustar forcing flag (3=input,1,2=wndspd,4=stress)
+c --- 'flxflg' = thermal forcing flag (0=none,3=net_flux,1,2,4=sst-based)
+c --- 'empflg' = E-P forcing flag (0=none,3=net_E-P, 1,2,4=sst-based_E)
+c --- 'dswflg' = diurnal shortwv flag (0=none,1=daily to diurnal correction)
+c --- 'sssflg' = SSS relaxation flag (0=none,1=clim)
+c --- 'lwflag' = longwave corr. flag (0=none,1=clim,2=atmos), sst-based
+c --- 'sstflg' = SST relaxation flag (0=none,1=clim,2=atmos,3=observed)
+c --- 'icmflg' = ice mask flag (0=none,1=clim,2=atmos,3=obs/coupled)
+c --- 'flxoff' = net flux offset flag (0=F,1=T)
+c --- 'flxsmo' = smooth surface fluxes (0=F,1=T)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkini(clmflg,'clmflg')
+ call blkini(wndflg,'wndflg')
+
+!!Alex add pstrsi for bb86 config
+ call blkinr(pstrsi,'pstrsi','(a6," =",f10.4," m")')
+
+ call blkini(ustflg,'ustflg')
+ call blkini(flxflg,'flxflg')
+ call blkini(empflg,'empflg')
+ call blkini(dswflg,'dswflg')
+ call blkini(sssflg,'sssflg')
+ call blkini(lwflag,'lwflag')
+ call blkini(sstflg,'sstflg')
+ call blkini(icmflg,'icmflg')
+ call blkinl(flxoff,'flxoff')
+ call blkinl(flxsmo,'flxsmo')
+c
+!!Alex add BB86 information if pstrsi > 0.
+ if (pstrsi > 0.) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & ' !!!! BB86 Configuration !!!!'
+ call flush(lp)
+ endif !1st tile
+ endif
+
+ if (clmflg.ne.6 .and. clmflg.ne.12) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - clmflg must be 6 or 12'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (lbflag.lt.0 .or. lbflag.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - lbflag must be between 0 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (lbflag.ne.2 .and. bnstfq.ne.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - bnstfq must be 0.0 unless lbflag is 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (lbflag.eq.2 .and. bnstfq.le.0.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - bnstfq must be positive when lbflag is 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (wndflg.lt.0 .or. wndflg.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - wndflg must be between 0 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (ustflg.lt.1 .or. ustflg.gt.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - ustflg must be between 1 and 4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.lt.0 .or. flxflg.gt.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - flxflg must be between 0 and 4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.gt.0 .and.
+ & wndflg.eq.0 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - wndflg must be 1,2,3 when flxflg>0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.eq.3 .and.
+ & ustflg.eq.4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - ustflg must be 1,2,3 when flxflg==3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (empflg.lt.0 .or. empflg.gt.4) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - empflg must be between 0 and 4'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.eq.3 .and. (empflg.ne.0 .and. empflg.ne.3)) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - empflg must be 0 or 3 when flxflg==3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (empflg.ne.flxflg .and. empflg.ne.0 .and. empflg.ne.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - empflg must be 0 or 3 or flxflg'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.eq.0 .and.
+ & empflg.ne.0 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - empflg must be 0 when flxflg==0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (flxflg.eq.3 .and.
+ & dswflg.eq.1 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - dswflg must be 0 when flxflg==3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (lwflag.lt.0 .or. lwflag.gt.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - lwflag must be between 0 and 2'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (lwflag.gt.0 .and.
+ & flxflg.eq.0 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - flxflg must be >0 when lwflag>0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (flxflg.eq.0) then
+ flxoff = .false. !no thermal forcing
+ endif
+c
+ if (iceflg.eq.0) then
+ icmflg = 0 !no ice
+ ticegr = 2.0 !surtmp not needed for ice temperature
+ elseif (iceflg.ge.2) then
+ icegln = icmflg.eq.3 !ENLN plus relax to coupler ice concentration
+ endif
+c
+ if (icmflg.lt.0 .or. icmflg.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - icmflg must be between 0 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ elseif (icmflg.eq.1) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - icmflg 1 not yet implemented'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ elseif (icmflg.eq.3 .and. iceflg.eq.1) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - icmflg 3 not yet implemented for iceflg==1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (sstflg.lt.0 .or. sstflg.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - sstflg must be between 0 and 3'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+ if (sstflg.gt.1 .and.
+ & yrflag.lt.2 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,a /)')
+ & 'error - yrflag must be >1 (high frequency forcing)',
+ & ' when sstflg>1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (sssflg.lt.0 .or. sssflg.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - sssflg must be 0 or 1'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- s w i t c h e s (if set to .true., then...)
+c --- (due to a SGI bug: read in an integer with 0=F,1=T)
+c --- windf use wind stress forcing (wndflg>0)
+c --- thermo use thermodynamic forcing
+c --- pensol use penetrating solar radiation (input above)
+c --- pcipf use E-P forcing (may be redefined in forfun)
+c
+c --- relax activate lateral boundary T/S/p climatological nudging
+c --- trcrlx activate lateral boundary tracer climatological nudging
+c
+c --- srelax activate surface salinity climatological nudging
+c --- trelax activate surface temperature climatological nudging
+c --- relaxt input tracer climatological relaxation fields
+c --- relaxf input T/S/p climatological relaxation fields
+c --- (note that relaxt implies relaxf)
+c --- relaxs input surface climatological relaxation fields only
+c --- priver rivers as a precipitation bogas
+c --- epmass treat evap-precip as a mass exchange
+c
+ windf = wndflg.ne.0
+ thermo = flxflg.ne.0
+ pensol = pensol .and. thermo
+ pcipf = empflg.ne.0 ! if .true., might later be set .false. by forfun
+c
+ if (.not.(thermo .or. sstflg.gt.0 .or. srelax)) then
+ niter=1
+ elseif (mxlkta) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a /)')
+ & 'error - KT mixed layer needs thermal forcing, i.e.',
+ & ' mlflag=2 needs max(sstflg,sstflg,flxflg)>0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif !.not(thermo ...):mxlkta
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ call blkinl(relax, 'relax ')
+ call blkinl(trcrlx,'trcrlx')
+ call blkinl(priver,'priver')
+ call blkinl(epmass,'epmass')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+c
+ if (priver .and. .not.thermo) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - priver must be .false. for flxflg=0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ if (epmass .and. .not.thermo) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - epmass must be .false. for flxflg=0'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+ close(unit=uoff+99) !file='blkdat.input'
+c
+ srelax = sssflg.eq.1
+ trelax = sstflg.eq.1
+ relaxt = trcout .and. (trcrlx .or.
+ & (.not.trcrin .and. iniflg.eq.2))
+ relaxf = relax
+ & .or. srelax
+ & .or. trelax
+ & .or. lwflag.eq.1
+ & .or. relaxt
+ relaxs = .not. relax
+ & .and. relaxf
+c
+c --- initialize from climatology (update relaxf and relaxs)?
+ if (iniflg.eq.2 .and. yrflag.ne.3) then
+#if defined(USE_CCSM3)
+ relaxf = .true.
+ relaxs = .false.
+#else
+ open(unit=uoff+99,file=trim(flnminp)//'limits') !on all nodes
+ read(uoff+99,*) day1
+ close(unit=uoff+99) !file='limits'
+ if (day1.le.0.0) then
+ relaxf = .true.
+ relaxs = .false.
+ endif !initialize from climatology
+#endif /* USE_CCSM3:else */
+ endif
+c
+ if (kkwall.ne.kdm .and. relaxf .and. .not. relaxs) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - kkwall (dimensions.h) must be kdm for 3-d clim'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkdat)')
+ stop '(blkdat)'
+ endif
+c
+c --- use 'huge' to initialize array portions that the code should never access
+ huge = 2.0**100 ! 2^100, or about 1.2676506e30
+#if defined(USE_CCSM3)
+c
+c --- i/o file names
+c --- directory names (eg, flnmgrdd) are read in from namelist in ccsm3_io
+c
+ flnmdep = trim(flnmdepd)//'regional.depth'
+ flnmgrd = trim(flnmgrdd)//'regional.grid'
+ flnmarc = trim(flnmarcd)//'archv.0000_000_00'
+ flnmarcm = trim(flnmarcd)//'archm.0000_000_00'
+ flnmarct = trim(flnmarcd)//'archt.0000_000_00'
+ flnmovr = 'ovrtn'
+ flnmflx = 'flxdp'
+c
+c --- i/o directory names
+c
+ flnmforw = trim(flnmrlxd)
+#else
+c
+c --- i/o file names
+c
+ flnmdep = 'regional.depth'
+ flnmgrd = 'regional.grid'
+ flnmarc = 'archv.0000_000_00'
+ flnmarcm = 'archm.0000_000_00'
+ flnmarct = 'archt.0000_000_00'
+ flnmovr = 'ovrtn_out'
+ flnmflx = 'flxdp_out'
+ flnmrsi = 'restart_in'
+ flnmrso = 'restart_out'
+c
+c --- i/o directory names
+c
+ flnmfor = './'
+ flnmforw = './'
+#endif /* USE_CCSM3:else */
+ return
+ end
+ subroutine blkinr(rvar,cvar,cfmt)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real rvar
+ character cvar*6,cfmt*(*)
+c
+c read in one real value
+c
+ character*6 cvarin
+c
+ read(uoff+99,*) rvar,cvarin
+ if (mnproc.eq.1) then
+ write(lp,cfmt) cvarin,rvar
+ call flush(lp)
+ endif !1st tile
+c
+ if (cvar.ne.cvarin) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in blkinr - input ',cvarin,
+ + ' but should be ',cvar
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkinr)')
+ stop
+ endif
+ return
+ end
+ subroutine blkinr2(rvar,nvar,cvar1,cfmt1,cvar2,cfmt2)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real rvar
+ integer nvar
+ character cvar1*6,cvar2*6,cfmt1*(*),cfmt2*(*)
+c
+c read in one real value
+c identified as either cvar1 (return nvar=1) or cvar2 (return nvar=2)
+c
+ character*6 cvarin
+c
+ read(uoff+99,*) rvar,cvarin
+ if (cvar1.eq.cvarin) then
+ nvar = 1
+ if (mnproc.eq.1) then
+ write(lp,cfmt1) cvarin,rvar
+ call flush(lp)
+ endif !1st tile
+ elseif (cvar2.eq.cvarin) then
+ nvar = 2
+ if (mnproc.eq.1) then
+ write(lp,cfmt2) cvarin,rvar
+ call flush(lp)
+ endif !1st tile
+ else
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in blkinr2 - input ',cvarin,
+ + ' but should be ',cvar1,' or ',cvar2
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkinr2)')
+ stop
+ endif
+ return
+ end
+ subroutine blkin8(rvar,cvar,cfmt)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real*8 rvar
+ character cvar*6,cfmt*(*)
+c
+c read in one real*8 value
+c
+ character*6 cvarin
+c
+ read(uoff+99,*) rvar,cvarin
+ if (mnproc.eq.1) then
+ write(lp,cfmt) cvarin,rvar
+ call flush(lp)
+ endif !1st tile
+c
+ if (cvar.ne.cvarin) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in blkin8 - input ',cvarin,
+ + ' but should be ',cvar
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkin8)')
+ stop
+ endif
+ return
+ end
+ subroutine blkini(ivar,cvar)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer ivar
+ character*6 cvar
+c
+c read in one integer value
+c
+ character*6 cvarin
+c
+ read(uoff+99,*) ivar,cvarin
+ if (mnproc.eq.1) then
+ write(lp,6000) cvarin,ivar
+ call flush(lp)
+ endif !1st tile
+c
+ if (cvar.ne.cvarin) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in blkini - input ',cvarin,
+ + ' but should be ',cvar
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkini)')
+ stop
+ endif
+ return
+ 6000 format(a6,' =',i10)
+ end
+ subroutine blkinl(lvar,cvar)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ logical lvar
+ character*6 cvar
+c
+c read in one logical value
+c due to a SGI bug for logical I/O: read in an integer 0=F,1=T
+c
+ character*6 cvarin
+ integer ivar
+c
+ read(uoff+99,*) ivar,cvarin
+ lvar = ivar .ne. 0
+ if (mnproc.eq.1) then
+ write(lp,6000) cvarin,lvar
+ call flush(lp)
+ endif !1st tile
+c
+ if (cvar.ne.cvarin) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in blkinl - input ',cvarin,
+ + ' but should be ',cvar
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(blkinl)')
+ stop
+ endif
+ return
+ 6000 format(a6,' =',l10)
+ end
+c>
+c> Revision history
+c>
+c> Oct. 1999 - added variables to control penetrating solar radiation
+c> Oct. 1999 - added switch to select mixed layer model
+c> Oct. 1999 - dp00 for hybgen is now set here
+c> Dec. 1999 - multiple heat flux transfer coefficients (cts1, cts2, ctl)
+c> replace old coefficient ct
+c> Jan. 2000 - changed to subroutine with run-time input
+c> May. 2000 - conversion to SI units
+c> Nov. 2000 - added kapflg,thflag,hybflg,advflg,wndflg
+c> Dec. 2000 - added flxflg
+c> Aug. 2001 - added bnstfq,nestfq
+c> Aug. 2001 - added mapflg==4 for an f-plane
+c> Aug. 2001 - betard and betabl inverted to replace division by multiply
+c> May 2002 - map projection via regional.grid file (see geopar.f)
+c> May 2002 - vertical coordinate via d[ps]00*
+c> May 2002 - diffusion variable names include 2/4 for Laplacian/biharmonic
+c> May 2002 - added PWP and MY2.5 mixed layer options
+c> May 2002 - added thkmlr, distinct from thkmin
+c> Aug 2002 - added ntracr and trcflg to control tracers
+c> Nov 2002 - added jerlv0=0 to use kpar-based turbidity
+c> Nov 2002 - split thkmlr into thkmls and thkmlt
+c> Apr 2003 - added dp00i, vsigma, and priver
+c> May 2003 - added bldmin, bldmax, flxsmo, and icmflg
+c> Jun 2003 - added locsig and removed thflag=4
+c> Oct 2003 - thkdf4 negative now signals spacial variation
+c> Nov 2003 - added advtyp
+c> Jan 2004 - added latdiw
+c> Jan 2004 - added bblkpp
+c> Jan 2004 - added hblflg and cv=0.0 option
+c> Feb 2004 - added botdiw (and latdiw) for GISS
+c> Feb 2004 - added temdfc
+c> Mar 2004 - added thkriv and epmass
+c> Mar 2004 - added isotop
+c> Mar 2005 - added tfrz_0,tfrz_s,ticegr,hicemn,hicemx
+c> Mar 2005 - added tsofrq,tofset,sofset
+c> Mar 2005 - added empflg
+c> Mar 2005 - added ustflg, reordered thermal forcing flags
+c> Mar 2005 - added flxoff
+c> Apr 2005 - replaced kapflg with kapref
+c> Jun 2005 - added hybrlx
+c> Jun 2006 - added cplifq, thkfrz and negative dsurfq option
+c> Nov 2006 - version 2.2
+c> Nov 2006 - added incflg,incstp,incupf
+c> Nov 2006 - added FLOATS (fltflg,...)
+c> Nov 2006 - added TIDES (tidflg,tidrmp,tid_t0,lbflag==3)
+c> Mar 2007 - added drgscl
+c> Mar 2007 - added drglim
+c> Mar 2007 - added tidcon,tidsal,tidgen
+c> Apr 2007 - implemented meanfq
+c> Apr 2007 - added btrlfr and btrmas (latter not yet implemented)
+c> May 2007 - added wbaro
+c> Jun 2007 - moved h1 to momtum
+c> Jun 2007 - added momtyp and facdf4
+c> Sep 2007 - added hybmap and hybiso
+c> Feb 2008 - added thkdrg
+c> Feb 2008 - added sshflg
+c> Jun 2008 - added tilefq
+c> Jul 2008 - added hybmap=3 (WENO-like)
+c> Oct 2008 - added dp0k and ds0k input option
+c> Oct 2008 - added dswflg
+c> Dec 2008 - difsmo is now an integer number of layers
+c> Jan 2009 - added -ve diagfq (arcend)
diff --git a/src_2.2.18_3_one/cnuity.f b/src_2.2.18_3_one/cnuity.f
new file mode 100755
index 0000000..6735912
--- /dev/null
+++ b/src_2.2.18_3_one/cnuity.f
@@ -0,0 +1,1278 @@
+ subroutine cnuity(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ use mod_floats ! HYCOM synthetic floats, drifters and moorings
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ------------------------------------------------------
+c --- continuity equation (flux-corrected transport version)
+c --- ------------------------------------------------------
+c
+ real dpfatal
+ parameter (dpfatal=-10.0) !fatal negative dp in meters
+c
+ logical lpipe_cnuity
+ parameter (lpipe_cnuity=.false.)
+c
+ integer, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & masku,maskv
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & pold
+ real, save, dimension (1-nbdy:jdm+nbdy) ::
+ & dpmn
+c
+ integer i,iflip,iprint,isave,j,jsave,k,l,ia,ib,ja,jb,mbdy
+ real q,dpmin,clip,flxhi,flxlo,dtinv,dpup,dpdn,thkdfu,thkdfv
+ real dpkmin(2*kdm)
+c
+ character*12 text,textu,textv
+c
+ mbdy = 6
+c
+ call xctilr(dpmixl( 1-nbdy,1-nbdy, n),1, 1, 6,6, halo_ps)
+ call xctilr(dp( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_ps)
+ call xctilr(dp( 1-nbdy,1-nbdy,1,m),1,kk, 6,6, halo_ps)
+ call xctilr(dpu( 1-nbdy,1-nbdy,1,m),1,kk, 6,6, halo_us)
+ call xctilr(dpv( 1-nbdy,1-nbdy,1,m),1,kk, 6,6, halo_vs)
+ call xctilr(u( 1-nbdy,1-nbdy,1,m),1,kk, 6,6, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,m),1,kk, 6,6, halo_vv)
+ call xctilr(ubavg( 1-nbdy,1-nbdy, m),1, 1, 6,6, halo_uv)
+ call xctilr(vbavg( 1-nbdy,1-nbdy, m),1, 1, 6,6, halo_vv)
+c
+c --- rhs: dpmixl.n
+c --- lhs: util3, dpold, utotn, vtotn
+c
+ margin = mbdy
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ util3(i,j)=0.
+ dpmold( i,j)=dpmixl(i,j,n) ! save for Asselin filter
+ enddo
+ enddo
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ utotn(i,j)=0.
+ enddo
+ enddo
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vtotn(i,j)=0.
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ do 76 k=1,kk
+c
+c --- uflux/vflux = low-order (diffusive) mass fluxes at old time level.
+c --- uflux2/vflux2 = 'antidiffusive' fluxes, defined as high-order minus low-
+c --- order fluxes. high-order fluxes are second-order in space, time-centered.
+c
+c --- rhs: depthu+, util3, dp.n, ubavg.m
+c --- lhs: uflux
+c
+ margin = mbdy - 1
+c
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ i=ifu(j,l)-1
+ if (i.ge.1-margin) then
+ if (iuopn(i,j).ne.0) then
+ q=min(dp(i ,j,k,n),max(0.,depthu(i+1,j)-util3(i ,j)))
+ utotm(i,j)=(u(i+1,j,k,m)+ubavg(i,j,m))*scuy(i,j)
+ uflux(i,j)=utotm(i,j)*q
+ endif
+ endif
+ i=ilu(j,l)+1
+ if (i.le.ii+margin) then
+ if (iuopn(i,j).ne.0) then
+ q=min(dp(i-1,j,k,n),max(0.,depthu(i-1,j)-util3(i-1,j)))
+ utotm(i,j)=(u(i-1,j,k,m)+ubavg(i,j,m))*scuy(i,j)
+ uflux(i,j)=utotm(i,j)*q
+ endif
+ endif
+ enddo
+ enddo
+c
+c --- rhs: depthv+, util3, dp.n, vbavg.m
+c --- lhs: vflux
+c
+ margin = mbdy - 1
+c
+ do i=1-margin,ii+margin
+ do l=1,jsv(i)
+ j=jfv(i,l)-1
+ if (j.ge.1-margin) then
+ if (ivopn(i,j).ne.0) then
+ q=min(dp(i,j ,k,n),max(0.,depthv(i,j+1)-util3(i,j )))
+ vtotm(i,j)=(v(i,j+1,k,m)+vbavg(i,j,m))*scvx(i,j)
+ vflux(i,j)=vtotm(i,j)*q
+ endif
+ endif
+ j=jlv(i,l)+1
+ if (j.le.jj+margin) then
+ if (ivopn(i,j).ne.0) then
+ q=min(dp(i,j-1,k,n),max(0.,depthv(i,j-1)-util3(i,j-1)))
+ vtotm(i,j)=(v(i,j-1,k,m)+vbavg(i,j,m))*scvx(i,j)
+ vflux(i,j)=vtotm(i,j)*q
+ endif
+ endif
+ enddo
+ enddo
+c
+c --- rhs: u.m, ubavg.m, depthu, dp.n+, util3+, dpu.m, uflux
+c --- rhs: v.m, vbavg.m, depthv, dp.n+, util3+, dpv.m, vflux
+c --- lhs: utotm,uflux,uflux2,uflx
+c --- lhs: vtotm,vflux,vflux2,vflx
+c
+ margin = mbdy - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ utotm(i,j)=(u(i,j,k,m)+ubavg(i,j,m))*scuy(i,j)
+ if (utotm(i,j).ge.0.) then
+ q=min(dp(i-1,j,k,n),max(0.,depthu(i,j)-util3(i-1,j)))
+ else
+ q=min(dp(i ,j,k,n),max(0.,depthu(i,j)-util3(i ,j)))
+ endif
+ uflux(i,j)=utotm(i,j)*q
+ uflux2(i,j)=utotm(i,j)*dpu(i,j,k,m)-uflux(i,j)
+ uflx(i,j,k)=uflux(i,j)
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vtotm(i,j)=(v(i,j,k,m)+vbavg(i,j,m))*scvx(i,j)
+ if (vtotm(i,j).ge.0.) then
+ q=min(dp(i,j-1,k,n),max(0.,depthv(i,j)-util3(i,j-1)))
+ else
+ q=min(dp(i,j ,k,n),max(0.,depthv(i,j)-util3(i,j )))
+ endif
+ vflux(i,j)=vtotm(i,j)*q
+ vflux2(i,j)=vtotm(i,j)*dpv(i,j,k,m)-vflux(i,j)
+ vflx(i,j,k)=vflux(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- advance -dp- field using low-order (diffusive) flux values
+c --- rhs: dp.n, dp.m, util3, uflux+, vflux+
+c --- lhs: dpold,dpoldm,util3,dp.n
+c
+ margin = mbdy - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,dpmin)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ dpmin=999.
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpold( i,j,k)=dp(i,j,k,n)
+ util3(i,j)=util3(i,j)+dp(i,j,k,n)
+ dp(i,j,k,n)=dp(i,j,k,n)-
+ & ((uflux(i+1,j)-uflux(i,j))+
+ & (vflux(i,j+1)-vflux(i,j)))*delt1*scp2i(i,j)
+ dpoldm(i,j,k)=dp(i,j,k,n) ! save for loop 19 test
+ dpmin=min(dpmin,dp(i,j,k,n))
+ enddo
+ enddo
+ dpmn(j)=dpmin ! minimizes false sharing
+ enddo ! loop 19
+!$OMP END PARALLEL DO
+c
+ dpmin=999.
+ do j=1,jj
+ dpmin=min(dpmin,dpmn(j))
+ enddo
+ dpkmin(k)=dpmin
+c
+ if (lpipe .and. lpipe_cnuity) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'dp.low k=',k
+ call pipe_compare_sym1(dp(1-nbdy,1-nbdy,k,n),ip,text)
+ endif
+c
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ i=ifu(j,l)-1
+ if (i.ge.1-margin) then
+ if (iuopn(i,j).ne.0) then
+ uflux(i,j)=0.0
+ endif
+ endif
+ i=ilu(j,l)+1
+ if (i.le.ii+margin) then
+ if (iuopn(i,j).ne.0) then
+ uflux(i,j)=0.0
+ endif
+ endif
+ enddo
+ enddo
+c
+ do i=1-margin,ii+margin
+ do l=1,jsv(i)
+ j=jfv(i,l)-1
+ if (j.ge.1-margin) then
+ if (ivopn(i,j).ne.0) then
+ vflux(i,j)=0.0
+ endif
+ endif
+ j=jlv(i,l)+1
+ if (j.le.jj+margin) then
+ if (ivopn(i,j).ne.0) then
+ vflux(i,j)=0.0
+ endif
+ endif
+ enddo
+ enddo
+c
+ if (lpipe .and. lpipe_cnuity) then
+c --- compare two model runs.
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+ masku(i,j)=iu(i,j)
+ if (i.gt. 1) masku(i,j)=masku(i,j)+iu(i-1,j)
+ if (i.lt.ii) masku(i,j)=masku(i,j)+iu(i+1,j)
+ maskv(i,j)=iv(i,j)
+ if (j.gt. 1) maskv(i,j)=maskv(i,j)+iv(i,j-1)
+ if (j.lt.jj) maskv(i,j)=maskv(i,j)+iv(i,j+1)
+ enddo
+ enddo
+ write (textu,'(a9,i3)') 'uflux k=',k
+ write (textv,'(a9,i3)') 'vflux k=',k
+ call pipe_compare_sym2(uflux,masku,textu,
+ & vflux,maskv,textv)
+ write (textu,'(a9,i3)') 'uflux2 k=',k
+ write (textv,'(a9,i3)') 'vflux2 k=',k
+ call pipe_compare_sym2(uflux2,masku,textu,
+ & vflux2,maskv,textv)
+ endif
+c
+cdiag if (mod(k,15).eq.1) then
+cdiag do i=itest-1,itest+1
+cdiag do j=jtest-1,jtest+1
+cdiag write (lp,101) nstep,i+i0,j+j0,k,dpold(i-1,j,k),uflux(i,j),
+cdiag. 'old dp''s, fluxes:',dpold(i,j-1,k),dpold(i,j,k),dpold(i,j+1,k)
+cdiag. ,vflux(i,j),dp(i,j,k,n),vflux(i,j+1),dpold(i+1,j,k),uflux(i+1,j)
+cdiag enddo
+cdiag enddo
+cdiag endif
+ 101 format (i9,2i5,i3,1p,e15.2,e30.2/a17,6e10.2/e37.2,e30.2)
+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 --- rhs: dp.n+, uflux2+, vflux2+
+c --- lhs: util1,util2
+c
+ margin = mbdy - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,ia,ib,ja,jb)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c --- assume margin0
+c
+c --- iunit=900-910; atmospheric forcing field
+c --- iunit=911-914; relaxation forcing field
+c --- iunit=915; relaxation time scale field
+c --- iunit=918; river forcing field
+c --- iunit=919; kpar forcing field
+c --- iunit=922; isopycnal target density field
+c --- iunit=923; laplacian or biharmonic diffusion velocity field
+c --- iunit=924; minimum depth for isopycnal layers
+c --- iunit=925; tidal drag roughness field (dragrh)
+c
+ integer i,ios,layer,mnth
+ real denlay,hmina,hminb,hmaxa,hmaxb
+ character cline*80
+c
+ if (iunit.lt.0) then
+c
+c --- special case, no .b file.
+c
+ call zaiord(field,ip,.false., hmina,hmaxa,
+ & -iunit)
+ return
+ endif
+c
+ call zagetc(cline,ios, uoff+iunit)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdmonth - hit end of input'
+ write(lp,*) 'iunit,ios = ',iunit,ios
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(a)') cline !print input array info
+ endif !1st tile
+ i = index(cline,'=')
+ if (iunit.ge.900 .and. iunit.le.910) then
+c --- atmospheric forcing
+ read (cline(i+1:),*) mnth,hminb,hmaxb
+ if (mnth.lt.1 .or. mnth.gt.12) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a /)')
+ & 'error on unit',iunit,' - not monthly atmospheric data'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ if (mnthck.gt.0 .and. mnth.ne.mnthck) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a,a,2i4,a /)')
+ & 'error on unit',iunit,' - wrong atmospheric month',
+ & ' (expected,input =',mnthck,mnth,')'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ elseif (iunit.eq.916) then
+c --- time-invarient heat flux correction
+ read (cline(i+1:),*) hminb,hmaxb
+ elseif (iunit.ge.911 .and. iunit.le.914) then
+c --- relaxation forcing
+ read (cline(i+1:),*) mnth,layer,denlay,hminb,hmaxb
+ if (mnth.lt.1 .or. mnth.gt.12) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a /)')
+ & 'error on unit',iunit,' - not monthly relaxation data'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ if (mnthck.gt.0 .and. mnth.ne.mnthck) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a,a,2i4,a /)')
+ & 'error on unit',iunit,' - wrong relaxation month',
+ & ' (expected,input =',mnthck,mnth,')'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ elseif (iunit.eq.919) then
+c --- kpar forcing
+ kparan = cline(i-8:i) .eq. ': range ='
+ if (kparan) then
+c --- annual
+ read (cline(i+1:),*) hminb,hmaxb
+ else
+c --- monthly
+ read (cline(i+1:),*) mnth,hminb,hmaxb
+ if (mnth.lt.1 .or. mnth.gt.12) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a /)')
+ & 'error on unit',iunit,' - not monthly kpar data'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ if (mnthck.gt.0 .and. mnth.ne.mnthck) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a,a,2i4,a /)')
+ & 'error on unit',iunit,' - wrong kpar month',
+ & ' (expected,input =',mnthck,mnth,')'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ endif
+ elseif (iunit.eq.918) then
+c --- river forcing
+ rivera = cline(i-8:i) .eq. ': range ='
+ if (rivera) then
+c --- annual
+ read (cline(i+1:),*) hminb,hmaxb
+ else
+c --- monthly
+ read (cline(i+1:),*) mnth,hminb,hmaxb
+ if (mnth.lt.1 .or. mnth.gt.12) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a /)')
+ & 'error on unit',iunit,' - not monthly river data'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ if (mnthck.gt.0 .and. mnth.ne.mnthck) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a,a,2i4,a /)')
+ & 'error on unit',iunit,' - wrong river month',
+ & ' (expected,input =',mnthck,mnth,')'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ endif
+ elseif (iunit.eq.915) then
+c --- relaxation time scale
+ read (cline(i+1:),*) hminb,hmaxb
+ elseif (iunit.eq.922) then
+c --- target density field.
+ read (cline(i+1:),*) layer,hminb,hmaxb
+ if (hminb.gt.sigma(layer)+0.005 .or.
+ & hmaxb.lt.sigma(layer)-0.005 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,a /)')
+ & 'error on unit',iunit,' - not consistent with sigma(k)'
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ elseif (iunit.eq.923) then
+c --- laplacian or biharmonic diffusion velocity field
+ read (cline(i+1:),*) hminb,hmaxb
+ elseif (iunit.eq.924) then
+c --- minimum depth for isopycnal layers
+ read (cline(i+1:),*) hminb,hmaxb
+ elseif (iunit.eq.925) then
+c --- tidal drag roughness
+ read (cline(i+1:),*) hminb,hmaxb
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(a / a,i5)')
+ & 'error - iunit must be 900-910 or 911-916 or 918-919',
+ & 'iunit =',iunit
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+c
+ if (hminb.eq.hmaxb) then !constant field
+ field(:,:) = hminb
+ call zaiosk(iunit)
+ else
+ call zaiord(field,ip,.false., hmina,hmaxa,
+ & iunit)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,i3 / a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & 'iunit = ',iunit,
+ & cline,
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif !1st tile
+ call xcstop('(rdmonth)')
+ stop '(rdmonth)'
+ endif
+ endif
+c
+ return
+ end
+c
+c
+ subroutine skmonth(iunit)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer iunit
+c
+c --- skip a single array field from unit iunit.
+c
+c --- iunit=900-910; atmospheric forcing field
+c --- iunit=911-914; relaxation forcing field
+c --- iunit=915; relaxation strength field
+c --- iunit=918; river forcing field
+c --- iunit=919; kpar forcing field
+c
+ character cline*80
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+iunit,'(a)') cline
+* write(lp, '(a)') cline
+ endif
+c
+ call zaiosk(iunit)
+c
+ return
+ end
+c
+c
+ subroutine rdpall(dtime0,dtime1)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real*8 dtime0,dtime1
+c
+c --- copy slot 2 into slot 1, and
+c --- read a set of high frequency forcing fields into slot 2.
+c --- on exit, dtime0 and dtime1 are the associated times (wind days).
+c
+ integer i,j,k
+ real*8 dtime(900:910)
+c
+ integer, save :: icall = -1
+c
+ real, parameter :: sstmin = -1.8
+ real, parameter :: sstmax = 35.0
+c
+ icall = icall + 1
+c
+ call rdpall1( taux,dtime(901),901,mod(icall,3).eq.0)
+ call rdpall1( tauy,dtime(902),902,mod(icall,3).eq.0)
+ if (ustflg.eq.3) then
+ call rdpall1(ustara,dtime(900),900,mod(icall,3).eq.0)
+ else
+ dtime(900) = dtime(901)
+ endif
+ if (wndflg.ne.3) then
+ call rdpall1(wndspd,dtime(903),903,mod(icall,3).eq.0)
+ else
+ dtime(903) = dtime(902)
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ wndspd(i,j,1) = wndspd(i,j,2)
+ enddo
+ enddo
+ call str2spd(wndspd(1-nbdy,1-nbdy,2),
+ & taux(1-nbdy,1-nbdy,2),
+ & tauy(1-nbdy,1-nbdy,2) )
+ endif !wndspd
+ call rdpall1(airtmp,dtime(904),904,mod(icall,3).eq.1)
+ call rdpall1(vapmix,dtime(905),905,mod(icall,3).eq.1)
+ if (pcipf) then
+ call rdpall1(precip,dtime(906),906,mod(icall,3).eq.1)
+ else
+ dtime(906) = dtime(905)
+ endif
+ call rdpall1(radflx,dtime(907),907,mod(icall,3).eq.2)
+ call rdpall1( swflx,dtime(908),908,mod(icall,3).eq.2)
+ if (lwflag.eq.2 .or. sstflg.eq.2 .or.
+ & icmflg.eq.2 .or. ticegr.eq.0.0 ) then
+ call rdpall1(surtmp,dtime(909),909,mod(icall,3).eq.2)
+ if (sstflg.ne.3) then !use atmos. sst as "truth"
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ seatmp(i,j,1) = max( sstmin, min(surtmp(i,j,1), sstmax ) )
+ seatmp(i,j,2) = max( sstmin, min(surtmp(i,j,2), sstmax ) )
+ enddo
+ enddo
+ endif
+ else
+ dtime(909) = dtime(905)
+ endif !surtmp:else
+ if (sstflg.eq.3) then
+ call rdpall1(seatmp,dtime(910),910,mod(icall,3).eq.2)
+ else
+ dtime(910) = dtime(905)
+ endif
+c
+ dtime0 = dtime1
+ dtime1 = dtime(901)
+c
+c --- check the input times.
+ do k= 902,910
+ if (dtime(k).ne.dtime1) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdpall - inconsistent forcing times'
+ write(lp,*) 'dtime0,dtime1 = ',dtime0,dtime1
+ write(lp,*) 'dtime = ',dtime
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdpall)')
+ stop '(rdpall)'
+ endif
+ enddo
+ return
+ end
+c
+c
+ subroutine rdpall1(field,dtime,iunit,lprint)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2) ::
+ & field
+ real*8 dtime
+ integer iunit
+ logical lprint
+c
+c --- copy field(:,:,2) into field(:,:,1), and
+c --- read a high frequency forcing field into field(:,:,2).
+c --- on exit, dtime is the time (wind day) of the forcing field.
+c
+ integer i,ios,j
+ character cline*80
+ real hmina,hminb,hmaxa,hmaxb,span
+c
+ call zagetc(cline,ios, uoff+iunit)
+ if (ios.lt.0) then ! e-o-f
+ if (yrflag.eq.2) then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+* write(lp,*) 'rdpall1 - rewind unit ',iunit
+* call flush(lp)
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ call zagetc(cline,ios, uoff+iunit)
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4 /)')
+ & 'end of file from zagetc, iunit = ',iunit
+ endif !1st tile
+ call xcstop('(rdpall1)')
+ stop '(rdpall1)'
+ endif
+ endif ! e-o-f
+ if (ios.gt.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',iunit,ios
+ endif !1st tile
+ call xcstop('(rdpall1)')
+ stop '(rdpall1)'
+ endif
+ if (lprint) then
+ if (mnproc.eq.1) then
+ write (lp,'(a)') cline
+ endif !1st tile
+ endif !lprint
+c
+ i = index(cline,'=')
+ read (cline(i+1:),*) dtime,span,hminb,hmaxb
+c
+ if (hminb.eq.hmaxb) then !constant field
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ field(i,j,1) = field(i,j,2)
+ field(i,j,2) = hminb
+ enddo
+ enddo
+ call zaiosk(iunit)
+ else !input field
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ field(i,j,1) = field(i,j,2)
+ enddo
+ enddo
+ call zaiord(field(1-nbdy,1-nbdy,2),ip,.false., hmina,hmaxa,
+ & iunit)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,i3 / a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & 'iunit = ',iunit,
+ & cline,
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif !1st tile
+ call xcstop('(rdpall1)')
+ stop '(rdpall1)'
+ endif
+ endif
+c
+c --- wind stress uses the the halo.
+c
+ if (iunit.eq.901 .and. wndflg.eq.1) then ! taux on u-grid
+ call xctilr(field(1-nbdy,1-nbdy,2),1,1, nbdy,nbdy, halo_uv)
+ elseif (iunit.eq.901) then ! taux on p-grid
+ call xctilr(field(1-nbdy,1-nbdy,2),1,1, nbdy,nbdy, halo_pv)
+ elseif (iunit.eq.902 .and. wndflg.eq.1) then ! tauy on v-grid
+ call xctilr(field(1-nbdy,1-nbdy,2),1,1, nbdy,nbdy, halo_vv)
+ elseif (iunit.eq.902) then ! tauy on p-grid
+ call xctilr(field(1-nbdy,1-nbdy,2),1,1, nbdy,nbdy, halo_pv)
+ endif
+ return
+ end
+c
+c
+ subroutine rdforf(mnth,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer lslot,mnth
+c
+c --- read forcing functions for one month.
+c
+ integer mreca,mrecc,mreck,mrecr
+ common/rdforfi/ mreca,mrecc,mreck,mrecr
+ save /rdforfi/
+c
+ integer i,irec,iunit,j
+c
+ real, parameter :: sstmin = -1.8
+ real, parameter :: sstmax = 35.0
+c
+ if (mnth.le.mreca) then
+c
+c --- rewind all units
+c
+ if (ustflg.eq.3) then
+ iunit = 900
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ endif
+ if (windf) then
+ do iunit= 901,902
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ enddo
+ endif
+ if (thermo) then
+ do iunit= max(903,901+wndflg),908 !904,908 when wndflg==3
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ enddo
+ endif
+ if (lwflag.eq.2 .or. sstflg.eq.2 .or.
+ & icmflg.eq.2 .or. ticegr.eq.0.0 ) then
+ iunit = 909
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ endif !surtmp
+ if (sstflg.eq.3) then
+ iunit = 910
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ endif
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdforf: mreca,mnth = ',mreca,mnth,' (rewind)'
+* endif !1st tile
+* call xcsync(flush_lp)
+ mreca = 0
+ endif
+c
+c --- skip forward to desired month
+c
+ do irec= mreca+1,mnth-1
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdforf: mreca,mnth = ',mreca,mnth,
+* & ' (skipping ',irec,')'
+* endif !1st tile
+* call xcsync(flush_lp)
+ if (ustflg.eq.3) then
+ call skmonth(900)
+ endif
+ if (windf) then
+ do iunit= 901,902
+ call skmonth(iunit)
+ enddo
+ endif
+ if (thermo) then
+ do iunit= max(903,901+wndflg),908 !904,908 when wndflg==3
+ call skmonth(iunit)
+ enddo
+ endif
+ if (lwflag.eq.2 .or. sstflg.eq.2 .or.
+ & icmflg.eq.2 .or. ticegr.eq.0.0 ) then
+ call skmonth(909)
+ endif !surtmp
+ if (sstflg.eq.3) then
+ call skmonth(910)
+ endif
+ enddo
+c
+c --- read desired month
+c
+ if (windf) then
+ call rdmonthck(taux(1-nbdy,1-nbdy,lslot),901,mnth)
+ call rdmonthck(tauy(1-nbdy,1-nbdy,lslot),902,mnth)
+ if (wndflg.eq.1) then !on uv-grids
+ call xctilr(taux(1-nbdy,1-nbdy,lslot),1,1, nbdy,nbdy, halo_uv)
+ call xctilr(tauy(1-nbdy,1-nbdy,lslot),1,1, nbdy,nbdy, halo_vv)
+ else !on p-grid
+ call xctilr(taux(1-nbdy,1-nbdy,lslot),1,1, nbdy,nbdy, halo_pv)
+ call xctilr(tauy(1-nbdy,1-nbdy,lslot),1,1, nbdy,nbdy, halo_pv)
+ endif
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ taux(i,j,lslot) = 0.0
+ tauy(i,j,lslot) = 0.0
+ enddo
+ enddo
+ endif
+ if (thermo) then
+ if (ustflg.eq.3) then
+ call rdmonthck(ustara(1-nbdy,1-nbdy,lslot),900,mnth)
+ endif
+ if (wndflg.ne.3) then
+ call rdmonthck(wndspd(1-nbdy,1-nbdy,lslot),903,mnth)
+ else
+ call str2spd(wndspd(1-nbdy,1-nbdy,lslot),
+ & taux(1-nbdy,1-nbdy,lslot),
+ & tauy(1-nbdy,1-nbdy,lslot) )
+ endif !wndspd
+ call rdmonthck(airtmp(1-nbdy,1-nbdy,lslot),904,mnth)
+ call rdmonthck(vapmix(1-nbdy,1-nbdy,lslot),905,mnth)
+ if (pcipf) then
+ call rdmonthck(precip(1-nbdy,1-nbdy,lslot),906,mnth)
+ endif
+ call rdmonthck(radflx(1-nbdy,1-nbdy,lslot),907,mnth)
+ call rdmonthck( swflx(1-nbdy,1-nbdy,lslot),908,mnth)
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ wndspd(i,j,lslot) = 0.0
+ airtmp(i,j,lslot) = 0.0
+ vapmix(i,j,lslot) = 0.0
+ precip(i,j,lslot) = 0.0
+ radflx(i,j,lslot) = 0.0
+ swflx(i,j,lslot) = 0.0
+ enddo
+ enddo
+ endif
+c
+ if (lwflag.eq.2 .or. sstflg.eq.2 .or.
+ & icmflg.eq.2 .or. ticegr.eq.0.0 ) then
+ call rdmonthck(surtmp(1-nbdy,1-nbdy,lslot),909,mnth)
+ if (sstflg.ne.3) then
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ seatmp(i,j,lslot) = max( sstmin,
+ & min(sstmax, surtmp(i,j,lslot) ) )
+ enddo
+ enddo
+ endif
+ endif !surtmp
+c
+ if (sstflg.eq.3) then
+ call rdmonthck(seatmp(1-nbdy,1-nbdy,lslot),910,mnth)
+ endif
+c
+ mreca = mnth
+c
+ if (mnproc.eq.1) then
+ write (lp,'(2(a,i3))') ' forcing functions for month',mnth,
+ & ' written into slot',lslot
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ end
+c
+c
+ subroutine rdkpar(mnth,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer lslot,mnth
+c
+c --- read kpar forcing for one month.
+c
+ integer mreca,mrecc,mreck,mrecr
+ common/rdforfi/ mreca,mrecc,mreck,mrecr
+ save /rdforfi/
+c
+ integer i,irec,iunit,j
+c
+ if (kparan) then
+ return ! annual (constant) kpar forcing
+ endif
+c
+ if (mnth.le.mreck) then
+c
+c --- rewind
+c
+ iunit=919
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdkpar: mreck,mnth = ',mreck,mnth,' (rewind)'
+* endif !1st tile
+* call xcsync(flush_lp)
+ mreck = 0
+ endif
+c
+c --- skip forward to desired month
+c
+ do irec= mreck+1,mnth-1
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdkpar: mreck,mnth = ',mreck,mnth,
+* & ' (skipping ',irec,')'
+* endif !1st tile
+* call xcsync(flush_lp)
+ call skmonth(919)
+ enddo
+c
+c --- read desired month
+c
+ call rdmonthck(akpar(1-nbdy,1-nbdy,lslot),919,mnth)
+c
+ mreck = mnth
+c
+ if (mnproc.eq.1) then
+ write (lp,'(2(a,i3))') ' kpar forcing for month',mnth,
+ & ' written into slot',lslot
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ end
+c
+c
+ subroutine rdrivr(mnth,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer lslot,mnth
+c
+c --- read river forcing for one month.
+c
+ integer mreca,mrecc,mreck,mrecr
+ common/rdforfi/ mreca,mrecc,mreck,mrecr
+ save /rdforfi/
+c
+ integer i,irec,iunit,j
+c
+ if (rivera) then
+ return ! annual (constant) river forcing
+ endif
+c
+ if (mnth.le.mrecr) then
+c
+c --- rewind
+c
+ iunit=918
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdrivr: mreca,mnth = ',mreca,mnth,' (rewind)'
+* endif !1st tile
+* call xcsync(flush_lp)
+ mrecr = 0
+ endif
+c
+c --- skip forward to desired month
+c
+ do irec= mrecr+1,mnth-1
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdforf: mrecr,mnth = ',mrecr,mnth,
+* & ' (skipping ',irec,')'
+* endif !1st tile
+* call xcsync(flush_lp)
+ call skmonth(918)
+ enddo
+c
+c --- read desired month
+c
+ call rdmonthck(rivers(1-nbdy,1-nbdy,lslot),918,mnth)
+c
+ mrecr = mnth
+c
+ if (mnproc.eq.1) then
+ write (lp,'(2(a,i3))') ' rivers forcing for month',mnth,
+ & ' written into slot',lslot
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ end
+c
+c
+ subroutine rdrlax(month,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer lslot,month
+c
+c --- read relaxation fields for one month,
+c --- monthly (clmflg==12) or bi-monthly (clmflg==6) data.
+c
+ integer mreca,mrecc,mreck,mrecr
+ common/rdforfi/ mreca,mrecc,mreck,mrecr
+ save /rdforfi/
+c
+ logical lexist,lfatal
+ integer i,irec,iunit,j,k,ktr,mrec,mnth,mxunit
+ real p23min(2),shallow
+c
+ mnth=mod(month-1,12)+1
+ if (mnproc.eq.1) then
+ write(lp,*) 'rdrlax - month = ',month,mnth
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ if (relaxf) then
+ if (clmflg.eq.12) then
+ mrec = mnth
+ else
+ mrec = (mnth+1)/2
+ endif
+ if (relaxt) then
+ mxunit = 914 ! tracers
+ elseif (relaxs) then
+ mxunit = 912 ! T&S only
+ else
+ mxunit = 913
+ endif
+c
+ if (mrec.le.mrecc) then
+c
+c --- rewind all units
+c
+ do iunit= 911,mxunit
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+iunit
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ read (uoff+iunit,*)
+ endif
+ call zaiorw(iunit)
+ enddo
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdrlax: mrecc,mrec = ',mrecc,mrec,' (rewind)'
+* endif !1st tile
+* call xcsync(flush_lp)
+ mrecc = 0
+ endif
+c
+c --- skip forward to desired month
+c
+ do irec= mrecc+1,mrec-1
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdrlax: mrecc,mrec = ',mrecc,mrec,
+* & ' (skipping ',irec,')'
+* endif !1st tile
+* call xcsync(flush_lp)
+ do iunit= 911,mxunit
+ if (iunit.lt.914) then
+ do k= 1,kk
+ call skmonth(iunit)
+ enddo
+ else
+ do ktr= 1,ntracr
+ do k= 1,kk
+ call skmonth(iunit)
+ enddo
+ enddo
+ endif
+ enddo
+ enddo
+c
+c --- read desired month
+c
+ if (relaxs) then ! surface only
+ k=1
+ call rdmonthck(twall(1-nbdy,1-nbdy,k,lslot),911,mnth)
+ do k= 2,kk
+ call skmonth( 911)
+ enddo
+ k=1
+ call rdmonthck(swall(1-nbdy,1-nbdy,k,lslot),912,mnth)
+ do k= 2,kk
+ call skmonth( 912)
+ enddo
+ if (relaxt) then !need pwall for tracers
+ do k= 1,kk
+ call rdmonthck(pwall(1-nbdy,1-nbdy,k,lslot),913,mnth)
+ enddo
+ endif
+ else
+ do k= 1,kk
+ call rdmonthck(twall(1-nbdy,1-nbdy,k,lslot),911,mnth)
+ enddo
+ do k= 1,kk
+ call rdmonthck(swall(1-nbdy,1-nbdy,k,lslot),912,mnth)
+ enddo
+ do k= 1,kk
+ call rdmonthck(pwall(1-nbdy,1-nbdy,k,lslot),913,mnth)
+ enddo
+ endif
+c
+ if (relaxt) then
+ do ktr= 1,ntracr
+ do k= 1,kk
+ call rdmonthck(trwall(1-nbdy,1-nbdy,k,lslot,ktr),914,mnth)
+ enddo
+ enddo
+ endif
+c
+ mrecc = mrec
+c
+c --- sanity check.
+c
+ if (lslot.eq.1 .and. (relaxt .or. .not.relaxs)) then
+ if (isopyc) then
+ shallow = dp0k(1)*5.0*qonem
+ else
+ shallow = sum(dp0k(1:min(max(5,nsigma+2),kk)))*qonem
+ endif
+ p23min(1) = huge
+ p23min(2) = huge
+ do j= 1,jj
+ do i= 1,ii
+ if (depths(i,j).gt.shallow) then
+ p23min(1) = min( p23min(1), pwall(i,j,min(2,kk),lslot) )
+ p23min(2) = min( p23min(2), pwall(i,j,min(3,kk),lslot) )
+ endif
+ enddo
+ enddo
+ call xcminr(p23min)
+ if (p23min(1).eq.huge) then
+ if (mnproc.eq.1) then
+ write (lp,'(2a,f7.1)')
+ & 'rdrlax: could not check pwall.2, all depths below',
+ & shallow
+ endif !1st tile
+ else
+ shallow = dp0k(1)+dp0k(min(2,kk))
+ lfatal = .false.
+ if (abs(p23min(1)-dp0k(1)).le.dp0k(1)*0.01) then
+ if (mnproc.eq.1) then
+ write (lp,'(a,2f7.2)')
+ & 'rdrlax: pwall.2 ok; expected,input min depth =',
+ & dp0k(1)*qonem,p23min(1)*qonem
+ endif !1st tile
+ else
+ lfatal = .true.
+ if (mnproc.eq.1) then
+ write (lp,'(a,2f7.2,a)')
+ & 'rdrlax: pwall.2 NOT ok; expected,input min depth =',
+ & dp0k(1)*qonem,p23min(1)*qonem,
+ & ' (bad climatology?)'
+ endif !1st tile
+ endif
+ if (abs(p23min(2)-shallow).le.shallow*0.01) then
+ if (mnproc.eq.1) then
+ write (lp,'(a,2f7.2)')
+ & 'rdrlax: pwall.3 ok; expected,input min depth =',
+ & shallow*qonem,p23min(2)*qonem
+ endif !1st tile
+ elseif (.not.isopyc) then ! ignore pwall.3 when MICOM-like
+ lfatal = .true.
+ if (mnproc.eq.1) then
+ write (lp,'(a,2f7.2,a)')
+ & 'rdrlax: pwall.3 NOT ok; expected,input min depth =',
+ & shallow*qonem,p23min(2)*qonem,
+ & ' (bad climatology?)'
+ endif !1st tile
+ endif
+ if (lfatal) then
+ inquire(
+ & file=flnmforw(1:len_trim(flnmforw))//'relax.weird',
+ & exist=lexist)
+ if (lexist) then
+ if (mnproc.eq.1) then
+ write (lp,'(3a)')
+ & 'rdrlax: continuing because file ',
+ & flnmforw(1:len_trim(flnmforw))//'relax.weird',
+ & ' exists (ignore the "bad" climatology)'
+ endif !1st tile
+ call xcsync(flush_lp)
+ else
+ call xcsync(flush_lp)
+ if (mnproc.eq.1) then
+ write (lp,'(3a)')
+ & 'rdrlax: create an empty file ',
+ & flnmforw(1:len_trim(flnmforw))//'relax.weird',
+ & ' to ignore the "bad" climatology'
+ endif !1st tile
+ call xcstop('(rdrlax)')
+ stop '(rdrlax)'
+ endif
+ endif
+ endif
+ endif ! sanity check
+c
+ if (mnproc.eq.1) then
+ write (lp,'(2(a,i3))') ' relaxation fields for month',mnth,
+ & ' written into slot',lslot
+ endif !1st tile
+ call xcsync(flush_lp)
+ endif
+ return
+ end
+c
+c
+ subroutine rdbaro(dtime)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real*8 dtime
+c
+c --- baroclinic velocity nesting archive input processing
+c
+c --- filenames nest/archv.????_???_??.[ab]
+c
+c --- I/O and array I/O unit 921 is reserved for the entire run.
+c
+c --- all input fields much be defined at all grid points
+c
+ integer iarch
+ save iarch
+ real*8 dbnstf,dtimei,dtime0,dtime1
+ save dbnstf,dtimei,dtime0,dtime1
+c
+ integer i,j,k
+c
+c --- wb0 negative on first call only.
+ if (wb0.lt.-1.0) then
+c
+c --- initialize nesting fields
+c
+ if (mnproc.eq.1) then
+ write (lp,*) ' now initializing baro nesting fields ...'
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ if (bnstfq.ge.1.0) then
+ dbnstf = bnstfq
+ else
+ dbnstf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*bnstfq)/baclin))
+ endif
+ dtimei = int(dtime/dbnstf)*dbnstf
+c
+ dtime0 = dtimei
+ lb0 = 1
+ call rdbaro_in(dtime0,1)
+c
+ iarch = 1
+ dtime1 = dtimei + dbnstf
+ lb1 = 2
+ call rdbaro_in(dtime1,2)
+c
+ if (mnproc.eq.1) then
+ write (lp,*)
+ write (lp,*) ' dtime,dtime0,dtime1 = ',dtime,dtime0,dtime1
+ write (lp,*)
+ write (lp,*) ' ...finished initializing baro nesting fields'
+ endif !1st tile
+ call xcsync(flush_lp)
+ endif ! initialization
+c
+ if (dtime.gt.dtime1) then
+c
+c --- get the next set of fields.
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ ubnest(i,j,1) = ubnest(i,j,2)
+ vbnest(i,j,1) = vbnest(i,j,2)
+ ubpnst(i,j,1) = ubpnst(i,j,2)
+ vbpnst(i,j,1) = vbpnst(i,j,2)
+ pbnest(i,j,1) = pbnest(i,j,2)
+ enddo
+ enddo
+ dtime0 = dtime1
+ iarch = iarch + 1
+ dtime1 = dtimei + dbnstf*iarch
+ call rdbaro_in(dtime1,2)
+c
+* if (mnproc.eq.1) then
+* write(lp,*) ' exit rdbaro_in - ',dtime,dtime0,dtime1
+* endif !1st tile
+* call xcsync(flush_lp)
+ endif ! next set of fields.
+c
+c --- linear interpolation in time.
+ wb0 = (dtime1-dtime)/(dtime1-dtime0)
+ wb1 = 1.0 - wb0
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdbaro - dtime,wb0,wb1 = ',dtime,wb0,wb1
+* endif !1st tile
+* call xcsync(flush_lp)
+ return
+ end
+c
+c
+ subroutine rdbaro_in(dtime,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real*8 dtime
+ integer lslot
+c
+c --- input barotropic fields from archive on model day dtime.
+c --- filenames nest/archv.????_???_??.[ab]
+c --- I/O and array I/O unit 921 is reserved for the entire run.
+c
+ character flnm*22, cline*80, cvarin*6, cfield*8
+ integer i,idmtst,ios,j,jdmtst,k,layer
+ integer iyear,iday,ihour
+ logical nodens
+ real hqpbot
+c
+ call forday(dtime, yrflag, iyear,iday,ihour)
+c
+ write(flnm,'("nest/archv.",i4.4,"_",i3.3,"_",i2.2)')
+ & iyear,iday,ihour
+c
+ if (mnproc.eq.1) then
+ write (lp,*) 'rdbaro_in: ',flnm
+ endif !1st tile
+ call xcsync(flush_lp)
+*
+ call zaiopf(flnm//'.a','old', 921)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ open (unit=uoff+921,file=flnm//'.b',form='formatted',
+ & status='old',action='read')
+c
+ read(uoff+921,'(a)') cline
+ read(uoff+921,'(a)') cline
+ read(uoff+921,'(a)') cline
+ read(uoff+921,'(a)') cline
+c
+ read(uoff+921,'(a)') cline
+ read(uoff+921,'(a)') cline
+ read(uoff+921,'(a)') cline
+ endif !1st tile
+c
+ call zagetc(cline,ios, uoff+921)
+ read(cline,*) idmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',idmtst
+* endif !1st tile
+ if (cvarin.ne.'idm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdbaro_in - input ',cvarin,
+ & ' but should be idm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ call zagetc(cline,ios, uoff+921)
+ read(cline,*) jdmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',jdmtst
+* endif !1st tile
+ if (cvarin.ne.'jdm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdbaro_in - input ',cvarin,
+ & ' but should be jdm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+c
+ if (idmtst.ne.itdm .or. jdmtst.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdbaro_in - input idm,jdm',
+ & ' not consistent with parameters'
+ write(lp,*) 'idm,jdm = ',itdm, jtdm, ' (dimensions.h)'
+ write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)'
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+c
+ call zagetc(cline,ios, uoff+921)
+c
+c --- skip some surface fields.
+c
+ call rd_archive(util1, cfield,layer, 921) ! montg1
+ if (cfield.ne.'montg1 ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdbaro_in - expected ','montg1 '
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ nodens = layer.ne.0 !new or original archive type
+c
+ call rd_archive(util2, cfield,layer, 921) ! srfhgt=montg1+thref*pbnest
+ if (cfield.ne.'srfhgt ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdbaro_in - expected ','srfhgt '
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ if (nodens) then
+ call zagetc(cline,ios, uoff+921) !steric or surflx
+ call zaiosk(921)
+ if (cline(1:8).eq.'steric ') then !surflx
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+921,*)
+ endif
+ call zaiosk(921)
+ endif
+ do i= 1,3 !salflx,dpbl,dpmixl
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+921,*)
+ endif
+ call zaiosk(921)
+ enddo
+ else
+ do i= 1,9 !surflx,salflx,dpbl,dpmixl,tmix,smix,thmix,umix,vmix
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+921,*)
+ endif
+ call zaiosk(921)
+ enddo
+ endif !nodens:else
+ call rd_archive(ubnest(1-nbdy,1-nbdy,lslot), cfield,layer, 921)
+ if (cfield.eq.'kemix ') then
+ call rd_archive(ubnest(1-nbdy,1-nbdy,lslot), cfield,layer, 921)
+ endif
+ if (cfield.eq.'covice ') then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+921,*)
+ endif
+ call zaiosk(921)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+921,*)
+ endif
+ call zaiosk(921)
+ call rd_archive(ubnest(1-nbdy,1-nbdy,lslot), cfield,layer, 921)
+ endif
+ if (cfield.ne.'u_btrop ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdbaro_in - expected ','u_btrop '
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ call rd_archive(vbnest(1-nbdy,1-nbdy,lslot), cfield,layer, 921)
+ if (cfield.ne.'v_btrop ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdbaro_in - expected ','v_btrop '
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close( unit=uoff+921)
+ endif
+ call zaiocl(921)
+c
+ call xctilr(ubnest(1-nbdy,1-nbdy,lslot),1,1, 1,1, halo_uv)
+ call xctilr(vbnest(1-nbdy,1-nbdy,lslot),1,1, 1,1, halo_vv)
+c
+!$OMP PARALLEL DO PRIVATE(j,i,hqpbot)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do i=1,ii
+ if (ip(i,j).eq.1) then
+ hqpbot = 0.5/pbot(i,j)
+ pbnest(i,j,lslot) = (util2(i,j)-util1(i,j))*qthref
+ ubpnst(i,j,lslot) = (ubnest(i, j,lslot)*depthu(i, j)+
+ & ubnest(i+1,j,lslot)*depthu(i+1,j) )
+ & *hqpbot
+ vbpnst(i,j,lslot) = (vbnest(i,j, lslot)*depthv(i,j )+
+ & vbnest(i,j+1,lslot)*depthv(i,j+1) )
+ & *hqpbot
+ else
+ pbnest(i,j,lslot) = 0.0
+ ubpnst(i,j,lslot) = 0.0
+ vbpnst(i,j,lslot) = 0.0
+ endif
+ enddo
+ enddo
+c
+ if (.false. .and. ittest.ne.-1 .and. jttest.ne.-1) then
+ call xcsync(flush_lp)
+ if (i0.lt.ittest .and. i0+ii.ge.ittest .and.
+ & j0.lt.jttest .and. j0+jj.ge.jttest ) then
+ write(lp,'(i5,i4,a,1p5e13.5)')
+ & itest+i0,jtest+j0,' rdbaro: ub,vb,pb,ubp,vbp = ',
+ & ubnest(itest,jtest,lslot),
+ & vbnest(itest,jtest,lslot),
+ & pbnest(itest,jtest,lslot),
+ & ubpnst(itest,jtest,lslot),
+ & vbpnst(itest,jtest,lslot)
+ write(lp,'(i5,i4,a,1p5e13.5)')
+ & itest+i0,jtest+1+j0,' rdbaro: ub,vb,pb,ubp,vbp = ',
+ & ubnest(itest,jtest+1,lslot),
+ & vbnest(itest,jtest+1,lslot),
+ & pbnest(itest,jtest+1,lslot),
+ & ubpnst(itest,jtest+1,lslot),
+ & vbpnst(itest,jtest+1,lslot)
+ endif
+ call xcsync(flush_lp)
+ endif
+ return
+ end
+c
+c
+ subroutine rdnest(dtime)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real*8 dtime
+c
+c --- 3-d nesting archive input processing
+c
+c --- filenames ./nest/archv.????_???_??.[ab]
+c --- ./nest/rmu.[ab]
+c
+c --- I/O and array I/O unit 915 is used for rmun[pv] only (not reserved).
+c --- I/O and array I/O unit 920 is reserved for the entire run.
+c
+c --- all input fields much be defined at all grid points
+c
+ integer iarch
+ save iarch
+ real*8 dnestf,dtimei,dtime0,dtime1
+ save dnestf,dtimei,dtime0,dtime1
+c
+ integer i,ios,j,k
+ character preambl(5)*79,cline*80
+c
+c --- wn0 negative on first call only.
+ if (wn0.lt.-1.0) then
+c
+c --- initialize nesting fields
+c
+ if (mnproc.eq.1) then
+ write (lp,*) ' now initializing 3-d nesting fields ...'
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ call zaiopf('nest/rmu.a', 'old', 915)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ open (unit=uoff+915,file='nest/rmu.b',
+ & status='old',action='read')
+ endif !1st tile
+ call zagetc(cline,ios, uoff+915) !1st line of the header on all tiles
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind uoff+915
+ read (uoff+915,'(a79)') preambl
+ endif !1st tile
+ call preambl_print(preambl)
+ if (cline.eq.'Relaxation Masks') then !two masks
+ call rdmonth(rmunp, 915)
+ call rdmonth(rmunv, 915)
+ call xctilr(rmunp,1,1, nbdy,nbdy, halo_ps)
+ call xctilr(rmunv,1,1, nbdy,nbdy, halo_ps)
+ else !one mask
+ call rdmonth(rmunp, 915)
+ call xctilr(rmunp,1,1, nbdy,nbdy, halo_ps)
+ rmunv(:,:) = rmunp(:,:)
+ endif !1 or 2 masks
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close (unit=uoff+915)
+ endif !1st tile
+ call zaiocl(915)
+c
+ if (nestfq.ge.1.0) then
+ dnestf = nestfq
+ else
+ dnestf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*nestfq)/baclin))
+ endif
+ dtimei = int(dtime/dnestf)*dnestf
+c
+ dtime0 = dtimei
+ ln0 = 1
+ call rdnest_in(dtime0,1)
+c
+ iarch = 1
+ dtime1 = dtimei + dnestf
+ ln1 = 2
+ call rdnest_in(dtime1,2)
+c
+ if (mnproc.eq.1) then
+ write (lp,*)
+ write (lp,*) ' dtime,dtime0,dtime1 = ',dtime,dtime0,dtime1
+ write (lp,*)
+ write (lp,*) ' ...finished initializing 3-d nesting fields'
+ endif !1st tile
+ call xcsync(flush_lp)
+ endif ! initialization
+c
+ if (dtime.gt.dtime1) then
+c
+c --- get the next set of fields.
+ do k= 1,kk
+ do j= 1,jj
+ do i= 1,ii
+ tnest(i,j,k,1) = tnest(i,j,k,2)
+ snest(i,j,k,1) = snest(i,j,k,2)
+ pnest(i,j,k,1) = pnest(i,j,k,2)
+ unest(i,j,k,1) = unest(i,j,k,2)
+ vnest(i,j,k,1) = vnest(i,j,k,2)
+ enddo
+ enddo
+ enddo
+ dtime0 = dtime1
+ iarch = iarch + 1
+ dtime1 = dtimei + dnestf*iarch
+ call rdnest_in(dtime1,2)
+c
+* if (mnproc.eq.1) then
+* write(lp,*) ' exit rdnest_in - ',dtime,dtime0,dtime1
+* endif !1st tile
+* call xcsync(flush_lp)
+ endif ! next set of fields.
+c
+c --- linear interpolation in time.
+ wn0 = (dtime1-dtime)/(dtime1-dtime0)
+ wn1 = 1.0 - wn0
+* if (mnproc.eq.1) then
+* write(lp,*) 'rdnest - dtime,wn0,wn1 = ',dtime,wn0,wn1
+* endif !1st tile
+* call xcsync(flush_lp)
+ return
+ end
+c
+c
+ subroutine rdnest_in(dtime,lslot)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real*8 dtime
+ integer lslot
+c
+c --- input 3-d nesting fields from archive on model day dtime.
+c --- filenames nest/archv.????_???_??.[ab]
+c --- I/O and array I/O unit 920 is reserved for the entire run.
+c
+ logical ldebug_rdnest
+ parameter (ldebug_rdnest=.false.)
+c
+ character flnm*22, cline*80, cvarin*6, cfield*8
+ integer i,idmtst,ios,j,jdmtst,k,layer
+ integer iyear,iday,ihour
+ logical meanar,nodens
+c
+ call forday(dtime, yrflag, iyear,iday,ihour)
+c
+ write(flnm,'("nest/archv.",i4.4,"_",i3.3,"_",i2.2)')
+ & iyear,iday,ihour
+c
+ if (mnproc.eq.1) then
+ write (lp,*) 'rdnest_in: ',flnm
+ endif !1st tile
+ call xcsync(flush_lp)
+*
+ call zaiopf(flnm//'.a','old', 920)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ open (unit=uoff+920,file=flnm//'.b',form='formatted',
+ & status='old',action='read')
+c
+ read(uoff+920,'(a)') cline
+ read(uoff+920,'(a)') cline
+ read(uoff+920,'(a)') cline
+ read(uoff+920,'(a)') cline
+c
+ read(uoff+920,'(a)') cline
+ read(uoff+920,'(a)') cline
+ read(uoff+920,'(a)') cline
+ endif !1st tile
+c
+ call zagetc(cline,ios, uoff+920)
+ read(cline,*) idmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',idmtst
+* endif !1st tile
+ if (cvarin.ne.'idm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdnest_in - input ',cvarin,
+ & ' but should be idm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ call zagetc(cline,ios, uoff+920)
+ read(cline,*) jdmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',jdmtst
+* endif !1st tile
+ if (cvarin.ne.'jdm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdnest_in - input ',cvarin,
+ & ' but should be jdm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+c
+ if (idmtst.ne.itdm .or. jdmtst.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rdnest_in - input idm,jdm',
+ & ' not consistent with parameters'
+ write(lp,*) 'idm,jdm = ',itdm, jtdm, ' (dimensions.h)'
+ write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)'
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+c
+c --- skip surface fields.
+c
+ call rd_archive(util1, cfield,layer, 920) ! montg1 (discarded)
+ if (cfield.ne.'montg1 ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','montg1 '
+ endif !1st tile
+ call xcstop('(rdbaro_in)')
+ stop '(rdbaro_in)'
+ endif
+ nodens = layer.ne.0 !new or original archive type
+ if (nodens) then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920)
+ call zagetc(cline,ios, uoff+920) !steric or surflx
+ call zaiosk(920)
+ if (cline(1:8).eq.'steric ') then !surflx
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920)
+ endif
+ do i= 1,3 !salflx,dpbl,dpmixl
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920)
+ enddo
+ else
+ do i= 1,10
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920)
+ enddo
+ endif !nodens:else
+ call zagetc(cline,ios, uoff+920) !kemix or covice or u_btrop
+ meanar = cline(1:8).eq.'kemix '
+ if (meanar) then
+ call zaiosk(920) !skip kemix
+ call rd_archive(util1, cfield,layer, 920) !covice or u_btrop
+ if (cfield.eq.'covice ') then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip thkice
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip temice
+ call rd_archive(util1, cfield,layer, 920) !u_btrop
+ endif
+ call rd_archive(util2, cfield,layer, 920) !v_btrop
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip kebtrop
+ else !standard archive file
+ if (cline(1:8).eq.'covice ') then
+ call zaiosk(920) !skip covice
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip thkice
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip temice
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ endif
+ call zaiosk(920) !skip u_btrop
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip v_btrop
+ endif !meanar:else
+c
+c --- 3-d fields.
+c
+ do k=1,kk
+ call rd_archive(unest(1-nbdy,1-nbdy,k,lslot), cfield,layer, 920)
+ if (cfield.ne.'u-vel. ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','u-vel. '
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ call rd_archive(vnest(1-nbdy,1-nbdy,k,lslot), cfield,layer, 920)
+ if (cfield.ne.'v-vel. ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','v-vel. '
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ if (meanar) then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip k.e.
+ endif
+ if (k.ne.kk) then
+ call rd_archive(pnest(1-nbdy,1-nbdy,k+1,lslot),
+ & cfield,layer, 920)
+ if (cfield.ne.'thknss ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','thknss '
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ else
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920)
+ endif
+ call rd_archive(tnest(1-nbdy,1-nbdy,k,lslot), cfield,layer, 920)
+ if (cfield.ne.'temp ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','temp '
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ call rd_archive(snest(1-nbdy,1-nbdy,k,lslot), cfield,layer, 920)
+ if (cfield.ne.'salin ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in rdnest_in - expected ','salin '
+ endif !1st tile
+ call xcstop('(rdnest_in)')
+ stop '(rdnest_in)'
+ endif
+ if (.not. nodens) then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+920,*)
+ endif
+ call zaiosk(920) !skip density
+ endif !.not.nodens
+ enddo
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close( unit=uoff+920)
+ endif
+ call zaiocl(920)
+
+ if (meanar) then
+ call xctilr(pnest(1-nbdy,1-nbdy,1,lslot),1,kk, 1,1, halo_ps)
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ if (meanar) then !mean archive
+c for thin layers, take baroclinic velocity from above
+c otherwise, convert from total to baroclinic velocity
+ do k= 1,kk
+ do i=1,ii
+ if (iu(i,j).eq.1) then
+ if (min(pnest(i, j,k,lslot),
+ & pnest(i-1,j,k,lslot) ).lt.tencm) then
+ unest(i,j,k,lslot) = unest(i,j,max(1,k-1),lslot)
+ else
+ unest(i,j,k,lslot) = unest(i,j,k,lslot) - util1(i,j)
+ endif !thin layer:else
+ endif !iu
+ if (iv(i,j).eq.1) then
+ if (min(pnest(i,j, k,lslot),
+ & pnest(i,j-1,k,lslot) ).lt.tencm) then
+ vnest(i,j,k,lslot) = vnest(i,j,max(1,k-1),lslot)
+ else
+ vnest(i,j,k,lslot) = vnest(i,j,k,lslot) - util2(i,j)
+ endif !thin layer:else
+ endif !iv
+ enddo !i
+ enddo !k
+ endif !meanar
+c convert from layer thickness to interface depth (pressure)
+ do i=1,ii
+ pnest(i,j,1,lslot) = 0.0
+ do k= 3,kk
+ pnest(i,j,k,lslot) = pnest(i,j,k, lslot) +
+ & pnest(i,j,k-1,lslot)
+ enddo !k
+ enddo !i
+ enddo !j
+c
+ if (ldebug_rdnest .and. ittest.ne.-1 .and. jttest.ne.-1) then
+ call xcsync(flush_lp)
+ if (i0.lt.ittest .and. i0+ii.ge.ittest .and.
+ & j0.lt.jttest .and. j0+jj.ge.jttest ) then
+ 103 format(i8,i5,i4,1x,a,a/
+ & (i8,5x,i4,1x,a,a,2f7.3,2f7.3,f8.4,f9.3,f9.2))
+ write(lp,103)
+ & nstep,itest+i0,jtest+j0,'rdnest',
+ & ': utot vtot temp saln dens thkns dpth',
+ & (nstep,k, 'rdnest',':',
+ & unest(itest,jtest,k,lslot)+ubnest(itest,jtest,lslot),
+ & vnest(itest,jtest,k,lslot)+vbnest(itest,jtest,lslot),
+ & tnest(itest,jtest,k,lslot),
+ & snest(itest,jtest,k,lslot),
+ & 0.0,
+ & (pnest(itest,jtest,k+1,lslot)-
+ & pnest(itest,jtest,k, lslot) )*qonem,
+ & pnest(itest,jtest,k+1,lslot)*qonem,
+ & k=1,kk-1),
+ & (nstep,k, 'rdnest',':',
+ & unest(itest,jtest,k,lslot)+ubnest(itest,jtest,lslot),
+ & vnest(itest,jtest,k,lslot)+vbnest(itest,jtest,lslot),
+ & tnest(itest,jtest,k,lslot),
+ & snest(itest,jtest,k,lslot),
+ & 0.0,
+ & depths(i,j)-pnest(itest,jtest,k,lslot)*qonem,
+ & depths(i,j),
+ & k=kk,kk)
+ endif
+ call xcsync(flush_lp)
+ endif
+c
+ return
+ end
+c
+c
+ subroutine rd_archive(field, cfield,layer, iunit)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h' ! for ip.
+c
+ character cfield*8
+ integer layer,iunit
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & field
+c
+c --- read a single archive array field from unit iunit.
+c
+ integer i,ios,nnstep
+ real hmina,hminb,hmaxa,hmaxb,timein,thet
+ character cline*80
+c
+ call zagetc(cline,ios, uoff+iunit)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in rd_archive - hit end of input'
+ write(lp,*) 'iunit,ios = ',iunit,ios
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(rd_archive)')
+ stop '(rd_archive)'
+ endif
+* if (mnproc.eq.1) then
+* write(lp,'(a)') cline
+* endif !1st tile
+c
+ cfield = cline(1:8)
+c
+ i = index(cline,'=')
+ read(cline(i+1:),*) nnstep,timein,layer,thet,hminb,hmaxb
+c
+ if (hminb.eq.hmaxb) then !constant field
+ field(:,:) = hminb
+ call zaiosk(iunit)
+ else
+ call zaiord(field,ip,.false., hmina,hmaxa,
+ & iunit)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif !1st tile
+cnostop call xcstop('(rd_archive)')
+cnostop stop '(rd_archive)'
+ endif
+ endif
+ return
+ end
+c
+c
+ subroutine str2spd(wspd, tx,ty)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+ include 'common_blocks.h'
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & wspd, tx,ty
+c
+c --- calculate wind speed from wind stress
+c
+c --- speed-dependent scale factor from stress to speed is based
+c --- on the Kara (neutral) wind-speed dependent drag coefficient
+c
+ integer i,j
+ real strspd,wndstr
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ wndstr = sqrt( tx(i,j)**2 + ty(i,j)**2 )
+ if (wndstr.LE.0.7711) THEN
+ strspd = 1.0/(1.22*(((3.236E-3 *wndstr -
+ + 5.230E-3)*wndstr +
+ + 3.218E-3)*wndstr +
+ + 0.926E-3) )
+ else
+ strspd = 1.0/(1.22*(((0.007E-3 *wndstr -
+ + 0.092E-3)*wndstr +
+ + 0.485E-3)*wndstr +
+ + 1.461E-3) )
+ endif
+ wspd(I,J) = sqrt( strspd*wndstr )
+ enddo
+ enddo
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> Mar. 1995 - added logical variable 'windf'
+c> Oct. 1997 - made necessary changes to reduce time dimension from 12 to 4
+c> Oct. 1999 - added code to read and store shortwave heat flux used for
+c> penetrating shortwave radiation
+c> Jan. 2000 - removed all conversion factors (apply before input)
+c> Jan. 2000 - removed biasrd and biaspc (apply before input)
+c> May. 2000 - conversion to SI units, positive flux into ocean
+c> Aug. 2000 - added option for high frequency atmospheric forcing
+c> Jan. 2001 - converted from pakk to array input file type
+c> Jul. 2001 - added skmonth and support for relaxs (surface only relax)
+c> Jul. 2001 - added rdopen and rdbaro
+c> Aug. 2001 - added constant field logic (skip the array input)
+c> Mar. 2003 - added surtmp and seatmp
+c> Mar. 2005 - added wndflg==3 and str2spd
+c> Aug. 2005 - added tracer climatology
+c> Nov. 2006 - [uv]pnst now from interpolation of transports
diff --git a/src_2.2.18_3_one/geopar.F b/src_2.2.18_3_one/geopar.F
new file mode 100755
index 0000000..4df0815
--- /dev/null
+++ b/src_2.2.18_3_one/geopar.F
@@ -0,0 +1,721 @@
+ subroutine geopar
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+#if defined(USE_CCSM3)
+ use ccsm3_grid, only : ANGLET
+#endif
+c
+c --- set up model parameters related to geography
+c
+c --- hycom version 2.1
+c
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real dp0kf,dpm,dpms,ds0kf,dsm,dsms
+ real hmina,hminb,hmaxa,hmaxb
+ integer i,ios,j,k,ktr,l
+ character preambl(5)*79,cline*80
+#if defined(USE_CCSM3)
+ real plinei(itdm),plinej(jtdm)
+ save plinei,plinej
+#endif
+c
+ real aspmax
+ parameter (aspmax=2.0) ! maximum grid aspect ratio for diffusion
+* parameter (aspmax=1.0) ! ignore grid aspect ratio in diffusion
+c
+c --- read grid location,spacing,coriolis arrays
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ write (lp,'(3a)') ' reading grid file from ',
+ & trim(flnmgrd),'.[ab]'
+ open (unit=uoff+9,file=trim(flnmgrd)//'.b',
+ & status='old')
+ endif
+ call xcsync(flush_lp)
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ read(cline,*) i
+c
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ read (cline,*) j
+c
+ if (i.ne.itdm .or. j.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - wrong array size in grid file'
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(a)') trim(cline)
+ endif
+ read (cline,*) mapflg
+c
+ call zaiopf(trim(flnmgrd)//'.a','old', 9)
+c
+ do k= 1,15
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then
+ write (lp,'(a)') trim(cline)
+ endif
+ call xcsync(flush_lp)
+c
+ if (k.eq.1) then
+ call zaiord(plon, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.2) then
+ call zaiord(plat, ip,.false., hmina,hmaxa, 9)
+ do i= 1,2 !skip qlon,qlat
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',
+ & uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ call zaiosk(9)
+ enddo
+ elseif (k.eq.3) then
+ call zaiord(ulon, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.4) then
+ call zaiord(ulat, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.5) then
+ call zaiord(vlon, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.6) then
+ call zaiord(vlat, ip,.false., hmina,hmaxa, 9)
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+#if defined(USE_CCSM3)
+c pang in ANGLET
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then
+ write (lp,'(a)') trim(cline)
+ endif
+ call xcsync(flush_lp)
+ call zaiord(ANGLET, ip,.false., hmina,hmaxa, 9)
+#else
+c skip pang
+ call zaiosk(9)
+#endif
+ elseif (k.eq.7) then
+ call zaiord(scpx, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.8) then
+ call zaiord(scpy, ip,.false., hmina,hmaxa, 9)
+ elseif (k.eq.9) then
+ call zaiord(scqx, iq,.false., hmina,hmaxa, 9)
+ elseif (k.eq.10) then
+ call zaiord(scqy, iq,.false., hmina,hmaxa, 9)
+ elseif (k.eq.11) then
+ call zaiord(scux, iu,.false., hmina,hmaxa, 9)
+ elseif (k.eq.12) then
+ call zaiord(scuy, iu,.false., hmina,hmaxa, 9)
+ elseif (k.eq.13) then
+ call zaiord(scvx, iv,.false., hmina,hmaxa, 9)
+ elseif (k.eq.14) then
+ call zaiord(scvy, iv,.false., hmina,hmaxa, 9)
+ else
+ call zaiord(corio,iq,.false., hmina,hmaxa, 9)
+ endif
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ enddo
+c
+ call zaiocl(9)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close(unit=uoff+9)
+ endif
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ i=itest
+ j=jtest
+ write (lp,'(/ a,2i5,a,f8.3,a,f12.9,2f10.2/)')
+ & ' i,j=',i+i0,j+j0,
+ & ' plat=',plat(i,j),
+ & ' corio,scux,vy=',corio(i,j),scux(i,j),scvy(i,j)
+ endif
+ call xcsync(flush_lp)
+#if defined(USE_CCSM3)
+c --- printout similar to ccsm ice model
+ call xclget(plinei,itdm, plon, 1,1, +1, 0, 1)
+ call xclget(plinej,jtdm, plat, 1,1, 0,+1, 1)
+ if (mnproc.eq.1) then
+ write (lp,*)
+ write (lp,'(a,4f9.3,a,4f9.3)')
+ & '(domain) plon(:,1): ',
+ & plinei(1:4),' ...', plinei(itdm-2:itdm)
+ write (lp,'(a,4f9.3,a,4f9.3)')
+ & '(domain) plat(1,:): ',
+ & plinej(1:4),' ...', plinej(jtdm-2:jtdm)
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+#endif
+c
+c --- read basin depth array
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ write (lp,'(3a)') ' reading bathymetry file from ',
+ & trim(flnmdep),'.[ab]'
+ open (unit=uoff+9,file=trim(flnmdep)//'.b',
+ & status='old')
+ read ( uoff+9,'(a79)') preambl
+ endif
+ call xcsync(flush_lp)
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close(unit=uoff+9)
+ write (lp,'(/(1x,a))') preambl,cline
+ endif
+c
+ call zaiopf(trim(flnmdep)//'.a','old', 9)
+ call zaiord(depths,ip,.false., hmina,hmaxa, 9)
+ call zaiocl(9)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ if (depths(i,j).gt.0.5*huge) then
+ depths(i,j) = 0.0
+ endif
+ enddo
+ enddo
+c
+c --- determine do-loop limits for u,v,p,q points, and update halo for depths
+ call bigrid(depths, mapflg, util1,util2,util3)
+ccc call prtmsk(ip,depths,util1,idm,ii,jj,0.0,1.0,
+ccc & 'bottom depth (m)')
+c
+c now safe to apply halo to arrays.
+c
+ vland = 1.0
+ call xctilr(plon, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(plat, 1,1, nbdy,nbdy, halo_ps)
+#if defined(USE_CCSM3)
+ call xctilr(ANGLET,1,1, nbdy,nbdy, halo_ps)
+#endif
+ call xctilr(scpx, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(scpy, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(ulon, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(ulat, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(scux, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(scuy, 1,1, nbdy,nbdy, halo_us)
+ call xctilr(vlon, 1,1, nbdy,nbdy, halo_vs)
+ call xctilr(vlat, 1,1, nbdy,nbdy, halo_vs)
+ call xctilr(scvx, 1,1, nbdy,nbdy, halo_vs)
+ call xctilr(scvy, 1,1, nbdy,nbdy, halo_vs)
+ call xctilr(corio, 1,1, nbdy,nbdy, halo_qs)
+ call xctilr(scqx, 1,1, nbdy,nbdy, halo_qs)
+ call xctilr(scqy, 1,1, nbdy,nbdy, halo_qs)
+ vland = 0.0
+c
+c --- area of grid cells (length x width) at u,v,p,q points resp.
+c
+******!$OMP PARALLEL DO PRIVATE(j,i)
+******!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ scu2(i,j)=scux(i,j)*scuy(i,j)
+ scv2(i,j)=scvx(i,j)*scvy(i,j)
+ scp2(i,j)=scpx(i,j)*scpy(i,j)
+ scq2(i,j)=scqx(i,j)*scqy(i,j)
+c
+ scuxi(i,j)=1.0/max(scux(i,j),epsil)
+ scvyi(i,j)=1.0/max(scvy(i,j),epsil)
+ scp2i(i,j)=1.0/max(scp2(i,j),epsil)
+ scq2i(i,j)=1.0/max(scq2(i,j),epsil)
+c
+c --- largest grid spacing (within limits) used in all diffusion
+c --- coefficients: min(max(sc?x,sc?y),sc?x*aspmax,sc?y*aspmax)
+ aspux(i,j)=min(max(scux(i,j),scuy(i,j)),
+ & min(scux(i,j),scuy(i,j))*aspmax)
+ & /max(scux(i,j),epsil)
+ aspuy(i,j)=min(max(scux(i,j),scuy(i,j)),
+ & min(scux(i,j),scuy(i,j))*aspmax)
+ & /max(scuy(i,j),epsil)
+ aspvx(i,j)=min(max(scvx(i,j),scvy(i,j)),
+ & min(scvx(i,j),scvy(i,j))*aspmax)
+ & /max(scvx(i,j),epsil)
+ aspvy(i,j)=min(max(scvx(i,j),scvy(i,j)),
+ & min(scvx(i,j),scvy(i,j))*aspmax)
+ & /max(scvy(i,j),epsil)
+c
+ util1(i,j)=depths(i,j)*scp2(i,j)
+ enddo
+ enddo
+c
+ call xcsum(avgbot, util1,ip)
+ call xcsum(area, scp2, ip)
+ avgbot=avgbot/area
+ if (mnproc.eq.1) then
+ write (lp,'(/a,f9.1,-12p,f10.2)')
+ & ' mean basin depth (m) and area (10^6 km^2):',
+ & avgbot,area
+ endif
+ call xcsync(flush_lp)
+c
+c --- calculate dp0k and ds0k?
+ if (dp00.lt.0.0) then
+c --- dp0k and ds0k already input
+ dpms = 0.0
+ do k=1,kk
+ dpm = dp0k(k)
+ dpms = dpms + dpm
+ dp0k(k) = dp0k(k)*onem
+ if (mnproc.eq.1) then
+ write(lp,135) k,dp0k(k)*qonem,dpm,dpms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: dp0k = ',dp0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo !k
+ dsms = 0.0
+ do k=1,nsigma
+ dsm = ds0k(k)
+ dsms = dsms + dsm
+ ds0k(k) = ds0k(k)*onem
+ if (mnproc.eq.1) then
+ write(lp,130) k,ds0k(k)*qonem,dsm,dsms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: ds0k = ',ds0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo !k
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ else
+c --- calculate dp0k and ds0k
+c
+c --- logorithmic k-dependence of dp0 (deep z's)
+ dp00 =onem*dp00
+ dp00x=onem*dp00x
+ dp00i=onem*dp00i
+ if (isopyc) then
+ dp0k(1)=thkmin*onem
+ else
+ dp0k(1)=dp00
+ endif
+ dpm = dp0k(1)*qonem
+ dpms = dpm
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,135) 1,dp0k(1)*qonem,dpm,dpms
+ endif
+ 135 format('dp0k(',i2,') =',f7.2,' m',
+ & ' thkns =',f7.2,' m',
+ & ' depth =',f8.2,' m')
+ call xcsync(flush_lp)
+c
+ dp0kf=1.0
+ do k=2,kk
+ dp0kf=dp0kf*dp00f
+ if (k.le.nhybrd) then
+ if (dp00f.ge.1.0) then
+ dp0k(k)=min(dp00*dp0kf,dp00x)
+ else
+ dp0k(k)=max(dp00*dp0kf,dp00x)
+ endif
+ else
+ dp0k(k)=0.0
+ endif
+ dpm = dp0k(k)*qonem
+ dpms = dpms + dpm
+ if (mnproc.eq.1) then
+ write(lp,135) k,dp0k(k)*qonem,dpm,dpms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: dp0kf = ',dp0kf, mnproc
+ write(6,*) 'geopar: dp0k = ',dp0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo !k
+c
+c --- logorithmic k-dependence of ds0 (shallow z-s)
+ ds00 =onem*ds00
+ ds00x=onem*ds00x
+ if (isopyc) then
+ ds0k(1)=thkmin*onem
+ else
+ ds0k(1)=ds00
+ endif
+ dsm = ds0k(1)*qonem
+ dsms = dsm
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,130) 1,ds0k(1)*qonem,dsm,dsms
+ endif
+ 130 format('ds0k(',i2,') =',f7.2,' m',
+ & ' thkns =',f7.2,' m',
+ & ' depth =',f8.2,' m')
+ call xcsync(flush_lp)
+c
+ ds0kf=1.0
+ do k=2,nsigma
+ ds0kf=ds0kf*ds00f
+ if (ds00f.ge.1.0) then
+ ds0k(k)=min(ds00*ds0kf,ds00x)
+ else
+ ds0k(k)=max(ds00*ds0kf,ds00x)
+ endif
+ dsm = ds0k(k)*qonem
+ dsms = dsms + dsm
+ if (mnproc.eq.1) then
+ write(lp,130) k,ds0k(k)*qonem,dsm,dsms
+ endif
+ if (mnproc.eq.-99) then ! bugfix that prevents optimization
+ write(6,*) 'geopar: ds0kf = ',ds0kf, mnproc
+ write(6,*) 'geopar: ds0k = ',ds0k(k),k,mnproc
+ endif
+ call xcsync(flush_lp)
+ enddo !k
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ endif !input:calculate dp0k,ds0k
+c
+c --- sigma-depth scale factors
+ do k=1,nsigma
+ dssk(k)=ds0k(k)/dsms ! onem * fraction of depths in sigma layer k
+ enddo
+ do k= nsigma+1,kdm
+ ds0k(k)=dp0k(k)
+ dssk(k)=0.0 ! these layers are zero in sigma mode
+ enddo
+c
+c --- initialize thermobaric reference state arrays.
+c
+ if (kapref.eq.-1) then
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ write (lp,'(3a)') ' reading thermobaric reference file from ',
+ & trim(flnmforw), 'tbaric.[ab]'
+ open (unit=uoff+9,file=trim(flnmforw)//'tbaric.b',
+ & status='old')
+ read ( uoff+9,'(a79)') preambl
+ endif
+ call xcsync(flush_lp)
+ call zagetc(cline,ios, uoff+9)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'geopar: I/O error from zagetc, iunit,ios = ',uoff+9,ios
+ endif !1st tile
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) hminb,hmaxb
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close(unit=uoff+9)
+ write (lp,'(/(1x,a))') preambl,cline
+ endif
+c
+c --- input field is between 1.0 and 3.0 and indicates the
+c --- relative strength of the two nearest reference states,
+c --- e.g. 1.7 is 70% ref2 and 30% ref1
+c --- and 2.3 is 70% ref2 and 30% ref3.
+c
+ call zaiopf(trim(flnmforw)//'tbaric.a','old', 9)
+ call zaiord(util1,ip,.false., hmina,hmaxa, 9)
+ call zaiocl(9)
+c
+ if (abs(hmina-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & '.a,.b min = ',hmina,hminb,hmina-hminb,
+ & '.a,.b max = ',hmaxa,hmaxb,hmaxa-hmaxb
+ endif
+ call xcstop('(geopar)')
+ stop '(geopar)'
+ endif
+c
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.0) then
+ util1(i,j) = 1.0 !land
+ endif
+ enddo
+ enddo
+c
+ vland = 1.0
+ call xctilr(util1, 1,1, nbdy,nbdy, halo_ps)
+ vland = 0.0
+c
+c kapi is the 2nd reference state (1st is always 2)
+c skap is the scale factor (0.0-1.0) for the 1st reference state
+c
+c assumes that reference states 1 and 3 are never next to each other.
+c
+ do j= 1,jj
+ do i= 1,ii
+ if (max(util1(i, j),
+ & util1(i-1,j),
+ & util1(i+1,j),
+ & util1(i, j-1),
+ & util1(i, j+1) ).gt.2.0) then
+ util2(i,j) = 3.0 !kapi
+ skap(i,j) = 3.0 - util1(i,j)
+ else
+ util2(i,j) = 1.0 !kapi
+ skap(i,j) = util1(i,j) - 1.0
+ endif
+ enddo
+ enddo
+ vland = 1.0
+ call xctilr(util2, 1,1, nbdy,nbdy, halo_ps)
+ call xctilr(skap, 1,1, nbdy,nbdy, halo_ps)
+ vland = 0.0
+c
+ kapi(:,:) = util2(:,:)
+ else
+ skap(:,:) = 1.0 !for diagnostics only
+ kapi(:,:) = kapref !for diagnostics only
+ endif !kapref.eq.-1:else
+c
+c --- initialize some arrays
+c --- set depthu,dpu,utotn,pgfx,depthv,dpv,vtotn,pgfy to zero everywhere,
+c --- so that they can be used at "lateral neighbors" of u and v points.
+c --- similarly for pbot,dp at neighbors of q points.
+c
+!$OMP PARALLEL DO PRIVATE(j,i,k,ktr)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ p( i,j,1)=0.0
+ pu( i,j,1)=0.0
+ pv( i,j,1)=0.0
+ utotn( i,j)=0.0
+ vtotn( i,j)=0.0
+ pgfx( i,j)=0.0
+ pgfy( i,j)=0.0
+ gradx( i,j)=0.0
+ grady( i,j)=0.0
+ depthu(i,j)=0.0
+ depthv(i,j)=0.0
+ pbot( i,j)=0.0
+c
+ psikk( i,j,1)=0.0
+ psikk( i,j,2)=0.0
+ thkk( i,j,1)=0.0
+ thkk( i,j,2)=0.0
+c
+ ubavg( i,j,1)=huge
+ ubavg( i,j,2)=huge
+ ubavg( i,j,3)=huge
+ vbavg( i,j,1)=huge
+ vbavg( i,j,2)=huge
+ vbavg( i,j,3)=huge
+ utotm( i,j)=huge
+ vtotm( i,j)=huge
+ uflux( i,j)=huge
+ vflux( i,j)=huge
+ uflux1(i,j)=huge
+ vflux1(i,j)=huge
+ uflux2(i,j)=huge
+ vflux2(i,j)=huge
+ uflux3(i,j)=huge
+ vflux3(i,j)=huge
+ uja( i,j)=huge
+ ujb( i,j)=huge
+ via( i,j)=huge
+ vib( i,j)=huge
+ do k=1,kk
+ dp( i,j,k,1)=0.0
+ dp( i,j,k,2)=0.0
+ dpu(i,j,k,1)=0.0
+ dpu(i,j,k,2)=0.0
+ dpv(i,j,k,1)=0.0
+ dpv(i,j,k,2)=0.0
+c
+ u( i,j,k,1)=huge
+ u( i,j,k,2)=huge
+ v( i,j,k,1)=huge
+ v( i,j,k,2)=huge
+c
+ uflx( i,j,k)=huge
+ vflx( i,j,k)=huge
+c
+ dpav( i,j,k)=0.0
+ uflxav(i,j,k)=0.0
+ vflxav(i,j,k)=0.0
+ diaflx(i,j,k)=0.0
+c
+ do ktr= 1,ntracr
+ tracer(i,j,k,1,ktr)=0.0
+ tracer(i,j,k,2,ktr)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l)+1)
+ ubavg(i,j,1)=0.0
+ ubavg(i,j,2)=0.0
+ ubavg(i,j,3)=0.0
+ utotm (i,j)=0.0
+ uflux (i,j)=0.0
+ uflux2(i,j)=0.0
+ uflux3(i,j)=0.0
+ uja(i,j)=0.0
+ ujb(i,j)=0.0
+c
+ do k=1,kk
+ uflx(i,j,k)=0.0
+ u(i,j,k,1)=0.0
+ u(i,j,k,2)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+c
+ call xctilr(ubavg, 1, 3, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(utotm, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux2, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uflux3, 1, 1, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(uja, 1, 1, nbdy,nbdy, halo_us)
+ call xctilr(ujb, 1, 1, nbdy,nbdy, halo_us)
+ call xctilr(uflx, 1, kk, nbdy,nbdy, halo_us) ! note scalar
+ call xctilr(u, 1,2*kk, nbdy,nbdy, halo_us) ! note scalar
+c
+!$OMP PARALLEL DO PRIVATE(i,l,j,k)
+!$OMP& SCHEDULE(STATIC)
+ do i=1,ii
+ do l=1,jsp(i)
+ do j=max(1,jfp(i,l)),min(jj,jlp(i,l)+1)
+ vbavg(i,j,1)=0.0
+ vbavg(i,j,2)=0.0
+ vbavg(i,j,3)=0.0
+ vtotm (i,j)=0.0
+ vflux (i,j)=0.0
+ vflux2(i,j)=0.0
+ vflux3(i,j)=0.0
+ via(i,j)=0.0
+ vib(i,j)=0.0
+c
+ do k=1,kk
+ vflx(i,j,k)=0.0
+ v(i,j,k,1)=0.0
+ v(i,j,k,2)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+c
+ call xctilr(vbavg, 1, 3, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vtotm, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux2, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflux3, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(via, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vib, 1, 1, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(vflx, 1, kk, nbdy,nbdy, halo_vs) ! note scalar
+ call xctilr(v, 1,2*kk, nbdy,nbdy, halo_vs) ! note scalar
+c
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> May 1997 - extended list of variables set to 'huge' on land
+c> Oct. 1999 - added code that defines the vertical distribution of dp0
+c> used in hybgen
+c> Jan. 2000 - added mapflg logic for different projections
+c> Feb. 2000 - added dp00f for logorithmic z-level spacing
+c> Mar. 2000 - added dp00s for sigma-spacing in shallow water
+c> May 2000 - conversion to SI units (still wrong corio)
+c> Feb. 2001 - removed rotated grid option
+c> Jan. 2002 - more flexible Z-sigma-Z vertical configuration
+c> Jan. 2002 - all grids now via array input
+c> Sep. 2004 - define kapi and skap for thermobaricity
+c> Oct. 2008 - dp0k and ds0k can now be input, see blkdat.F
diff --git a/src_2.2.18_3_one/h.ps b/src_2.2.18_3_one/h.ps
new file mode 100755
index 0000000..14b0386
Binary files /dev/null and b/src_2.2.18_3_one/h.ps differ
diff --git a/src_2.2.18_3_one/hybgen.f b/src_2.2.18_3_one/hybgen.f
new file mode 100755
index 0000000..405cca0
--- /dev/null
+++ b/src_2.2.18_3_one/hybgen.f
@@ -0,0 +1,1881 @@
+ subroutine hybgen(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ---------------------
+c --- hybrid grid generator
+c --- ---------------------
+c
+ logical, parameter :: lpipe_hybgen=.false. !for debugging
+c
+ integer i,j,k,l
+ character text*12
+c
+ 103 format (i9,2i5,a/(33x,i3,2f8.3,f8.3,f9.3,f9.2))
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag write (lp,103) nstep,itest+i0,jtest+j0,
+cdiag. ' entering hybgen: temp saln dens thkns dpth',
+cdiag. (k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag. th3d(itest,jtest,k,n)+thbase,dp(itest,jtest,k,n)*qonem,
+cdiag. p(itest,jtest,k+1)*qonem,k=1,kk)
+cdiag endif
+c
+ call xctilr(dpmixl( 1-nbdy,1-nbdy, n),1, 1, 1,1, halo_ps)
+c
+ margin = 0 ! no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call hybgenaj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- vertical momentum flux across moving interfaces (the s-dot term in the
+c --- momentum equation) - required to locally conserve momentum when hybgen
+c --- moves vertical coordinates first, store old interface pressures in
+c --- -pu-, -pv-
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,1)=0.0
+ pu(i,j,2)=dpu(i,j,1,n)
+ enddo !i
+ do k=2,kk
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,n)
+ enddo !i
+ enddo !k
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,1)=0.0
+ pv(i,j,2)=dpv(i,j,1,n)
+ enddo !i
+ do k=2,kk
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,n)
+ enddo !i
+ enddo !k
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+c --- update layer thickness at -u,v- points.
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, margin) ! p's halo extended by dpudpv
+c
+ if (lpipe .and. lpipe_hybgen) then
+c --- compare two model runs.
+ do k= 1,kk+1
+ write (text,'(a9,i3)') 'p k=',k
+ call pipe_compare(p( 1-nbdy,1-nbdy,k),ip,text)
+ write (text,'(a9,i3)') 'pu k=',k
+ call pipe_compare(pu(1-nbdy,1-nbdy,k),iu,text)
+ write (text,'(a9,i3)') 'pv k=',k
+ call pipe_compare(pv(1-nbdy,1-nbdy,k),iv,text)
+ enddo
+ do k= 1,kk
+ write (text,'(a9,i3)') 'dp k=',k
+ call pipe_compare(dp( 1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'dpu k=',k
+ call pipe_compare(dpu(1-nbdy,1-nbdy,k,n),iu,text)
+ write (text,'(a9,i3)') 'dpv k=',k
+ call pipe_compare(dpv(1-nbdy,1-nbdy,k,n),iv,text)
+ enddo
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call hybgenbj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+ return
+ end subroutine hybgen
+
+ subroutine hybgenaj(m,n,j )
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- --------------------------------------------
+c --- hybrid grid generator, single j-row (part A).
+c --- --------------------------------------------
+c
+ logical, parameter :: lunmix=.true. !unmix a too light deepest layer
+ logical, parameter :: lconserve=.false. !explicitly conserve each column
+c
+ double precision asum( mxtrcr+4,3)
+ real offset(mxtrcr+4)
+c
+ logical lcm(kdm) !use PCM for some layers?
+ real s1d(kdm,mxtrcr+4), !original scalar fields
+ & f1d(kdm,mxtrcr+4), !final scalar fields
+ & c1d(kdm,mxtrcr+4,3), !interpolation coefficients
+ & dpi( kdm), !original layer thicknesses, >= dpthin
+ & dprs(kdm), !original layer thicknesses
+ & pres(kdm+1), !original layer interfaces
+ & prsf(kdm+1), !final layer interfaces
+ & qhrlx( kdm+1), !relaxation coefficient, from qhybrlx
+ & dp0ij( kdm), !minimum layer thickness
+ & dp0cum(kdm+1) !minimum interface depth
+ real p_hat,p_hat0,p_hat2,p_hat3,hybrlx,
+ & delt,deltm,dels,delsm,q,qtr,qts,thkbop,
+ & zthk,dpthin
+ integer i,k,ka,kp,ktr,l,fixlay,nums1d
+ character*12 cinfo
+c
+ double precision, parameter :: dsmll=1.0d-8
+ double precision, parameter :: zp5=0.5 !for sign function
+c
+c --- c u s h i o n function (from Bleck & Benjamin, 1992):
+c --- if delp >= qqmx*dp0 >> dp0, -cushn- returns -delp-
+c --- if delp <= qqmn*dp0 << -dp0, -cushn- returns -dp0-
+c
+ real qqmn,qqmx,cusha,cushb
+ parameter (qqmn=-4.0, qqmx=2.0) ! shifted range
+* parameter (qqmn=-2.0, qqmx=4.0) ! traditional range
+* parameter (qqmn=-4.0, qqmx=6.0) ! somewhat wider range
+ parameter (cusha=qqmn**2*(qqmx-1.0)/(qqmx-qqmn)**2)
+ parameter (cushb=1.0/qqmn)
+c
+ real qq,cushn,delp,dp0
+ include 'stmt_fns.h'
+ qq( delp,dp0)=max(qqmn, min(qqmx, delp/dp0))
+ cushn(delp,dp0)=dp0*
+ & (1.0+cusha*(1.0-cushb*qq(delp,dp0))**2)*
+ & max(1.0, delp/(dp0*qqmx))
+c
+ dpthin = 0.001*onemm
+ thkbop = thkbot*onem
+ hybrlx = 1.0/qhybrlx
+c
+ if (mxlmy) then
+ nums1d = ntracr + 4
+ else
+ nums1d = ntracr + 2
+ endif
+c
+ if (.not.isopcm) then
+ do k=1,nhybrd
+ lcm(k) = .false. !use same remapper for all layers
+ enddo !k
+ do k=nhybrd+1,kk
+ lcm(k) = .true. !purely isopycnal layers use PCM
+ enddo !k
+ endif
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+ dp0cum(1)=0.0
+ qhrlx( 1)=1.0 !no relaxation in top layer
+ dp0ij( 1)=min( dp0k(1), max( ds0k(1), dssk(1)*depths(i,j) ) )
+ dp0cum(2)=dp0cum(1)+dp0ij(1)
+ qhrlx( 2)=1.0 !no relaxation in top layer
+ p(i,j, 2)=p(i,j,1)+dp(i,j,1,n)
+ do k=2,kk
+c --- q is dp0k(k) when in surface fixed coordinates
+c --- q is dp00i when much deeper than surface fixed coordinates
+ if (dp0k(k).le.dp00i) then
+ q = dp0k(k)
+ qts= 0.0 !0 at dp0k
+ else
+ q = max( dp00i,
+ & dp0k(k) * dp0k(k)/
+ & max( dp0k( k),
+ & p(i,j,k)-dp0cum(k) ) )
+ qts= 1.0 - (q-dp00i)/(dp0k(k)-dp00i) !0 at dp0k, 1 at dp00i
+ endif
+ qhrlx( k+1)=1.0/(1.0 + qts*(hybrlx-1.0)) !1 at dp0k, qhybrlx at dp00i
+ dp0ij( k) =min( q,max( ds0k(k), dssk(k)*depths(i,j) ) )
+ dp0cum(k+1)=dp0cum(k)+dp0ij(k)
+ p(i,j, k+1)=p(i,j,k)+dp(i,j,k,n)
+ enddo !k
+c
+c --- identify the always-fixed coordinate layers
+ fixlay = 1 !layer 1 always fixed
+ do k= 2,nhybrd
+ if (dp0cum(k).ge.topiso(i,j)) then
+ exit !layers k to nhybrd can be isopycnal
+ endif
+ qhrlx(k+1)=1.0 !no relaxation in fixed layers
+ fixlay = fixlay+1
+ enddo !k
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3)')
+cdiag & 'hybgen, always-fixed coordinate layers: 1 to ',
+cdiag & fixlay
+cdiag call flush(lp)
+cdiag endif !debug
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,'(a/(i6,1x,2f8.3,2f9.3,f9.3))')
+cdiag . 'hybgen: thkns minthk dpth mindpth hybrlx',
+cdiag . (k,dp(i,j,k,n)*qonem, dp0ij(k)*qonem,
+cdiag . p(i,j,k+1)*qonem,dp0cum(k+1)*qonem,
+cdiag . 1.0/qhrlx(k+1),
+cdiag . k=1,kk)
+cdiag endif !debug
+c
+c --- identify the deepest layer kp with significant thickness (> dpthin)
+c
+ kp = 2 !minimum allowed value
+ do k=kk,3,-1
+ if (p(i,j,k+1)-p(i,j,k).ge.dpthin) then
+ kp=k
+ exit
+ endif
+ enddo
+c
+c --- massless or near-massless (thickness < dpthin) layers
+c
+ do k=kp+1,kk
+ if (k.le.nhybrd) then
+c --- fill thin and massless layers on sea floor with fluid from above
+ th3d(i,j,k,n)=th3d(i,j,k-1,n)
+ saln(i,j,k,n)=saln(i,j,k-1,n)
+ temp(i,j,k,n)=temp(i,j,k-1,n)
+ elseif (th3d(i,j,k,n).ne.theta(i,j,k)) then
+ if (hybflg.ne.2) then
+c --- fill with saln from above
+ th3d(i,j,k,n)=max(theta(i,j,k), th3d(i,j,k-1,n))
+ saln(i,j,k,n)=saln(i,j,k-1,n)
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ saln(i,j,k,n)=sofsig(th3d(i,j,k,n)+thbase,temp(i,j,k,n))
+ else
+c --- fill with temp from above
+ th3d(i,j,k,n)=max(theta(i,j,k), th3d(i,j,k-1,n))
+ temp(i,j,k,n)=temp(i,j,k-1,n)
+ saln(i,j,k,n)=sofsig(th3d(i,j,k,n)+thbase,temp(i,j,k,n))
+ endif
+ endif
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=tracer(i,j,k-1,n,ktr)
+ enddo
+ if (mxlmy) then
+ q2 (i,j,k,n)=q2( i,j,k-1,n)
+ q2l(i,j,k,n)=q2l(i,j,k-1,n)
+ endif
+ enddo !k
+c
+ k=kp !at least 2
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3)')
+cdiag & 'hybgen, deepest inflated layer:',k
+cdiag call flush(lp)
+cdiag endif !debug
+c
+ if (lunmix .and. !usually .true.
+ & k.gt.fixlay+1 .and.
+ & theta(i,j,k)-epsil.gt.th3d(i,j,k,n) .and.
+ & theta(i,j,k-1) .lt.th3d(i,j,k,n) .and.
+ & ( th3d(i,j,k,n)- th3d(i,j,k-1,n)).gt.
+ & (theta(i,j,k) -theta(i,j,k-1) )*0.001 ) then
+c
+c --- water in the deepest inflated layer with significant thickness
+c --- (kp) is too light
+c ---
+c --- split layer into 2 sublayers, one near the desired density
+c --- and one exactly matching the T&S properties of layer k-1.
+c --- To prevent "runaway" T or S, the result satisfies either
+c --- abs(T.k - T.k-1) <= abs(T.k-2 - T.k-1) or
+c --- abs(S.k - S.k-1) <= abs(S.k-2 - S.k-1)
+c --- It is also limited to a 50% change in layer thickness.
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3)')
+cdiag & 'hybgen, deepest inflated layer too light (stable):',k
+cdiag call flush(lp)
+cdiag endif !debug
+c
+ delsm=abs(saln(i,j,k-2,n)-saln(i,j,k-1,n))
+ dels =abs(saln(i,j,k-1,n)-saln(i,j,k, n))
+ deltm=abs(temp(i,j,k-2,n)-temp(i,j,k-1,n))
+ delt =abs(temp(i,j,k-1,n)-temp(i,j,k, n))
+c --- sanity check on deltm and delsm
+ q=min(temp(i,j,k-2,n),temp(i,j,k-1,n),temp(i,j,k,n))
+ if (q.gt. 6.0) then
+ deltm=min( deltm, 6.0*(theta(i,j,k)-theta(i,j,k-1)) )
+ elseif (q.gt. 0.0) then
+ deltm=min( deltm, 10.0*(theta(i,j,k)-theta(i,j,k-1)) )
+ else !(q.le. 0.0)
+ deltm=min( deltm, 25.0*(theta(i,j,k)-theta(i,j,k-1)) )
+ endif
+ delsm=min( delsm, 1.3*(theta(i,j,k)-theta(i,j,k-1)) )
+ qts=0.0
+ if (delt.gt.epsil) then
+ qts=max(qts, (min(deltm, 2.0*delt)-delt)/delt) ! qts<=1.0
+ endif
+ if (dels.gt.epsil) then
+ qts=max(qts, (min(delsm, 2.0*dels)-dels)/dels) ! qts<=1.0
+ endif
+ q=(theta(i,j,k)-th3d(i,j,k, n))/
+ & (theta(i,j,k)-th3d(i,j,k-1,n))
+ q=min(q,qts/(1.0+qts)) ! upper sublayer <= 50% of total
+ q=qhrlx(k)*q
+c --- qhrlx is relaxation coefficient (inverse baroclinic time steps)
+ p_hat=q*(p(i,j,k+1)-p(i,j,k))
+ p(i,j,k)=p(i,j,k)+p_hat
+ if (hybflg.eq.0) then !T&S
+ temp(i,j,k,n)=temp(i,j,k,n)+(q/(1.0-q))*(temp(i,j,k,n) -
+ & temp(i,j,k-1,n) )
+ saln(i,j,k,n)=saln(i,j,k,n)+(q/(1.0-q))*(saln(i,j,k,n) -
+ & saln(i,j,k-1,n) )
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ elseif (hybflg.eq.1) then !th&S
+ th3d(i,j,k,n)=th3d(i,j,k,n)+(q/(1.0-q))*(th3d(i,j,k,n) -
+ & th3d(i,j,k-1,n) )
+ saln(i,j,k,n)=saln(i,j,k,n)+(q/(1.0-q))*(saln(i,j,k,n) -
+ & saln(i,j,k-1,n) )
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ elseif (hybflg.eq.2) then !th&T
+ th3d(i,j,k,n)=th3d(i,j,k,n)+(q/(1.0-q))*(th3d(i,j,k,n) -
+ & th3d(i,j,k-1,n) )
+ temp(i,j,k,n)=temp(i,j,k,n)+(q/(1.0-q))*(temp(i,j,k,n) -
+ & temp(i,j,k-1,n) )
+ saln(i,j,k,n)=sofsig(th3d(i,j,k,n)+thbase,temp(i,j,k,n))
+ endif
+ if (ntracr.gt.0 .and. p_hat.ne.0.0) then
+ qtr=p_hat/(p(i,j,k)-p(i,j,k-1)) !ok because <1.0 and >0.0
+ do ktr= 1,ntracr
+ if (trcflg(ktr).eq.2) then !temperature tracer
+ tracer(i,j,k,n,ktr)=tracer(i,j,k,n,ktr)+
+ & (q/(1.0-q))*(tracer(i,j,k, n,ktr)-
+ & tracer(i,j,k-1,n,ktr))
+ else !standard tracer - not split into two sub-layers
+ tracer(i,j,k-1,n,ktr)=tracer(i,j,k-1,n,ktr)+
+ & qtr*(tracer(i,j,k, n,ktr)-
+ & tracer(i,j,k-1,n,ktr))
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i4,i3,5e12.3)')
+cdiag & 'hybgen, 10(+):',
+cdiag & k,ktr,p_hat,p(i,j,k),p(i,j,k-1),
+cdiag & qtr,tracer(i,j,k-1,n,ktr)
+cdiag call flush(lp)
+cdiag endif !debug
+ endif !trcflg
+ enddo !ktr
+ endif !tracers
+ if (mxlmy .and. p_hat.ne.0.0) then
+ qtr=p_hat/(p(i,j,k)-p(i,j,k-1)) !ok because <1.0 and >0.0
+ q2( i,j,k-1,n)=q2( i,j,k-1,n)+
+ & qtr*(q2( i,j,k,n)-q2( i,j,k-1,n))
+ q2l(i,j,k-1,n)=q2l(i,j,k-1,n)+
+ & qtr*(q2l(i,j,k,n)-q2l(i,j,k-1,n))
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i4,i3,6e12.3)')
+cdiag & 'hybgen, 10(+):',
+cdiag & k,0,p_hat,p(i,j,k)-p(i,j,k-1),p(i,j,k+1)-p(i,j,k),
+cdiag & qtr,q2(i,j,k-1,n),q2l(i,j,k-1,n)
+cdiag call flush(lp)
+cdiag endif !debug
+ endif
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3,f6.3,5f8.3)')
+cdiag & 'hybgen, 10(+):',
+cdiag & k,q,temp(i,j,k,n),saln(i,j,k,n),
+cdiag & th3d(i,j,k,n)+thbase,theta(i,j,k)+thbase
+cdiag call flush(lp)
+cdiag endif !debug
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3,f6.3,5f8.3)')
+cdiag & 'hybgen, 10(-):',
+cdiag & k,0.0,temp(i,j,k,n),saln(i,j,k,n),
+cdiag & th3d(i,j,k,n)+thbase,theta(i,j,k)+thbase
+cdiag call flush(lp)
+cdiag endif !debug
+ endif !too light
+c
+c --- store one-dimensional arrays of -temp-, -saln-, and -p- for the 'old'
+c --- vertical grid before attempting to restore isopycnic conditions
+ pres(1)=p(i,j,1)
+ do k=1,kk
+ if (hybflg.eq.0) then !T&S
+ s1d(k,1) = temp(i,j,k,n)
+ s1d(k,2) = saln(i,j,k,n)
+ elseif (hybflg.eq.1) then !th&S
+ s1d(k,1) = th3d(i,j,k,n)
+ s1d(k,2) = saln(i,j,k,n)
+ elseif (hybflg.eq.2) then !th&T
+ s1d(k,1) = th3d(i,j,k,n)
+ s1d(k,2) = temp(i,j,k,n)
+ endif
+ do ktr= 1,ntracr
+ s1d(k,2+ktr) = tracer(i,j,k,n,ktr)
+ enddo
+ if (mxlmy) then
+ s1d(k,ntracr+3) = q2( i,j,k,n)
+ s1d(k,ntracr+4) = q2l(i,j,k,n)
+ endif
+ pres(k+1)=p(i,j,k+1)
+ dprs(k) =pres(k+1)-pres(k)
+ dpi( k) =max(dprs(k),dpthin)
+c
+ if (isopcm) then
+ if (k.le.fixlay) then
+ lcm(k) = .false. !fixed layers are never PCM
+ else
+c --- thin and isopycnal layers remapped with PCM.
+ lcm(k) = k.gt.nhybrd
+ & .or. dprs(k).le.dpthin
+ & .or. abs(th3d(i,j,k,n)-theta(i,j,k)).lt.hybiso
+ endif !k<=fixlay:else
+ endif !isopcm
+ enddo !k
+c
+c --- try to restore isopycnic conditions by moving layer interfaces
+c --- qhrlx(k) are relaxation coefficients (inverse baroclinic time steps)
+c
+ if (fixlay.ge.1) then
+c
+c --- maintain constant thickness, layer k = 1
+ k=1
+ p_hat=p(i,j,k)+dp0ij(k)
+ p(i,j,k+1)=min(p_hat,p(i,j,k+2))
+ endif
+c
+ do k=2,nhybrd
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(cinfo,'(a9,i2.2,1x)') ' do 88 k=',k
+cdiag 109 format (i9,2i5,a,a/(i9,8x,a,a,i3,f9.2,f8.2,f9.2,f8.2))
+cdiag write(lp,109) nstep,itest+i0,jtest+j0,
+cdiag. cinfo,': othkns odpth nthkns ndpth',
+cdiag. (nstep,cinfo,':',ka,
+cdiag. (pres(ka+1)-
+cdiag. pres(ka) )*qonem,
+cdiag. pres(ka+1) *qonem,
+cdiag. (p(itest,jtest,ka+1)-
+cdiag. p(itest,jtest,ka) )*qonem,
+cdiag. p(itest,jtest,ka+1) *qonem,ka=1,kk)
+cdiag call flush(lp)
+cdiag endif !debug
+c
+ if (k.le.fixlay) then
+c
+c --- maintain constant thickness, k <= fixlay
+ if (k.lt.kk) then !p.kk+1 not changed
+ p(i,j,k+1)=min(dp0cum(k+1),p(i,j,kk+1))
+ if (k.eq.fixlay) then
+c --- enforce interface order (may not be necessary).
+ do ka= k+2,kk
+ if (p(i,j,ka).ge.p(i,j,k+1)) then
+ exit ! usually get here quickly
+ else
+ p(i,j,ka) = p(i,j,k+1)
+ endif
+ enddo !ka
+ endif !k.eq.fixlay
+ endif !k.lt.kk
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i3.2,f8.2)') 'hybgen, fixlay :',
+cdiag& k+1,p(i,j,k+1)*qonem
+cdiag call flush(lp)
+cdiag endif !debug
+ else
+c
+c --- do not maintain constant thickness, k > fixlay
+c
+ if (th3d(i,j,k,n).gt.theta(i,j,k)+epsil .and.
+ & k.gt.fixlay+1) then
+c
+c --- water in layer k is too dense
+c --- try to dilute with water from layer k-1
+c --- do not move interface if k = fixlay + 1
+c
+ if (th3d(i,j,k-1,n).ge.theta(i,j,k-1) .or.
+ & p(i,j,k).le.dp0cum(k)+onem .or.
+ & p(i,j,k+1)-p(i,j,k).le.p(i,j,k)-p(i,j,k-1)) then
+c
+c --- if layer k-1 is too light, thicken the thinner of the two,
+c --- i.e. skip this layer if it is thicker.
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,3x,i2.2,1pe13.5)')
+cdiag& 'hybgen, too dense:',k,th3d(i,j,k,n)-theta(i,j,k)
+cdiag call flush(lp)
+cdiag endif !debug
+c
+ if ((theta(i,j,k)-th3d(i,j,k-1,n)).le.epsil) then
+c layer k-1 too dense, take entire layer
+ p_hat=p(i,j,k-1)+dp0ij(k-1)
+ else
+ q=(theta(i,j,k)-th3d(i,j,k, n))/
+ & (theta(i,j,k)-th3d(i,j,k-1,n)) ! -1 <= q < 0
+ p_hat0=p(i,j,k)+q*(p(i,j,k+1)-p(i,j,k)) ! p(i,j,k+1)
+ endif
+c
+c --- if layer k+1 does not touch the bottom then maintain minimum
+c --- thicknesses of layers k and k+1 as much as possible,
+c --- but permit layers to collapse to zero thickness at the bottom
+c
+ if (p(i,j,k+2).lt.p(i,j,kk+1)) then
+ if (p(i,j,kk+1)-p(i,j,k).gt.
+ & dp0ij(k)+dp0ij(k+1) ) then
+ p_hat=p(i,j,k+2)-cushn(p(i,j,k+2)-p_hat,dp0ij(k+1))
+ endif
+ p_hat=p(i,j,k)+max(p_hat-p(i,j,k),dp0ij(k))
+ p_hat=min(p_hat,
+ & max(0.5*(p(i,j,k+1)+p(i,j,k+2)),
+ & p(i,j,k+2)-dp0ij(k+1)))
+ else
+ p_hat=min(p(i,j,k+2),p_hat)
+ endif !p.k+2= dpthin
+ & dprs(kdm), !original layer thicknesses
+ & pres(kdm+1), !original layer interfaces
+ & prsf(kdm+1) !final layer interfaces
+ real dpthin
+c
+c --- vertical momentum flux across moving interfaces (the s-dot term in the
+c --- momentum equation) - required to locally conserve momentum when hybgen
+c --- moves vertical coordinates.
+c
+ dpthin = 0.001*onemm
+c
+c --- always use high order remapping for velocity
+ do k=1,kk
+ lcm(k) = .false. !use same remapper for all layers
+ enddo !k
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+c
+c --- store one-dimensional arrays of -u- and -p- for the 'old' vertical grid
+ pres(1)=pu(i,j,1)
+ do k=1,kk
+ s1d(k) =u(i,j,k,n)
+ pres(k+1)=pu(i,j,k+1)
+ dprs(k) =pres(k+1)-pres(k)
+ dpi( k) =max(dprs(k),dpthin)
+ enddo !k
+c
+c --- remap -u- profiles from the 'old' vertical grid onto the
+c --- 'new' vertical grid.
+c
+ prsf(1) = pu(i,j,1)
+ do k=1,kk
+ pu(i,j,k+1) = pu(i,j,k) + dpu(i,j,k,n) !new vertical grid
+ prsf(k+1) = pu(i,j,k+1)
+ enddo
+ if (hybmap.eq.0) then !PCM
+ call hybgen_pcm_remap(s1d,pres,dprs,
+ & f1d,prsf,kk,kk,1, dpthin)
+ elseif (hybmap.eq.1 .and. hybiso.gt.2.0) then !PLM (as in 2.1.08)
+ call hybgen_plm_coefs(s1d, dprs,lcm,c1d,
+ & kk, 1, dpthin)
+ call hybgen_plm_remap(s1d,pres,dprs, c1d,
+ & f1d,prsf,kk,kk,1, dpthin)
+ else !WENO-like (even if scalar fields are PLM or PPM)
+ call hybgen_weno_coefs(s1d, dpi, lcm,c1d,
+ & kk, 1, dpthin)
+ call hybgen_weno_remap(s1d,pres,dprs, c1d,
+ & f1d,prsf,kk,kk,1, dpthin)
+ endif !hybmap
+ do k=1,kk
+ if (dpi(k).gt.dpthin .or.
+ & prsf(k).le.prsf(kk+1)-onemm) then
+ u(i,j,k,n) = f1d(k)
+ else
+* --- thin near-bottom layer, zero total current
+ u(i,j,k,n) = -ubavg(i,j,n)
+ endif
+ enddo !k
+c
+ 104 format (i9,2i5,a/(33x,i3,f8.3,f9.3,f9.2))
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,104) nstep,itest+i0,jtest+j0,
+cdiag& ' hybgen, do 412: u thkns dpth',
+cdiag& (k,s1d(k,1),
+cdiag& (pres(k+1)-pres(k))*qonem,pres(k+1)*qonem,
+cdiag& k,u(i,j,k,n),
+cdiag& dpu(i,j,k,n)*qonem,pu(i,j,k+1)*qonem,
+cdiag& k=1,kk)
+cdiag endif !debug
+c
+ enddo !i
+ enddo !l
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+c
+c --- store one-dimensional arrays of -v- and -p- for the 'old' vertical grid
+ pres(1)=pv(i,j,1)
+ do k=1,kk
+ s1d(k) =v(i,j,k,n)
+ pres(k+1)=pv(i,j,k+1)
+ dprs(k) =pres(k+1)-pres(k)
+ dpi( k) =max(dprs(k),dpthin)
+ enddo !k
+c
+c --- remap -v- profiles from the 'old' vertical grid onto the
+c --- 'new' vertical grid.
+c
+ prsf(1) = pv(i,j,1)
+ do k=1,kk
+ pv(i,j,k+1) = pv(i,j,k) + dpv(i,j,k,n) !new vertical grid
+ prsf(k+1) = pv(i,j,k+1)
+ enddo !k
+ if (hybmap.eq.0) then !PCM
+ call hybgen_pcm_remap(s1d,pres,dprs,
+ & f1d,prsf,kk,kk,1, dpthin)
+ elseif (hybmap.eq.1 .and. hybiso.gt.2.0) then !PLM (as in 2.1.08)
+ call hybgen_plm_coefs(s1d, dprs,lcm,c1d,
+ & kk, 1, dpthin)
+ call hybgen_plm_remap(s1d,pres,dprs, c1d,
+ & f1d,prsf,kk,kk,1, dpthin)
+ else !WENO-like (even if scalar fields are PLM or PPM)
+ call hybgen_weno_coefs(s1d, dpi, lcm,c1d,
+ & kk, 1, dpthin)
+ call hybgen_weno_remap(s1d,pres,dprs, c1d,
+ & f1d,prsf,kk,kk,1, dpthin)
+ endif !hybmap
+ do k=1,kk
+ if (dpi(k).gt.dpthin .or.
+ & prsf(k).le.prsf(kk+1)-onemm) then
+ v(i,j,k,n) = f1d(k)
+ else
+* --- thin near-bottom layer, zero total current
+ v(i,j,k,n) = -vbavg(i,j,n)
+ endif
+ enddo !k
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,104) nstep,itest+i0,jtest+j0,
+cdiag& ' hybgen, do 512: v thkns dpth',
+cdiag& (k,s1d(k,1),
+cdiag& (pres(k+1)-pres(k))*qonem,pres(k+1)*qonem,
+cdiag& k,v(i,j,k,n),
+cdiag& dpv(i,j,k,n)*qonem,pv(i,j,k+1)*qonem,
+cdiag& k=1,kk)
+cdiag endif !debug
+c
+ enddo !i
+ enddo !l
+c
+ return
+ end subroutine hybgenbj
+
+ subroutine hybgen_pcm_remap(si,pi,dpi,
+ & so,po,ki,ko,ks,thin)
+ implicit none
+c
+ integer ki,ko,ks
+ real si(ki,ks),pi(ki+1),dpi(ki),
+ & so(ko,ks),po(ko+1),thin
+c
+c-----------------------------------------------------------------------
+c 1) remap from one set of vertical cells to another.
+c method: piecewise constant across each input cell
+c the output is the average of the interpolation
+c profile across each output cell.
+c
+c PCM (donor cell) is the standard 1st order upwind method.
+c
+c 2) input arguments:
+c si - initial scalar fields in pi-layer space
+c pi - initial layer interface depths (non-negative)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c pi(k+1) >= pi(k)
+c dpi - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+c ki - number of input layers
+c ko - number of output layers
+c ks - number of fields
+c po - target interface depths (non-negative)
+c po( 1) is the surface
+c po(ko+1) is the bathymetry (== pi(ki+1))
+c po(k+1) >= po(k)
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) Tim Campbell, Mississippi State University, October 2002.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer i,k,l,lb,lt
+ real dpb,dpt,xb,xt,zb,zt,zx,o
+ real*8 sz
+c
+ zx=pi(ki+1) !maximum depth
+ zb=max(po(1),pi(1))
+ lb=1
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ do k= 1,ko !output layers
+ zt = zb
+ zb = min(po(k+1),zx)
+* write(lp,*) 'k,zt,zb = ',k,zt,zb
+ lt=lb !top will always correspond to bottom of previous
+ !find input layer containing bottom output interface
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ if (zb-zt.le.thin .or. zt.ge.zx) then
+ if (k.ne.1) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else !thin surface layer
+ do i= 1,ks
+ so(k,i) = si(k,i)
+ enddo !i
+ endif
+ else
+c
+c form layer averages.
+c use PPM-like logic (may not have minimum operation count)
+c
+* if (pi(lb).gt.zt) then
+* write(lp,*) 'bad lb = ',lb
+* stop
+* endif
+ if (lt.ne.lb) then !multiple layers
+ xt=(zt-pi(lt))/max(dpi(lt),thin)
+ xb=(zb-pi(lb))/max(dpi(lb),thin)
+ dpt=pi(lt+1)-zt
+ dpb=zb-pi(lb)
+ do i= 1,ks
+ o = si((lt+lb)/2,i) !offset to reduce round-off
+ sz = dpt*(si(lt,i)-o)
+ do l=lt+1,lb-1
+ sz = sz+dpi(l)*(si(l,i)-o)
+ enddo !l
+ sz = sz+dpb*(si(lb,i)-o)
+ so(k,i) = o + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ else !single layer
+ do i= 1,ks
+ so(k,i) = si(lt,i)
+ enddo !i
+ endif
+ endif !thin:std layer
+ enddo !k
+ return
+ end subroutine hybgen_pcm_remap
+
+ subroutine hybgen_plm_coefs(si,dpi,lc,ci,kk,ks,thin)
+ implicit none
+c
+ integer kk,ks
+ logical lc(kk)
+ real si(kk,ks),dpi(kk),ci(kk,ks),thin
+c
+c-----------------------------------------------------------------------
+c 1) coefficents for remaping from one set of vertical cells to another.
+c method: piecewise linear across each input cell with
+c monotonized central-difference limiter.
+c
+c van Leer, B., 1977, J. Comp. Phys., 23 276-299.
+c
+c 2) input arguments:
+c si - initial scalar fields in pi-layer space
+c dpi - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+c lc - use PCM for selected layers
+c kk - number of layers
+c ks - number of fields
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c ci - coefficents (slopes) for hybgen_plm_remap
+c profile(y)=si+ci*(y-1), 0<=y<=1
+c
+c 4) Tim Campbell, Mississippi State University, October 2002.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer k,i
+ real qcen,zbot,zcen,ztop
+c
+ do i= 1,ks
+ ci(1, i) = 0.0
+ ci(kk,i) = 0.0
+ enddo !i
+ do k= 2,kk-1
+ if (lc(k) .or. dpi(k).le.thin) then !use PCM
+ do i= 1,ks
+ ci(k,i) = 0.0
+ enddo !i
+ else
+c --- use qcen in place of 0.5 to allow for non-uniform grid
+ qcen = dpi(k)/(dpi(k)+0.5*(dpi(k-1)+dpi(k+1))) !dpi(k)>thin
+ do i= 1,ks
+c --- PLM (non-zero slope, but no new extrema)
+c --- layer value is si-0.5*ci at top interface,
+c --- and si+0.5*ci at bottom interface.
+c
+c --- monotonized central-difference limiter (van Leer, 1977,
+c --- JCP 23 pp 276-299). For a discussion of PLM limiters, see
+c --- Finite Volume Methods for Hyperbolic Problems by R.J. Leveque.
+ ztop = 2.0*(si(k, i)-si(k-1,i))
+ zbot = 2.0*(si(k+1,i)-si(k, i))
+ zcen =qcen*(si(k+1,i)-si(k-1,i))
+ if (ztop*zbot.gt.0.0) then !ztop,zbot are the same sign
+ ci(k,i)=sign(min(abs(zcen),abs(zbot),abs(ztop)),zbot)
+ else
+ ci(k,i)=0.0 !local extrema, so no slope
+ endif
+ enddo !i
+ endif !PCM:PLM
+ enddo !k
+ return
+ end subroutine hybgen_plm_coefs
+
+ subroutine hybgen_plm_remap(si,pi,dpi,ci,
+ & so,po,ki,ko,ks,thin)
+ implicit none
+c
+ integer ki,ko,ks
+ real si(ki,ks),pi(ki+1),dpi(ki),ci(ki,ks),
+ & so(ko,ks),po(ko+1),thin
+c
+c-----------------------------------------------------------------------
+c 1) remap from one set of vertical cells to another.
+c method: piecewise linear across each input cell
+c the output is the average of the interpolation
+c profile across each output cell.
+c
+c van Leer, B., 1977, J. Comp. Phys., 23 276-299.
+c
+c 2) input arguments:
+c si - initial scalar fields in pi-layer space
+c pi - initial layer interface depths (non-negative)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c pi(k+1) >= pi(k)
+c dpi - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+c ci - coefficents (slopes) from hybgen_plm_coefs
+c profile(y)=si+ci*(y-1), 0<=y<=1
+c ki - number of input layers
+c ko - number of output layers
+c ks - number of fields
+c po - target interface depths (non-negative)
+c po( 1) is the surface
+c po(ko+1) is the bathymetry (== pi(ki+1))
+c po(k+1) >= po(k)
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) Tim Campbell, Mississippi State University, October 2002.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer i,k,l,lb,lt
+ real c0,qb0,qb1,qt0,qt1,xb,xt,zb,zt,zx,o
+ real*8 sz
+c
+ zx=pi(ki+1) !maximum depth
+ zb=max(po(1),pi(1))
+ lb=1
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ do k= 1,ko !output layers
+ zt = zb
+ zb = min(po(k+1),zx)
+* write(lp,*) 'k,zt,zb = ',k,zt,zb
+ lt=lb !top will always correspond to bottom of previous
+ !find input layer containing bottom output interface
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ if (zb-zt.le.thin .or. zt.ge.zx) then
+ if (k.ne.1) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else !thin surface layer
+ do i= 1,ks
+ so(k,i) = si(k,i)
+ enddo !i
+ endif
+ else
+c
+c form layer averages.
+c use PPM-like logic (may not have minimum operation count)
+c
+* if (pi(lb).gt.zt) then
+* write(lp,*) 'bad lb = ',lb
+* stop
+* endif
+ xt=(zt-pi(lt))/max(dpi(lt),thin)
+ xb=(zb-pi(lb))/max(dpi(lb),thin)
+ if (lt.ne.lb) then !multiple layers
+ qt0 = (1.0-xt)
+ qt1 = (1.0-xt**2)*0.5
+ qb0 = xb
+ qb1 = xb**2 *0.5
+ do i= 1,ks
+ o = si((lt+lb)/2,i) !offset to reduce round-off
+ c0 = si(lt,i) - o - 0.5*ci(lt,i)
+ sz= dpi(lt)*(c0*qt0 + ci(lt,i)*qt1)
+ do l=lt+1,lb-1
+ sz = sz+dpi(l)*(si(l,i) - o)
+ enddo !l
+ c0 = si(lb,i) - o - 0.5*ci(lb,i)
+ sz = sz+dpi(lb)*(c0*qb0 + ci(lb,i)*qb1)
+ so(k,i) = o + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ else !single layer
+ qt1 = (xb**2-xt**2 - (xb-xt))*0.5
+ do i= 1,ks
+ sz = dpi(lt)*(ci(lt,i)*qt1)
+ so(k,i) = si(lt,i) + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ endif
+ endif !thin:std layer
+ enddo !k
+ return
+ end subroutine hybgen_plm_remap
+
+ subroutine hybgen_ppm_coefs(s,dp,lc,ci,kk,ks,thin)
+ implicit none
+c
+ integer kk,ks
+ logical lc(kk)
+ real s(kk,ks),dp(kk),ci(kk,ks,3),thin
+c
+c-----------------------------------------------------------------------
+c 1) coefficents for remaping from one set of vertical cells to another.
+c method: monotonic piecewise parabolic across each input cell
+c
+c Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201.
+c
+c 2) input arguments:
+c s - initial scalar fields in pi-layer space
+c dp - initial layer thicknesses (>=thin)
+c lc - use PCM for selected layers
+c kk - number of layers
+c ks - number of fields
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c ci - coefficents for hybgen_ppm_remap
+c profile(y)=ci.1+ci.2*y+ci.3*y^2, 0<=y<=1
+c
+c 4) Tim Campbell, Mississippi State University, October 2002.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer j,i
+ real da,a6,slj,scj,srj
+ real as(kk),al(kk),ar(kk)
+ real dpjp(kk), dp2jp(kk), dpj2p(kk),
+ & qdpjp(kk),qdp2jp(kk),qdpj2p(kk),dpq3(kk),qdp4(kk)
+c
+ !compute grid metrics
+ do j=1,kk-1
+ dpjp( j) = dp(j) + dp(j+1)
+ dp2jp(j) = dp(j) + dpjp(j)
+ dpj2p(j) = dpjp(j) + dp(j+1)
+ qdpjp( j) = 1.0/dpjp( j)
+ qdp2jp(j) = 1.0/dp2jp(j)
+ qdpj2p(j) = 1.0/dpj2p(j)
+ enddo !j
+ dpq3(2) = dp(2)/(dp(1)+dpjp(2))
+ do j=3,kk-1
+ dpq3(j) = dp(j)/(dp(j-1)+dpjp(j)) !dp(j)/ (dp(j-1)+dp(j)+dp(j+1))
+ qdp4(j) = 1.0/(dpjp(j-2)+dpjp(j)) !1.0/(dp(j-2)+dp(j-1)+dp(j)+dp(j+1))
+ enddo !j
+c
+ do i= 1,ks
+ !Compute average slopes: Colella, Eq. (1.8)
+ as(1)=0.
+ do j=2,kk-1
+ if (lc(j) .or. dp(j).le.thin) then !use PCM
+ as(j) = 0.0
+ else
+ slj=s(j, i)-s(j-1,i)
+ srj=s(j+1,i)-s(j, i)
+ if (slj*srj.gt.0.) then
+ scj=dpq3(j)*( dp2jp(j-1)*srj*qdpjp(j)
+ & +dpj2p(j) *slj*qdpjp(j-1) )
+ as(j)=sign(min(abs(2.0*slj),abs(scj),abs(2.0*srj)),scj)
+ else
+ as(j)=0.
+ endif
+ endif !PCM:PPM
+ enddo !j
+ as(kk)=0.
+ !Compute "first guess" edge values: Colella, Eq. (1.6)
+ al(1)=s(1,i) !1st layer PCM
+ ar(1)=s(1,i) !1st layer PCM
+ al(2)=s(1,i) !1st layer PCM
+ do j=3,kk-1
+ al(j)=s(j-1,i)+dp(j-1)*(s(j,i)-s(j-1,i))*qdpjp(j-1)
+ & +qdp4(j)*(
+ & 2.*dp(j)*dp(j-1)*qdpjp(j-1)*(s(j,i)-s(j-1,i))*
+ & ( dpjp(j-2)*qdp2jp(j-1)
+ & -dpjp(j) *qdpj2p(j-1) )
+ & -dp(j-1)*as(j) *dpjp(j-2)*qdp2jp(j-1)
+ & +dp(j) *as(j-1)*dpjp(j) *qdpj2p(j-1)
+ & )
+ ar(j-1)=al(j)
+ enddo !j
+ ar(kk-1)=s(kk,i) !last layer PCM
+ al(kk) =s(kk,i) !last layer PCM
+ ar(kk) =s(kk,i) !last layer PCM
+ !Impose monotonicity: Colella, Eq. (1.10)
+ do j=2,kk-1
+ if (lc(j) .or. dp(j).le.thin) then !use PCM
+ al(j)=s(j,i)
+ ar(j)=s(j,i)
+ elseif ((s(j+1,i)-s(j,i))*(s(j,i)-s(j-1,i)).le.0.) then !local extremum
+ al(j)=s(j,i)
+ ar(j)=s(j,i)
+ else
+ da=ar(j)-al(j)
+ a6=6.0*s(j,i)-3.0*(al(j)+ar(j))
+ if (da*a6 .gt. da*da) then !peak in right half of zone
+ al(j)=3.0*s(j,i)-2.0*ar(j)
+ elseif (da*a6 .lt. -da*da) then !peak in left half of zone
+ ar(j)=3.0*s(j,i)-2.0*al(j)
+ endif
+ endif
+ enddo !j
+ !Set coefficients
+ do j=1,kk
+ if (al(j).ne.ar(j)) then
+ ci(j,i,1)=al(j)
+ ci(j,i,2)=ar(j)-al(j)
+ ci(j,i,3)=6.0*s(j,i)-3.0*(al(j)+ar(j))
+ else !PCM
+ ci(j,i,1)=al(j)
+ ci(j,i,2)=0.0
+ ci(j,i,3)=0.0
+ endif
+ enddo !j
+ enddo !i
+ return
+ end subroutine hybgen_ppm_coefs
+
+ subroutine hybgen_ppm_remap(si,pi,dpi,ci,
+ & so,po,ki,ko,ks,thin)
+ implicit none
+c
+ integer ki,ko,ks
+ real si(ki,ks),pi(ki+1),dpi(ki),ci(ki,ks,3),
+ & so(ko,ks),po(ko+1),thin
+c
+c-----------------------------------------------------------------------
+c 1) remap from one set of vertical cells to another.
+c method: monotonic piecewise parabolic across each input cell
+c the output is the average of the interpolation
+c profile across each output cell.
+c Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201.
+c
+c 2) input arguments:
+c si - initial scalar fields in pi-layer space
+c pi - initial layer interface depths (non-negative)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c pi(k+1) >= pi(k)
+c dpi - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+c ci - coefficents from hybgen_ppm_coefs
+c profile(y)=ci.1+ci.2*y+ci.3*y^2, 0<=y<=1
+c ki - number of input layers
+c ko - number of output layers
+c ks - number of fields
+c po - target interface depths (non-negative)
+c po( 1) is the surface
+c po(ko+1) is the bathymetry (== pi(ki+1))
+c po(k+1) >= po(k)
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) Tim Campbell, Mississippi State University, October 2002.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer i,k,l,lb,lt
+ real qb0,qb1,qb2,qt0,qt1,qt2,xb,xt,zb,zt,zx,o
+ real*8 sz
+c
+ zx=pi(ki+1) !maximum depth
+ zb=max(po(1),pi(1))
+ lb=1
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ do k= 1,ko !output layers
+ zt = zb
+ zb = min(po(k+1),zx)
+* write(lp,*) 'k,zt,zb = ',k,zt,zb
+ lt=lb !top will always correspond to bottom of previous
+ !find input layer containing bottom output interface
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ if (zb-zt.le.thin .or. zt.ge.zx) then
+ if (k.ne.1) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else !thin surface layer
+ do i= 1,ks
+ so(k,i) = si(k,i)
+ enddo !i
+ endif
+ else
+c
+c form layer averages.
+c
+* if (pi(lb).gt.zt) then
+* write(lp,*) 'bad lb = ',lb
+* stop
+* endif
+ xt=(zt-pi(lt))/max(dpi(lt),thin)
+ xb=(zb-pi(lb))/max(dpi(lb),thin)
+ if (lt.ne.lb) then !multiple layers
+ qt0 = (1.0-xt)
+ qt1 = (1.-xt**2)*0.5
+ qt2 = (1.-xt**3)/3.0
+ qb0 = xb
+ qb1 = xb**2 *0.5
+ qb2 = xb**3 /3.0
+ do i= 1,ks
+ o = si((lt+lb)/2,i) !offset to reduce round-off
+ sz = dpi(lt)*( (ci(lt,i,1)-o)*qt0
+ & +(ci(lt,i,2)+
+ & ci(lt,i,3) ) *qt1
+ & -ci(lt,i,3) *qt2 )
+ do l=lt+1,lb-1
+ sz = sz+dpi(l)*(si(l,i)-o)
+ enddo !l
+ sz = sz+dpi(lb)*( (ci(lb,i,1)-o)*qb0
+ & +(ci(lb,i,2)+
+ & ci(lb,i,3) ) *qb1
+ & -ci(lb,i,3) *qb2 )
+ so(k,i) = o + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ else !single layer
+ qt0 = (xb-xt)
+ qt1 = (xb**2-xt**2)*0.5
+ qt2 = (xb**3-xt**3)/3.0
+ do i= 1,ks
+ sz = dpi(lt)*( (ci(lt,i,1)-o)*qt0
+ & +(ci(lt,i,2)+
+ & ci(lt,i,3) ) *qt1
+ & -ci(lt,i,3) *qt2 )
+ so(k,i) = o + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ endif
+ endif !thin:std layer
+ enddo !k
+ return
+ end subroutine hybgen_ppm_remap
+
+ subroutine hybgen_weno_coefs(s,dp,lc,ci,kk,ks,thin)
+ implicit none
+c
+ integer kk,ks
+ logical lc(kk)
+ real s(kk,ks),dp(kk),ci(kk,ks,2),thin
+c
+c-----------------------------------------------------------------------
+c 1) coefficents for remaping from one set of vertical cells to another.
+c method: monotonic WENO-like alternative to PPM across each input cell
+c a second order polynomial approximation of the profiles
+c using a WENO reconciliation of the slopes to compute the
+c interfacial values
+c
+c REFERENCE?
+c
+c 2) input arguments:
+c s - initial scalar fields in pi-layer space
+c dp - initial layer thicknesses (>=thin)
+c lc - use PCM for selected layers
+c kk - number of layers
+c ks - number of fields
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c ci - coefficents for hybgen_weno_remap
+c ci.1 is value at interface above
+c ci.2 is value at interface below
+c
+c 4) Laurent Debreu, Grenoble.
+c Alan J. Wallcraft, Naval Research Laboratory, July 2008.
+c-----------------------------------------------------------------------
+c
+ real, parameter :: dsmll=1.0e-8
+c
+ integer j,i
+ real q,q01,q02,q001,q002
+ real qdpjm(kk),qdpjmjp(kk),dpjm2jp(kk)
+ real zw(kk+1,3)
+
+ !compute grid metrics
+ do j=2,kk-1
+ qdpjm( j) = 1.0/(dp(j-1) + dp(j))
+ qdpjmjp(j) = 1.0/(dp(j-1) + dp(j) + dp(j+1))
+ dpjm2jp(j) = dp(j-1) + 2.0*dp(j) + dp(j+1)
+ enddo !j
+ j=kk
+ qdpjm( j) = 1.0/(dp(j-1) + dp(j))
+c
+ do i= 1,ks
+ do j=2,kk
+ zw(j,3) = qdpjm(j)*(s(j,i)-s(j-1,i))
+ enddo !j
+ j = 1 !PCM first layer
+ ci(j,i,1) = s(j,i)
+ ci(j,i,2) = s(j,i)
+ zw(j, 1) = 0.0
+ zw(j, 2) = 0.0
+ do j=2,kk-1
+ if (lc(j) .or. dp(j).le.thin) then !use PCM
+ ci(j,i,1) = s(j,i)
+ ci(j,i,2) = s(j,i)
+ zw(j, 1) = 0.0
+ zw(j, 2) = 0.0
+ else
+ q001 = dp(j)*zw(j+1,3)
+ q002 = dp(j)*zw(j, 3)
+ if (q001*q002 < 0.0) then
+ q001 = 0.0
+ q002 = 0.0
+ endif
+ q01 = dpjm2jp(j)*zw(j+1,3)
+ q02 = dpjm2jp(j)*zw(j, 3)
+ if (abs(q001) > abs(q02)) then
+ q001 = q02
+ endif
+ if (abs(q002) > abs(q01)) then
+ q002 = q01
+ endif
+ q = (q001-q002)*qdpjmjp(j)
+ q001 = q001-q*dp(j+1)
+ q002 = q002+q*dp(j-1)
+
+ ci(j,i,2) = s(j,i)+q001
+ ci(j,i,1) = s(j,i)-q002
+ zw( j,1) = (2.0*q001-q002)**2
+ zw( j,2) = (2.0*q002-q001)**2
+ endif !PCM:WEND
+ enddo !j
+ j = kk !PCM last layer
+ ci(j,i,1) = s(j,i)
+ ci(j,i,2) = s(j,i)
+ zw(j, 1) = 0.0
+ zw(j, 2) = 0.0
+
+ do j=2,kk
+ q002 = max(zw(j-1,2),dsmll)
+ q001 = max(zw(j, 1),dsmll)
+ zw(j,3) = (q001*ci(j-1,i,2)+q002*ci(j,i,1))/(q001+q002)
+ enddo !j
+ zw( 1,3) = 2.0*s( 1,i)-zw( 2,3) !not used?
+ zw(kk+1,3) = 2.0*s(kk,i)-zw(kk,3) !not used?
+
+ do j=2,kk-1
+ if (.not.(lc(j) .or. dp(j).le.thin)) then !don't use PCM
+ q01 = zw(j+1,3)-s(j,i)
+ q02 = s(j,i)-zw(j,3)
+ q001 = 2.0*q01
+ q002 = 2.0*q02
+ if (q01*q02 < 0.0) then
+ q01 = 0.0
+ q02 = 0.0
+ elseif (abs(q01) > abs(q002)) then
+ q01 = q002
+ elseif (abs(q02) > abs(q001)) then
+ q02 = q001
+ endif
+ ci(j,i,1) = s(j,i)-q02
+ ci(j,i,2) = s(j,i)+q01
+ endif !PCM:WEND
+ enddo !j
+ enddo !i
+ return
+ end subroutine hybgen_weno_coefs
+
+ subroutine hybgen_weno_remap(si,pi,dpi,ci,
+ & so,po,ki,ko,ks,thin)
+ implicit none
+c
+ integer ki,ko,ks
+ real si(ki,ks),pi(ki+1),dpi(ki),ci(ki,ks,2),
+ & so(ko,ks),po(ko+1),thin
+c
+c-----------------------------------------------------------------------
+c 1) remap from one set of vertical cells to another.
+c method: monotonic WENO-like alternative to PPM across each input cell
+c a second order polynomial approximation of the profiles
+c using a WENO reconciliation of the slopes to compute the
+c interfacial values
+c the output is the average of the interpolation
+c profile across each output cell.
+c
+c REFERENCE?
+c
+c 2) input arguments:
+c si - initial scalar fields in pi-layer space
+c pi - initial layer interface depths (non-negative)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c pi(k+1) >= pi(k)
+c dpi - initial layer thicknesses (dpi(k)=pi(k+1)-pi(k))
+c ci - coefficents from hybgen_weno_coefs
+c ci.1 is value at interface above
+c ci.2 is value at interface below
+c ki - number of input layers
+c ko - number of output layers
+c ks - number of fields
+c po - target interface depths (non-negative)
+c po( 1) is the surface
+c po(ko+1) is the bathymetry (== pi(ki+1))
+c po(k+1) >= po(k)
+c thin - layer thickness (>0) that can be ignored
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) Laurent Debreu, Grenoble.
+c Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007.
+c-----------------------------------------------------------------------
+c
+ integer i,k,l,lb,lt
+ real dpb,dpt,qb0,qb1,qb2,qt0,qt1,qt2,xb,xt,zb,zt,zx,o
+ real*8 sz
+c
+ zx=pi(ki+1) !maximum depth
+ zb=max(po(1),pi(1))
+ lb=1
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ do k= 1,ko !output layers
+ zt = zb
+ zb = min(po(k+1),zx)
+* write(lp,*) 'k,zt,zb = ',k,zt,zb
+ lt=lb !top will always correspond to bottom of previous
+ !find input layer containing bottom output interface
+ do while (pi(lb+1).lt.zb .and. lb.lt.ki)
+ lb=lb+1
+ enddo
+ if (zb-zt.le.thin .or. zt.ge.zx) then
+ if (k.ne.1) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else !thin surface layer
+ do i= 1,ks
+ so(k,i) = si(k,i)
+ enddo !i
+ endif
+ else
+c
+c form layer averages.
+c
+* if (pi(lb).gt.zt) then
+* write(lp,*) 'bad lb = ',lb
+* stop
+* endif
+ xt=(zt-pi(lt))/max(dpi(lt),thin)
+ xb=(zb-pi(lb))/max(dpi(lb),thin)
+ if (lt.ne.lb) then !multiple layers
+ dpt = pi(lt+1)-zt
+ dpb = zb-pi(lb)
+ qt1 = xt*(xt-1.0)
+ qt2 = qt1+xt
+ qt0 = 1.0-qt1-qt2
+ qb1 = (xb-1.0)**2
+ qb2 = qb1-1.0+xb
+ qb0 = 1.0-qb1-qb2
+ do i= 1,ks
+ o = si((lt+lb)/2,i) !offset to reduce round-off
+ sz = dpt*(qt0*(si(lt,i) -o) +
+ & qt1*(ci(lt,i,1)-o) +
+ & qt2*(ci(lt,i,2)-o) )
+ do l=lt+1,lb-1
+ sz = sz+dpi(l)*(si(l,i) - o)
+ enddo !l
+ sz = sz + dpb*(qb0*(si(lb,i) -o) +
+ & qb1*(ci(lb,i,1)-o) +
+ & qb2*(ci(lb,i,2)-o) )
+ so(k,i) = o + sz/(zb-zt) !zb-zt>=thin
+ enddo !i
+ else !single layer
+ qt1 = xb**2 + xt**2 + xb*xt + 1.0 - 2.0*(xb+xt)
+ qt2 = qt1 - 1.0 + (xb+xt)
+ qt0 = 1.0 - qt1 - qt2
+ do i= 1,ks
+ sz=qt0*(si(lt,i) -o) +
+ & qt1*(ci(lt,i,1)-o) +
+ & qt2*(ci(lt,i,2)-o)
+ so(k,i) = o + sz
+ enddo !i
+ endif !layers
+ endif !thin:std layer
+ enddo !k
+ return
+ end subroutine hybgen_weno_remap
+
+c
+c
+c> Revision history:
+c>
+c> Feb. 2000 -- total rewrite to convert to 'newzp' approach
+c> Jul. 2000 -- added hybgenj for OpenMP parallelization
+c> Oct. 2000 -- added hybgenbj to simplify OpenMP logic
+c> Nov. 2000 -- fill massless layers on sea floor with salinity from above
+c> Nov. 2000 -- unmixing of deepest inflated layer uses th&T&S from above
+c> Nov. 2000 -- ignored isopycnic variance is now 0.002
+c> Nov. 2000 -- iterate to correct for cabbeling
+c> Nov. 2000 -- allow for "blocking" interior layers
+c> Nov. 2000 -- hybflg selects conserved fields (any two of T/S/th)
+c> Nov. 2002 -- replace PCM remapping with PLM when non-isopycnal
+c> Apr. 2003 -- added dp00i for thinner minimum layers away from the surface
+c> Dec. 2003 -- fixed tracer bug when deepest inflated layer is too light
+c> Dec. 2003 -- improved water column conservation
+c> Dec. 2003 -- compile time option for explicit water column conservation
+c> Dec. 2003 -- ignored isopycnic variance is now 0.0001
+c> Jan. 2004 -- shifted qqmn,qqmx range now used in cushion function
+c> Mar. 2004 -- minimum thickness no longer enforced in near-bottom layers
+c> Mar. 2004 -- ignored isopycnic variance is now epsil (i.e. very small)
+c> Mar. 2004 -- relaxation to isopycnic layers controled via hybrlx
+c> Mar. 2004 -- relaxation removes the need to correct for cabbeling
+c> Mar. 2004 -- modified unmixing selection criteria
+c> Mar. 2004 -- added isotop (topiso) for isopycnal layer minimum depths
+c> Jun. 2005 -- hybrlx (qhybrlx) now input via blkdat.input
+c> Jan. 2007 -- hybrlx now only active below "fixed coordinate" surface layers
+c> Aug. 2007 -- removed mxlkta logic
+c> Sep. 2007 -- added hybmap and hybiso for PCM,PLM,PPM remaper selection
+c> Jan. 2008 -- updated logic for two layers (one too dense, other too light)
+c> Jul. 2008 -- Added WENO-like, and bugfix to PPM for lcm==.true.
+c> Aug. 2008 -- Use WENO-like (vs PPM) for most velocity remapping
+c> Aug. 2008 -- Switch more thin near-isopycnal layers to PCM remapping
diff --git a/src_2.2.18_3_one/hycom b/src_2.2.18_3_one/hycom
new file mode 100755
index 0000000..d74d9c9
Binary files /dev/null and b/src_2.2.18_3_one/hycom differ
diff --git a/src_2.2.18_3_one/hycom.F b/src_2.2.18_3_one/hycom.F
new file mode 100755
index 0000000..1546c1c
--- /dev/null
+++ b/src_2.2.18_3_one/hycom.F
@@ -0,0 +1,172 @@
+#if defined(USE_ESMF)
+ program hycom
+c
+c --- ESMF driver for stand-alone HYCOM ocean model
+c
+ use ESMF_Mod
+* use mod_hycom, only : OCEAN_SetServices => HYCOM_SetServices
+ use mod_hycom, only : end_of_run,
+ & OCEAN_SetServices => HYCOM_SetServices
+c
+ implicit none
+c
+c --- Local variables
+c
+c --- Gridded Components
+ type(ESMF_GridComp) :: oceanGridComp
+c
+c --- States, Virtual Machines, and Layouts
+ type(ESMF_VM) :: worldVM
+ type(ESMF_State) :: oceanImpState, oceanExpState
+ integer :: petCount, localPet, split
+c
+c --- Calendars and clocks
+ type(ESMF_Clock) :: worldClock
+ type(ESMF_Clock) :: oceanClock
+c
+c --- Return codes for error checks
+ integer :: rc
+c
+c --- Miscellaneous
+ integer :: i
+c
+c-------------------------------------------------------------------------------
+c Initialize the ESMF Framework
+c-------------------------------------------------------------------------------
+c
+c --- Set default calendar and log type; get world VM
+ call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN,
+ & defaultLogType=ESMF_LOG_SINGLE,
+ & vm=worldVM, rc=rc)
+ if (rc .ne. ESMF_SUCCESS) stop 99
+c
+c --- Get VM info
+ call ESMF_VMGet(worldVM, petCount=petCount, localPET=localPet,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "ESMF_VMGet failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Create section
+c-------------------------------------------------------------------------------
+c
+c --- Create the OCEAN gridded component
+ oceanGridComp = ESMF_GridCompCreate(vm=worldVM,
+ & name="OCEAN Gridded Component",
+ & gridCompType=ESMF_OCEAN,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN GridCompCreate failed", rc))
+ & goto 10
+c
+c --- Create empty OCEAN import/export states
+ oceanImpState = ESMF_StateCreate(stateName="OCEAN Import State",
+ & stateType=ESMF_STATE_IMPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN ImpState Create failed", rc))
+ & goto 10
+ oceanExpState = ESMF_StateCreate(stateName="OCEAN Export State",
+ & stateType=ESMF_STATE_EXPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN ExpState Create failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Register section
+c-------------------------------------------------------------------------------
+c
+c --- Register the OCEAN gridded component
+ call ESMF_GridCompSetServices(oceanGridComp,
+ & OCEAN_SetServices, rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN Registration failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Initalize Section
+c-------------------------------------------------------------------------------
+c
+c --- Initialize OCEAN gridded component
+ call ESMF_GridCompInitialize(gridComp=oceanGridComp,
+ & importState=oceanImpState,
+ & exportState=oceanExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN Initialize failed", rc))
+ & goto 10
+*c
+*c --- Get copy of OCEAN clock
+* call ESMF_GridCompGet(oceanGridComp, clock=oceanClock, rc=rc)
+*c
+*c --- Initialize WORLD clock using OCEAN clock
+* worldClock = ESMF_ClockCreate(clock=oceanClock, rc=rc)
+c
+c-------------------------------------------------------------------------------
+c --- Run Section
+c-------------------------------------------------------------------------------
+c
+ do !until end of run
+ call ESMF_GridCompRun(gridComp=oceanGridComp,
+ & importState=oceanImpState,
+ & exportState=oceanExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+c
+c --- use end_of_run, rather than a ESMF Clock
+ if (end_of_run) then
+ exit
+ endif
+ enddo
+c
+c-------------------------------------------------------------------------------
+c Finalize Section
+c-------------------------------------------------------------------------------
+c
+c --- Finalize OCEAN gridded component
+ call ESMF_GridCompFinalize(gridComp=oceanGridComp,
+ & importState=oceanImpState,
+ & exportState=oceanExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc, "OCEAN Finalize failed", rc))
+ & goto 10
+c
+10 continue
+ call ESMF_VMBarrier(worldVM)
+ call ESMF_Finalize(rc=rc)
+c
+ stop
+ end program hycom
+#else
+ program hycom
+c
+c --- Non-ESMF driver for stand-alone HYCOM ocean model
+c
+ use mod_hycom, only : end_of_run,
+ & HYCOM_Init,
+ & HYCOM_Run,
+ & HYCOM_Final
+c
+ implicit none
+c
+c --- Initialize HYCOM.
+ call HYCOM_Init
+
+c --- Run HYCOM.
+ do !until end of run
+ call HYCOM_Run
+ if (end_of_run) then
+ exit
+ endif
+ enddo
+c
+c --- Finalize HYCOM.
+ call HYCOM_Final
+c
+ stop
+ end program hycom
+#endif
diff --git a/src_2.2.18_3_one/hycom_cice.F b/src_2.2.18_3_one/hycom_cice.F
new file mode 100755
index 0000000..7be636d
--- /dev/null
+++ b/src_2.2.18_3_one/hycom_cice.F
@@ -0,0 +1,421 @@
+ program hycom_cice
+c
+c --- ESMF driver for HYCOM ocean model and CICE sea-ice model
+c
+ use ESMF_Mod
+ use mod_hycom, only :
+ & OCN_put_export => put_export,
+ & OCN_get_import => get_import,
+ & OCN_end_of_run => end_of_run,
+ & OCN_nts_day => nts_day,
+ & OCN_nts_cpl => nts_ice,
+ & OCN_SetServices => HYCOM_SetServices
+ use ice_kinds_mod
+ use CICE_ComponentMod, only :
+ & ICE_SetServices => CICE_SetServices
+ use CICE_InitMod, only :
+ & ICE_nts_day => nts_day
+ use CICE_RunMod, only :
+ & ICE_put_export => put_export,
+ & ICE_get_import => get_import,
+ & ICE_end_of_run => end_of_run
+ use mod_OICPL, only :
+ & CPL_i2o => ice2ocn_phase,
+ & CPL_o2i => ocn2ice_phase,
+ & CPL_SetServices => OICPL_SetServices
+c
+ implicit none
+c
+c --- Local variables
+c
+c --- Gridded Components
+ type(ESMF_GridComp) :: ocnGridComp, !HYCOM as an ESMF component
+ & iceGridComp ! CICE as an ESMF component
+c
+c --- Coupler Components
+ type(ESMF_CplComp) :: o2iCplComp
+c
+c --- States, Virtual Machines, and Layouts
+ type(ESMF_State) :: ocnImpState, ! HYCOM import state
+ & ocnExpState, ! HYCOM export state
+ & iceImpState, ! CICE import state
+ & iceExpState, ! CICE export state
+ & cplImpState, ! OICPL import state
+ & cplExpState ! OICPL export state
+c
+ type(ESMF_VM) :: worldVM
+ integer :: petCount, localPet, split
+c
+c --- Calendars and clocks
+ type(ESMF_Clock) :: worldClock
+ type(ESMF_Clock) :: ocnClock
+ type(ESMF_Clock) :: iceClock
+c
+c --- Return codes for error checks
+ integer :: rc
+c
+c --- ICE coupling frequency
+ integer :: ice_nts_cpl,ocn_cpl_day
+c
+c --- Miscellaneous
+ integer :: i,its,its_ocn,its_ice,icpl,iday
+c
+c-------------------------------------------------------------------------------
+c Initialize the ESMF Framework
+c-------------------------------------------------------------------------------
+c
+c --- Set default calendar and log type; get world VM
+ rc = ESMF_Success
+ call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN,
+ & defaultLogType=ESMF_LOG_SINGLE,
+ & vm=worldVM,
+ & rc=rc)
+ if (rc .ne. ESMF_SUCCESS) stop 99
+c
+c --- Get VM info
+ call ESMF_VMGet(worldVM, petCount=petCount, localPET=localPet,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "ESMF_VMGet failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Create section
+c-------------------------------------------------------------------------------
+c
+c --- Create the OCEAN gridded component
+ ocnGridComp = ESMF_GridCompCreate(vm=worldVM,
+ & name="OCEAN Gridded Component",
+ & gridCompType=ESMF_OCEAN,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN GridCompCreate failed", rc))
+ & goto 10
+c
+c --- Create empty OCEAN import/export states
+ ocnImpState = ESMF_StateCreate(stateName="OCEAN Import",
+ & stateType=ESMF_STATE_IMPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN ImpState Create failed", rc))
+ & goto 10
+
+ ocnExpState = ESMF_StateCreate(stateName="OCEAN Export",
+ & stateType=ESMF_STATE_EXPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN ExpState Create failed", rc))
+ & goto 10
+c
+c --- Create the SEAICE gridded component
+ iceGridComp = ESMF_GridCompCreate(vm=worldVM,
+ & name='SEAICE Component',
+ & gridcomptype=ESMF_SEAICE,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE GridCompCreate failed", rc))
+ & goto 10
+c
+c --- Create empty SEAICE import/export states
+ iceImpState = ESMF_StateCreate(stateName="SEAICE Import",
+ & stateType=ESMF_STATE_IMPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE ImpState Create failed", rc))
+ & goto 10
+
+ iceExpState = ESMF_StateCreate(stateName="SEAICE Export",
+ & stateType=ESMF_STATE_EXPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE ExpState Create failed", rc))
+ & goto 10
+c
+c --- Create the OICPL coupler component
+ o2iCplComp = ESMF_CplCompCreate(vm=worldVM,
+ & name="OICPL Coupler Component",
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPLE CplCompCreate failed", rc))
+ & goto 10
+c
+c --- Create empty OICPL import/export states
+ cplImpState = ESMF_StateCreate(stateName="OICPL Import",
+ & stateType=ESMF_STATE_IMPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL ImpState Create failed", rc))
+ & goto 10
+
+ cplExpState = ESMF_StateCreate(stateName="OICPL Export",
+ & stateType=ESMF_STATE_EXPORT,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL ExpState Create failed", rc))
+ & goto 10
+c
+c --- Add OCEAN and SEAICE states to OICPL states
+ CALL ESMF_StateAddState(cplImpState, ocnImpState, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL: Add OCEAN impState failed", rc))
+ & goto 10
+
+ CALL ESMF_StateAddState(cplImpState, iceImpState, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL: Add SEAICE impState failed", rc))
+ & goto 10
+
+ CALL ESMF_StateAddState(cplExpState, ocnExpState, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL: Add OCEAN expState failed", rc))
+ & goto 10
+
+ CALL ESMF_StateAddState(cplExpState, iceExpState, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL: Add SEAICE impState failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Register section
+c-------------------------------------------------------------------------------
+c
+c --- Register the OCEAN gridded component
+ call ESMF_GridCompSetServices(ocnGridComp,
+ & OCN_SetServices, rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN Registration failed", rc))
+ & goto 10
+c
+c --- Register the SEAICE gridded component
+ call ESMF_GridCompSetServices(iceGridComp,
+ & ICE_SetServices, rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE Registration failed", rc))
+ & goto 10
+c
+c --- Register the OICPL coupler component
+ call ESMF_CplCompSetServices(o2iCplComp,
+ & CPL_SetServices,rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL Registration failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Initalize Section
+c-------------------------------------------------------------------------------
+c
+c --- Initialize OCEAN gridded component
+ call ESMF_GridCompInitialize( gridComp=ocnGridComp,
+ & importState=ocnImpState,
+ & exportState=ocnExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN Initialize failed", rc))
+ & goto 10
+*-----c
+*-----c --- Get copy of OCEAN clock
+*----- call ESMF_GridCompGet(ocnGridComp, clock=ocnClock, rc=rc)
+*-----c
+*-----c --- Initialize WORLD clock using OCEAN clock
+*----- worldClock = ESMF_ClockCreate(clock=ocnClock, rc=rc)
+c
+c --- Initialize SEAICE gridded component
+ call ESMF_GridCompInitialize( gridComp=iceGridComp,
+ & importState=iceImpState,
+ & exportState=iceExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE Initialize failed", rc))
+ & goto 10
+c
+ ocn_cpl_day = OCN_nts_day/OCN_nts_cpl
+ ice_nts_cpl = ICE_nts_day/ocn_cpl_day
+ if (localPet.eq.0) then !master
+ write(6,'(a,i5)') 'OCN_nts_day = ',OCN_nts_day
+ write(6,'(a,i5)') 'ICE_nts_day = ',ICE_nts_day
+ write(6,'(a,i5)') 'OCN_nts_cpl = ',OCN_nts_cpl
+ write(6,'(a,i5)') 'ice_nts_cpl = ',ice_nts_cpl
+ endif
+ if (OCN_nts_day.ne.ocn_cpl_day*OCN_nts_cpl) then
+ if (localPet.eq.0) then !master
+ write(6,*) 'ERROR OCN_nts_cpl not a divisor of OCN_nts_day'
+ endif
+ goto 10
+ endif
+ if (ICE_nts_day.ne.ocn_cpl_day*ice_nts_cpl) then
+ if (localPet.eq.0) then !master
+ write(6,*) 'ERROR ice_nts_cpl not a divisor of ICE_nts_day'
+ endif
+ goto 10
+ endif
+c
+c --- Initialize OICPL coupler component
+ call ESMF_CplCompInitialize( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL Initialize failed", rc))
+ & goto 10
+c
+c --- Couple SEAICE to OCEAN
+ call ESMF_CplCompRun( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=CPL_i2o,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL I2O Run failed", rc))
+ & goto 10
+c
+c --- Couple OCEAN to SEAICE
+ call ESMF_CplCompRun( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=CPL_o2i,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL I2O Run failed", rc))
+ & goto 10
+c
+c-------------------------------------------------------------------------------
+c --- Run Section
+c-------------------------------------------------------------------------------
+c
+c --- Run Ocean and SeaIce in lockstep, both looking backwards for imports
+ do icpl=1,huge(iday)/2 !until end of run
+
+c --- OCEAN
+ do its= 1,OCN_nts_cpl !couple period, OCEAN
+ if (mod(its,OCN_nts_cpl).le.1 .and.
+ & localPet.eq.0) then !master
+ write(6,'(a,i4,i4)') ' OCEAN run - icpl,its = ',icpl,its
+ endif
+ OCN_get_import = its.eq.1 !import at start of period
+ OCN_put_export = its.eq.OCN_nts_cpl !export at end of period
+ call ESMF_GridCompRun( gridComp=ocnGridComp,
+ & importState=ocnImpState,
+ & exportState=ocnExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN Run failed", rc))
+ & goto 10
+ enddo !its; OCEAN
+
+c --- SEAICE
+ do its= 1,ice_nts_cpl !couple period, SEAICE
+ if (mod(its,ice_nts_cpl).le.1 .and.
+ & localPet.eq.0) then !master
+ write(6,'(a,i4,i4)') 'SEAICE run - icpl,its = ',icpl,its
+ endif
+ ICE_get_import = its.eq.1 !import at start of period
+ ICE_put_export = its.eq.ice_nts_cpl !export at end of period
+! ICE_put_export = .false. !don't export at end of period
+ call ESMF_GridCompRun( gridComp=iceGridComp,
+ & importState=iceImpState,
+ & exportState=iceExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE Run failed (last half day)", rc))
+ & goto 10
+ enddo !its; SEAICE
+
+c --- use end_of_run, rather than a ESMF Clock
+ if (OCN_end_of_run) then
+ exit !icpl
+ endif !end_of_run
+
+c --- Couple SEAICE to OCEAN
+ call ESMF_CplCompRun( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=CPL_i2o,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL I2O Run failed", rc))
+ & goto 10
+
+c --- Couple OCEAN to SEAICE
+ call ESMF_CplCompRun( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=CPL_o2i,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL I2O Run failed", rc))
+ & goto 10
+
+ enddo !icpl
+c
+ call ESMF_VMBarrier(worldVM)
+c
+c-------------------------------------------------------------------------------
+c Finalize Section
+c-------------------------------------------------------------------------------
+c
+c --- Finalize OCEAN gridded component
+ call ESMF_GridCompFinalize( gridComp=ocnGridComp,
+ & importState=ocnImpState,
+ & exportState=ocnExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OCEAN Finalize failed", rc))
+ & goto 10
+c
+c --- Finalize SEAICE gridded component
+ call ESMF_GridCompFinalize( gridComp=iceGridComp,
+ & importState=iceImpState,
+ & exportState=iceExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_NONBLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "SEAICE Finalize failed", rc))
+ & goto 10
+c
+c --- Finalize OACPL coupler component
+ call ESMF_CplCompFinalize( cplComp=o2iCplComp,
+ & importState=cplImpState,
+ & exportState=cplExpState,
+ & clock=worldClock,
+ & phase=ESMF_SINGLEPHASE,
+ & blockingflag=ESMF_BLOCKING,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "OICPL Finalize failed", rc))
+ & goto 10
+
+c
+10 continue
+ call ESMF_VMBarrier(worldVM)
+ call ESMF_Finalize(rc=rc)
+c
+ stop
+ end program hycom_cice
diff --git a/src_2.2.18_3_one/hycom_gfortran b/src_2.2.18_3_one/hycom_gfortran
new file mode 100755
index 0000000..8bfee85
Binary files /dev/null and b/src_2.2.18_3_one/hycom_gfortran differ
diff --git a/src_2.2.18_3_one/hycom_intel b/src_2.2.18_3_one/hycom_intel
new file mode 100755
index 0000000..d74d9c9
Binary files /dev/null and b/src_2.2.18_3_one/hycom_intel differ
diff --git a/src_2.2.18_3_one/icloan.f b/src_2.2.18_3_one/icloan.f
new file mode 100755
index 0000000..2710a38
--- /dev/null
+++ b/src_2.2.18_3_one/icloan.f
@@ -0,0 +1,273 @@
+ subroutine icloan(m,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- 'energy loan' ice model. no advection, no dynamics. ice amount
+c --- represents energy 'loaned' to water column to prevent wintertime
+c --- cooling below freezing level. loan is paid back in summer.
+c
+c --- modified version for ice-ocean "coupling".
+c --- freeze/melt energy from relaxation to the freezing temperature.
+c --- the atmosphere/ice surface exchange is applied to the ocean
+c --- (previously done in thermf).
+c
+ integer i,j,l
+ real tfrz,tsur,tmxl,smxl,hfrz,paybak,borrow,hice,thkimx,t2f
+ real radfl,tdif,wind,airt,rair,snsibl,emnp,dtrmui
+ real thkimxy(jdm)
+c
+c --- hice = actual ice thickness (m), local variable
+c
+c --- thkice = average ice thickness, i.e. hice x covice (m)
+c --- covice = ice coverage, i.e. cell fraction (0.0 to 1.0)
+c --- temice = ice surface temperature (degC)
+c --- flxice = cell average heat flux under ice (W/m^2)
+c --- fswice = cell average swv flux under ice (W/m^2)
+c --- sflice = cell average salt flux under ice
+c
+c --- icefrq = e-folding time scale back to tfrz (no. time steps)
+c --- thkfrz = maximum thickness of near-surface freezing zone (m)
+c --- tfrz_0 = ice melting point (degC) at S=0psu
+c --- tfrz_s = gradient of ice melting point (degC/psu)
+c --- ticegr = vertical temperature gradient inside ice (deg/m)
+c --- (0.0 to get ice surface temp. from atmos. surtmp)
+c --- hicemn = minimum ice thickness (m)
+c --- hicemx = maximum ice thickness (m)
+c
+ real tfrz_n,ticemn,ticemx,salice,rhoice,fusion,meltmx
+ parameter (tfrz_n= -1.79, ! nominal ice melting point (degC)
+ & ticemn=-50.0, ! minimum ice surface temperature (degC)
+ & ticemx= 0.0, ! maximum ice surface temperature (degC)
+ & salice= 4.0, ! salinity of ice (psu) - same as CICE
+ & rhoice=917.0, ! density of ice (kg/m**3)
+ & fusion=334.e3, ! latent heat of fusion (J/kg)
+ & meltmx= 33.e-7)! max. ice melting rate (m/sec), 0.285 m/day
+c
+ real fluxmx !max. ice melting flux (W/m^2)
+ parameter (fluxmx=meltmx*fusion*rhoice) !~1000 W/m^2 - like CICE
+c
+ real csice,csubp,pairc,rgas,tzero
+ parameter (csice =0.0006, !ice-air sensible exchange coefficient
+ & csubp =1005.7, !specific heat of air (j/kg/deg)
+ & pairc=1013.0*100.0, !air pressure (mb) * 100
+ & rgas =287.1, !gas constant (j/kg/k)
+ & tzero=273.16) !celsius to kelvin temperature offset
+c
+ include 'stmt_fns.h'
+c
+ dtrmui = delt1/(1.0*86400.0) !dt*1/1days
+c
+c --- energy loan: add extra energy to the ocean to keep SST from dropping
+c --- below tfrz in winter. return this borrowed energy to the 'energy bank'
+c --- in summer.
+c
+c --- salt loan: analogous to energy loan.
+c
+ margin = 0 !no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,
+!$OMP& t2f,hfrz,smxl,tmxl,tfrz,borrow,paybak)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ thkimxy(j)=0.0 !simplifies OpenMP parallelization
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c --- relax to tfrz with e-folding time of icefrq time steps
+c --- assuming the effective surface layer thickness is hfrz
+c --- multiply by dpbl(i,j)/hfrz to get the actual e-folding time
+ hfrz = min( thkfrz*onem, dpbl(i,j) )
+ t2f = (spcifh*hfrz)/(baclin*icefrq*g)
+ smxl = saln(i,j,1,n)
+ tmxl = temp(i,j,1,n)
+ tfrz = tfrz_0 + smxl*tfrz_s !salinity dependent freezing point
+ borrow = (tfrz-tmxl)*t2f !W/m^2 into ocean
+c
+c --- limit heat flux range (for both forming and melting ice)
+ borrow=max( -fluxmx, min( fluxmx, borrow ) )
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,'(i9,2i5,a,5f9.3)')
+cdiag& nstep,i+i0,j+j0,' t,tfrz,flx,hfrz,cov:',
+cdiag& tmxl,tfrz,borrow,hfrz*qonem,covice(i,j)
+cdiag endif
+c
+ if (tmxl.lt.tfrz) then
+c
+c --- add energy to move tmxl towards tfrz (only if tmxl < tfrz)
+c
+ thkice(i,j)=thkice(i,j)+borrow*(delt1/(fusion*rhoice))
+ flxice(i,j)= borrow
+ sflice(i,j)= +borrow*(smxl-salice)*(1.0/fusion)
+ elseif (thkice(i,j).gt.0.0) then !tmxl > tfrz
+c
+c --- ice, so return the borrowed amount whenever tmxl > tfrz
+c
+ paybak=min( -borrow, thkice(i,j)*(fusion*rhoice/delt1) )
+ thkice(i,j)=thkice(i,j)-paybak*(delt1/(fusion*rhoice))
+ flxice(i,j)= -paybak
+ sflice(i,j)= -paybak*(smxl-salice)*(1.0/fusion)
+ else !tmxl > tfrz & thkice(i,j) == 0.0
+c
+c --- no ice.
+c
+ flxice(i,j)=0.0
+ sflice(i,j)=0.0
+c
+ if (icmflg.eq.2) then
+c
+c --- add extra cooling under the ice mask (tsur<=tfrz_n)
+c --- don't allow a new tsur maximum, to preserve sea ice
+c
+ if (yrflag.lt.2) then
+ tsur = min( max( surtmp(i,j,l0), surtmp(i,j,l1),
+ & surtmp(i,j,l2), surtmp(i,j,l3) ),
+ & surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1+
+ & surtmp(i,j,l2)*w2+surtmp(i,j,l3)*w3 )
+ else
+ tsur = min( max( surtmp(i,j,l0), surtmp(i,j,l1) ),
+ & surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1 )
+ endif
+ if (tsur.le.tfrz_n) then
+ surflx(i,j)=surflx(i,j)+borrow
+ endif
+ endif !icmflg.eq.2
+ endif
+c
+ util1(i,j)=max(thkice(i,j)-hicemx,0.0) !icex = ice exceeding hicemx
+ thkimxy(j)=max(thkimxy(j),thkice(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ thkimx=maxval(thkimxy(1:jj))
+ call xcmaxr(thkimx)
+c
+c --- spread out portion of ice thicker than hicemx
+ if (thkimx.gt.hicemx) then
+ call psmooth(util1, margin) !smooth icex
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,hice,smxl,tfrz,
+!$OMP& radfl,tdif,wind,airt,rair,snsibl,emnp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thkice(i,j)=util1(i,j)+min(thkice(i,j),hicemx) !icex_sm+rest
+c
+c --- compute fractional ice coverage for energy flux calculation
+ if (thkice(i,j).lt.1.e-5*hicemn) then
+ covice(i,j)=0.0
+ else
+ covice(i,j)=min(1.0,thkice(i,j)*(1.0/hicemn))
+ hice=thkice(i,j)/covice(i,j) !minimum of hicemn
+ end if
+c
+ if (icmflg.eq.3) then
+c --- relax to sea ice concentration from coupler
+c --- ice thickness is therefore always then 0 and hicemn
+ covice(i,j)=covice(i,j)+dtrmui*(si_c(i,j)-covice(i,j))
+ thkice(i,j)=covice(i,j)*hicemn
+ hice=hicemn
+ endif
+c
+c --- compute ice surface temperature
+ if (covice(i,j).eq.0.0) then
+ temice(i,j)=ticemx
+ elseif (ticegr.eq.0.0) then !use surtmp
+ temice(i,j)=max( ticemn,
+ & min( ticemx,
+ & surtmp(i,j,l0)*w0+
+ & surtmp(i,j,l1)*w1+
+ & surtmp(i,j,l2)*w2+
+ & surtmp(i,j,l3)*w3 ) )
+ else
+ temice(i,j)=max( ticemn, ticemx-ticegr*hice )
+ endif
+c
+ if (icmflg.eq.3) then
+ if (min(covice(i,j),si_c(i,j)).gt.0.0) then
+ temice(i,j)=max( ticemn, min( ticemx, si_t(i,j) ) )
+ endif
+ endif
+c
+c --- atmosphere to ice surface exchange, applied to the ocean.
+c
+ if (covice(i,j).gt.0.0) then
+c --- net radiative thermal flux (w/m**2) +ve into ocean/ice
+c --- radflx's Qsw includes the atmos. model's surface albedo,
+c --- i.e. it already allows for ice&snow where it is observed.
+ radfl=radflx(i,j,l0)*w0+radflx(i,j,l1)*w1
+ & +radflx(i,j,l2)*w2+radflx(i,j,l3)*w3
+ if (lwflag.gt.1) then
+c --- longwave correction to radfl (Qsw+Qlw).
+c --- this will be ~zero for ticegr==0.0 (temice=surtmp)
+ tdif = temice(i,j) -
+ & ( surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1
+ & +surtmp(i,j,l2)*w2+surtmp(i,j,l3)*w3)
+ !correction is blackbody radiation from tdif at temice
+ radfl = radfl - (4.506+0.0554*temice(i,j)) * tdif
+ endif
+ if (flxflg.ne.3) then
+c --- wind speed (m/s)
+ wind=wndspd(i,j,l0)*w0+wndspd(i,j,l1)*w1
+ & +wndspd(i,j,l2)*w2+wndspd(i,j,l3)*w3
+c --- air temperature (C)
+ airt=airtmp(i,j,l0)*w0+airtmp(i,j,l1)*w1
+ & +airtmp(i,j,l2)*w2+airtmp(i,j,l3)*w3
+ rair = pairc/(rgas*(tzero+airt))
+ snsibl = csubp*rair*wind*csice*(temice(i,j)-airt)
+ else
+ snsibl = 0.0 !already in total flux (i.e. in radfl)
+ endif
+ flxice(i,j) = flxice(i,j) +
+ & covice(i,j)*(radfl - snsibl) !no evap
+c
+c --- add a time-invarient net heat flux offset
+ if (flxoff) then
+ flxice(i,j) = flxice(i,j) + covice(i,j)*offlux(i,j)
+ endif
+c
+c --- emnp = evaporation minus precipitation (m/sec) into atmos.
+c --- no evap (sublimation) over ice, all precip enters ocean
+ if (pcipf) then
+ emnp = -( precip(i,j,l0)*w0+precip(i,j,l1)*w1
+ & +precip(i,j,l2)*w2+precip(i,j,l3)*w3)
+ else
+ emnp = 0.0
+ endif
+ if (priver) then
+ emnp = emnp - ( rivers(i,j,lr0)*wr0+rivers(i,j,lr1)*wr1
+ & +rivers(i,j,lr2)*wr2+rivers(i,j,lr3)*wr3)
+ endif
+c --- sflice = salt flux (10**-3 kg/m**2/sec) into ocean under ice
+ sflice(i,j) = sflice(i,j) +
+ & covice(i,j)*emnp*(saln(i,j,1,n)*qthref)
+ endif !covice
+c
+ fswice(i,j) = 0.0 !no penetrating Qsw under ice
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ return
+ end subroutine icloan
+c
+c
+c> Revision history
+c>
+c> June 2000 - conversion to SI units
+c> July 2000 - switched sign convention for vertical fluxes (now >0 if down)
+c> May 2003 - added option to impose an ice mask
+c> June 2003 - added 8 time step e-folding time scale
+c> June 2003 - limited rate of ice formation
+c> June 2003 - replaced constant saldif with smxl-salice
+c> Mar. 2005 - freezing point linearly dependent on salinity
+c> Mar. 2005 - ice surface temperature optionally from surtmp
+c> Jun. 2006 - modified version for ice-ocean "coupling"
diff --git a/src_2.2.18_3_one/inicon.f b/src_2.2.18_3_one/inicon.f
new file mode 100755
index 0000000..c94a24c
--- /dev/null
+++ b/src_2.2.18_3_one/inicon.f
@@ -0,0 +1,533 @@
+ subroutine inicon(mnth)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer mnth
+c
+c --- ------------------------------------------------------
+c --- initializatize all fields (except tracers, see initrc)
+c --- ------------------------------------------------------
+c
+ logical lpipe_inicon
+ parameter (lpipe_inicon=.false.)
+c
+ real pinit,pk1p5,pmin(0:kdm),realat,cenlat,tempk
+ integer i,j,k,k1,kkap,l,m,n
+cdiag character text*24
+ character ptxt*12,utxt*12,vtxt*12
+c
+ real poflat,roflat
+ external poflat,roflat
+c
+ include 'stmt_fns.h'
+c
+ if (iniflg.eq.3) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in inicon - invalid iniflg value'
+ write(lp,*) 'iniflg = ',iniflg
+ write(lp,*) 'use restart/src/restart_archv to convert'
+ write(lp,*) ' an archive to a restart file (off-line).'
+ write(lp,*) 'then rerun with this as restart_in, and with'
+ write(lp,*) ' a positive initial value in limits'
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(inicon)')
+ stop '(inicon)'
+ elseif (iniflg.lt.0 .or. iniflg.gt.3) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in inicon - invalid iniflg value'
+ write(lp,*) 'iniflg = ',iniflg
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(inicon)')
+ stop '(inicon)'
+ endif
+c
+ margin = 0
+c
+ if (iniflg.eq.2) then
+ call rdrlax(mnth,1)
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ if (k.eq.1 .or. k.le.nhybrd) then
+ temp(i,j,k,1)=twall(i,j,k,1)
+ saln(i,j,k,1)=swall(i,j,k,1)
+ th3d(i,j,k,1)=sig(temp(i,j,k,1),saln(i,j,k,1))-thbase
+ else ! isopyc
+ temp(i,j,k,1)=tofsig(theta(i,j,k)+thbase,
+ + swall(i,j,k,1))
+ saln(i,j,k,1)=swall(i,j,k,1)
+ th3d(i,j,k,1)=theta(i,j,k)
+ endif
+c
+ temp(i,j,k,2)=temp(i,j,k,1)
+ saln(i,j,k,2)=saln(i,j,k,1)
+ th3d(i,j,k,2)=th3d(i,j,k,1)
+ enddo
+ enddo
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,tempk)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do k=1,kk
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ tempk=tofsig(theta(i,j,k)+thbase,saln0)
+c
+ temp(i,j,k,1)=tempk
+ saln(i,j,k,1)=saln0
+ th3d(i,j,k,1)=theta(i,j,k)
+c
+ temp(i,j,k,2)=tempk
+ saln(i,j,k,2)=saln0
+ th3d(i,j,k,2)=theta(i,j,k)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+c
+ if (lpipe .and. lpipe_inicon) then
+ do k= 1,kk
+ write (ptxt,'(a9,i3)') 'temp.1 k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'temp.2 k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'saln.1 k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'saln.2 k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'th3d.1 k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'th3d.2 k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ enddo
+ endif
+c
+ if (mnproc.eq.1) then
+ write (lp,'('' sigma(k):'',9f7.2/(15x,9f7.2))')
+ & (sigma(k),k=1,kk)
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ i = (itdm+1)/2
+ j = (jtdm+1)/2
+ call xceget(cenlat, plat, i,j)
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,pmin,realat,pinit)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 54 j=1-margin,jj+margin
+ do 54 l=1,isp(j)
+ do 54 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j, 1)=0.0
+ p(i,j,kk+1)=depths(i,j)*onem
+c
+ pmin(0)=0.0
+ do 55 k=1,kk
+ if (k.le.nhybrd) then
+ pmin(k)=pmin(k-1)+min(dp0k(k),max(ds0k(k),
+ & dssk(k)*depths(i,j)))
+ else ! isopyc
+ pmin(k)=pmin(k-1)
+ endif
+c
+ if (mxlmy) then
+ q2( i,j,k,1)=smll
+ q2l( i,j,k,2)=smll
+ vctymy(i,j,k )=difmiw
+ difqmy(i,j,k )=difsiw
+ diftmy(i,j,k )=difsiw
+ if (k.eq.kk) then
+ q2( i,j,0 ,1)=smll
+ q2l( i,j,0 ,2)=smll
+ q2( i,j,k+1,1)=smll
+ q2l( i,j,k+1,2)=smll
+ vctymy(i,j,0 )=difmiw
+ difqmy(i,j,0 )=difsiw
+ diftmy(i,j,0 )=difsiw
+ vctymy(i,j,k+1 )=difmiw
+ difqmy(i,j,k+1 )=difsiw
+ diftmy(i,j,k+1 )=difsiw
+ endif
+ endif !mxlmy
+c
+ if (iniflg.le.1) then
+c
+c initial interfaces from zonal mean climatology.
+c
+ if (k.lt.kk) then
+ if (iniflg.eq.0) then
+c
+c --- initial interfaces are flat,
+c --- based on zonal mean climatology at center of the basin.
+c
+ realat=cenlat
+ else ! iniflg==1
+ if (mapflg.ne.4) then
+ realat=plat(i,j)
+ else
+ realat=cenlat
+ endif
+ endif
+ pinit=poflat(.5*(sigma(k)+sigma(k+1)),realat)
+c
+ if (i.eq.itest .and. j.eq.jtest) then
+ write (lp,'(a,i3,2f12.3,2f10.3)')
+ & 'k,pmin,poflat,sigma,realat = ',
+ & k,pmin(k)*qonem,
+ & pinit*qonem,.5*(sigma(k)+sigma(k+1)),realat
+ call flush(lp)
+ endif
+c
+ else ! k==kk
+ pinit=huge
+ endif
+ p(i,j,k+1)=max(pmin(k),pinit)
+ if (k.gt.2 .and.
+ & k.le.nhybrd+1 .and.
+ & p(i,j,k).le.pmin(k-1) .and.
+ & (k.eq.kk .or. p(i,j,k+1).gt.pmin(k))) then
+ do k1=1,k
+ pk1p5 = 0.5*(min(p(i,j,k1) ,depths(i,j)*onem)+
+ & min(p(i,j,k1+1),depths(i,j)*onem) )
+ th3d(i,j,k1,1)=roflat(pk1p5,realat) -thbase
+ temp(i,j,k1,1)=tofsig(th3d(i,j,k1,1)+thbase,saln0)
+ saln(i,j,k1,1)=saln0
+c
+ th3d(i,j,k1,2)=th3d(i,j,k1,1)
+ temp(i,j,k1,2)=temp(i,j,k1,1)
+ saln(i,j,k1,2)=saln(i,j,k1,1)
+c
+ if (kapref.eq.0) then !not thermobaric
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)
+ elseif (kapref.gt.0) then
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & kapref)
+ else !variable kapref
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & 2)
+ thstar(i,j,k1,2)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & kapi(i,j))
+ endif
+c
+ if (i.eq.itest .and. j.eq.jtest) then
+ write (lp,'(a,i3,4f12.3)')
+ & 'k,pk+.5,roflat,realat = ',
+ & k1,pk1p5*qonem,
+ & th3d(i,j,k1,1)+thbase,temp(i,j,k1,1),realat
+ call flush(lp)
+ endif
+ end do
+ end if
+ if (k.eq.kk) then
+ do k1=1,kk
+ p( i,j,k1+1)=min(p(i,j,k1+1),depths(i,j)*onem)
+ dp(i,j,k1,1)= p(i,j,k1+1)-p(i,j,k1)
+ dp(i,j,k1,2)= dp(i,j,k1,1)
+ if (kapref.eq.0) then !not thermobaric
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)
+ elseif (kapref.gt.0) then
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & kapref)
+ else !variable kapref
+ thstar(i,j,k1,1)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & 2)
+ thstar(i,j,k1,2)=th3d(i,j,k1,1)+kappaf(temp(i,j,k1,1),
+ & saln(i,j,k1,1),
+ & thbase+th3d(i,j,k1,1),
+ & p(i,j,k1),
+ & kapi(i,j))
+ endif
+ enddo
+ endif
+ elseif (iniflg.eq.2) then
+c
+c initial interfaces from relaxation fields.
+c
+ if (k.lt.kk) then
+ p(i,j,k+1) = pwall(i,j,k+1,1)
+ else
+ p(i,j,k+1) = depths(i,j)*onem
+ endif
+ dp(i,j,k,1) = p(i,j,k+1)-p(i,j,k)
+ dp(i,j,k,2) = dp(i,j,k,1)
+ if (kapref.eq.0) then !not thermobaric
+ thstar(i,j,k,1)=th3d(i,j,k,1)
+ elseif (kapref.gt.0) then
+ thstar(i,j,k,1)=th3d(i,j,k,1)+kappaf(temp(i,j,k,1),
+ & saln(i,j,k,1),
+ & thbase+th3d(i,j,k,1),
+ & p(i,j,k),
+ & kapref)
+ else !variable kapref
+ thstar(i,j,k,1)=th3d(i,j,k,1)+kappaf(temp(i,j,k,1),
+ & saln(i,j,k,1),
+ & thbase+th3d(i,j,k,1),
+ & p(i,j,k),
+ & 2)
+ thstar(i,j,k,2)=th3d(i,j,k,1)+kappaf(temp(i,j,k,1),
+ & saln(i,j,k,1),
+ & thbase+th3d(i,j,k,1),
+ & p(i,j,k),
+ & kapi(i,j))
+ endif
+ endif
+c
+cdiag if (mod(k,3).ne.1) go to 55
+cdiag write (text,'(''intf.pressure (m), k='',i3)') k+1
+cdiag call prtmsk(ip,p(1-nbdy,1-nbdy,k+1),util1,idm,ii,jj,0.,1.*qonem,text)
+c
+ 55 continue
+c
+ if (isopyc) then
+c
+c --- MICOM-like mixed layer no thinner than thkmin.
+c
+ p( i,j,2) =max(p(i,j,2),min(depths(i,j),thkmin)*onem)
+ dp(i,j,1,1)=p(i,j,2)-p(i,j,1)
+ dp(i,j,1,2)=dp(i,j,1,1)
+ do k=2,kk
+ p( i,j,k+1)=max(p(i,j,k+1),p(i,j,k))
+ dp(i,j,k,1)= p(i,j,k+1)-p(i,j,k)
+ dp(i,j,k,2)=dp(i,j,k,1)
+ enddo
+ endif
+ 54 continue
+!$OMP END PARALLEL DO
+c
+ if (iniflg.eq.0) then
+ do k= 1,kk
+ tempk = 0.0
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1 .and.
+ & abs(th3d(i,j,k,1)-th3d(ii/2,jj/2,k,1)).gt.
+ & abs(tempk)) then
+ write(6,*) 'inicon: i,j,k,th3d = ',
+ & i,j,k,th3d(i,j,k,1),th3d(ii/2,jj/2,k,1),
+ & th3d(i,j,k,1)-th3d(ii/2,jj/2,k,1)
+ tempk = th3d(i,j,k,1)-th3d(ii/2,jj/2,k,1)
+ endif
+ enddo
+ enddo
+ if (tempk.eq.0.0) then
+ write(6,*) 'inicon: constant layer k = ',k
+ else
+ write(6,*) 'inicon: variable layer k = ',k
+ endif
+ enddo
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 50 j=1-margin,jj+margin
+ do 51 l=1,isp(j)
+ do 51 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pbavg(i,j,1)=0.
+ pbavg(i,j,2)=0.
+ pbavg(i,j,3)=0.
+ pbot(i,j)=p(i,j,kk+1)
+c
+ klist(i,j)=kk !for MY2.5 mixed layer
+c
+ steric(i,j)=0.0
+ srfhgt(i,j)=0.0
+ montg1(i,j)=0.0
+c
+ do kkap= 1,kapnum
+ montg(i,j,1,kkap)=0.0
+ do k=1,kk-1
+ montg(i,j,k+1,kkap)=montg(i,j,k,kkap)-
+ & p(i,j,k+1)*(thstar(i,j,k+1,kkap)-thstar(i,j,k,kkap))*thref**2
+ enddo
+c
+ thkk( i,j,kkap)=thstar(i,j,kk,kkap)
+ psikk(i,j,kkap)=montg( i,j,kk,kkap)
+ enddo !kkap
+c
+c --- start with a thin mixed layer
+ if (hybrid) then
+ dpmixl(i,j,1)=min(depths(i,j)*onem-onem,
+ & max(thkmin*onem,p(i,j,2)))
+ else ! isopyc
+ dpmixl(i,j,1)=p(i,j,2)
+ endif
+ dpmixl(i,j,2)=dpmixl(i,j,1)
+ dpbl( i,j) =dpmixl(i,j,1)
+ dpbbl( i,j) =thkbot*onem
+c
+ temice(i,j) = temp(i,j,1,1)
+ covice(i,j) = 0.0
+ thkice(i,j) = 0.0
+ 51 continue
+ do i=1-margin,ii+margin
+ do k= 1,3
+ ubavg(i,j,k) = 0.0
+ vbavg(i,j,k) = 0.0
+ enddo
+ do k= 1,kk
+ u(i,j,k,1) = 0.0
+ u(i,j,k,2) = 0.0
+ v(i,j,k,1) = 0.0
+ v(i,j,k,2) = 0.0
+ enddo
+ enddo
+ 50 continue
+!$OMP END PARALLEL DO
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ write (lp,103) nstep,i0+itest,j0+jtest,
+ & ' istate: temp saln thstar thkns dpth montg',
+ & dpmixl(itest,jtest,1)*qonem,
+ & (k,temp(itest,jtest,k,1),saln(itest,jtest,k,1),
+ & thstar(itest,jtest,k,1)+thbase,dp(itest,jtest,k,1)*qonem,
+ & (p(itest,jtest,k+1)+p(itest,jtest,k))*0.5*qonem,
+ & montg(itest,jtest,k,1)/g,k=1,kk)
+ write(lp,104) depths(itest,jtest)
+ endif !test tile
+ call xcsync(flush_lp)
+c
+ if (lpipe .and. lpipe_inicon) then
+ do k= 1,kk
+ write (ptxt,'(a9,i3)') 'th3d.1 k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'th3d.2 k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'thstar k=',k
+ call pipe_compare_sym1(thstar(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'saln.1 k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'saln.2 k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'temp.1 k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'temp.2 k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') ' dp.1 k=',k
+ call pipe_compare_sym1( dp(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') ' dp.2 k=',k
+ call pipe_compare_sym1( dp(1-nbdy,1-nbdy,k,2),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'montg k=',k
+ call pipe_compare_sym1(montg(1-nbdy,1-nbdy,k,1),ip,ptxt)
+ enddo
+ write (ptxt,'(a9,i3)') 'thkk k=',kk
+ call pipe_compare_sym1(thkk( 1-nbdy,1-nbdy,1),ip,ptxt)
+ write (ptxt,'(a9,i3)') 'psikk k=',kk
+ call pipe_compare_sym1(psikk(1-nbdy,1-nbdy,1),ip,ptxt)
+ endif
+c
+ if(mxlkrt) then
+!$OMP PARALLEL DO PRIVATE(j,l,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ if(dpmixl(i,j,1).gt.p(i,j,k ) .and.
+ & dpmixl(i,j,1).le.p(i,j,k+1)) then
+ t1sav(i,j,1)=temp(i,j,k,1)
+ s1sav(i,j,1)=saln(i,j,k,1)
+ tmlb( i,j,1)=temp(i,j,k,1)
+ smlb( i,j,1)=saln(i,j,k,1)
+ nmlb( i,j,1)=k
+ t1sav(i,j,2)=t1sav(i,j,1)
+ s1sav(i,j,2)=s1sav(i,j,1)
+ tmlb( i,j,2)=tmlb(i,j,1)
+ smlb( i,j,2)=smlb(i,j,1)
+ nmlb( i,j,2)=k
+ end if
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ end if
+c
+ if (hybrid) then
+ m=2
+ n=1
+ call pipe_comparall(m,n, 'inicon, step')
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, margin) ! p's halo extended by dpudpv
+ if (lpipe) then
+ do k= 1,kk
+ write (utxt,'(a9,i3)') 'dpu k=',k
+ write (vtxt,'(a9,i3)') 'dpv k=',k
+ call pipe_compare_sym2(dpu(1-nbdy,1-nbdy,1,n),iu,utxt,
+ & dpv(1-nbdy,1-nbdy,1,n),iv,vtxt)
+ enddo
+ endif
+ call hybgen(m,n)
+ call pipe_comparall(m,n, 'inicn1, step')
+ m=1
+ n=2
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, margin) ! p's halo extended by dpudpv
+ if (lpipe) then
+ do k= 1,kk
+ write (utxt,'(a9,i3)') 'dpu k=',k
+ write (vtxt,'(a9,i3)') 'dpv k=',k
+ call pipe_compare_sym2(dpu(1-nbdy,1-nbdy,1,n),iu,utxt,
+ & dpv(1-nbdy,1-nbdy,1,n),iv,vtxt)
+ enddo
+ endif
+ call hybgen(m,n)
+ call pipe_comparall(m,n, 'inicn2, step')
+ endif
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ write (lp,103) nstep,i0+itest,j0+jtest,
+ & ' istate: temp saln thstar thkns dpth montg',
+ & dpmixl(itest,jtest,1)*qonem,
+ & (k,temp(itest,jtest,k,1),saln(itest,jtest,k,1),
+ & thstar(itest,jtest,k,1)+thbase,dp(itest,jtest,k,1)*qonem,
+ & (p(itest,jtest,k+1)+p(itest,jtest,k))*0.5*qonem,
+ & montg(itest,jtest,k,1)/g,k=1,kk)
+ write(lp,104) depths(itest,jtest)
+ 103 format (i9,2i5,a/23x,'mxl',32x, f8.1/
+ & (23x,i3,2f8.2,f8.2,2f8.1,f8.3))
+ 104 format ( 23x,'bot',32x, f8.1)
+ endif !test tile
+ call xcsync(flush_lp)
+c
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> Nov. 1999 - added code to initialize homogeneous values of thermodynamical
+c> variables near the surface
+c> May 2000 - conversion to SI units
+c> Aug. 2000 - added hybrid and isopycnic vertical coordinate options
+c> Mar 2009 - more accurate kappaf, with potential density
diff --git a/src_2.2.18_3_one/inigiss.f b/src_2.2.18_3_one/inigiss.f
new file mode 100755
index 0000000..184a75c
--- /dev/null
+++ b/src_2.2.18_3_one/inigiss.f
@@ -0,0 +1,1394 @@
+ subroutine inigiss
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c -----------------------------------------------
+c --- initialize nasa-giss vertical mixing scheme
+c -----------------------------------------------
+c
+ integer i,j,k
+c
+ real slq2b_00,smb_00,shb_00,ssb_00,c_y0,c_y00,deltanum,
+ & deltaden,delta,rrcrn,rrcrp,theta_rcrn_deg,theta_rcrp_deg,
+ & delra_r,theta_r_deg,theta_r,sm_r0,sh_r0,ss_r0,ra_r,ra_r1,
+ & rit,ric,ri_r,rid_r,sm_r,sh_r,ss_r,smosloq_r,rit1,ric1,
+ & ri_r1,rid_r1,slq2_r,smosloq_0r,ra_r0,rit0,ric0,ri_r0,rid_r0,
+ & slq2_r0,c_y001,sisa1
+c
+ integer iridsign,iridstep,irid,iri,mt0s,mtm1s,idfs,idif,irisign,
+ & iristep,itheta_r,jtheta_r,isailback,idifs,ira_r,ibg,
+ & ipenra_r
+c
+ real acosh1,xx
+ include 'stmt_fns.h'
+ acosh1(xx) = log(xx+sqrt((xx**2)-1.0))
+c
+c --- initialize viscosity and diffusivity arrays
+ do j=1,jdm
+ do i=1,idm
+ do k=1,kdm+1
+ vcty(i,j,k)=difmiw
+ dift(i,j,k)=difsiw
+ difs(i,j,k)=difsiw
+c --- no nonlocal forcing
+ ghats(i,j,k)=0.0
+ enddo
+ enddo
+ enddo
+c
+c --- dimensions for the tables in mxgiss routine
+c --- the file is needed in order to preserve in the
+c --- arrays for the Ri-tables
+c
+ pidbl=3.14159265358979312
+ ntbl=251
+ nextrtbl0=62
+ ifexpabstable=1
+ nextrtbl1=500
+ nextrtbl=nextrtbl0+ifexpabstable*nextrtbl1
+ nposapprox=51
+ mt0=ntbl-nposapprox
+ mt=mt0+nextrtbl ! table dimensions
+ mt_ra_r=nposapprox-1
+ n_theta_r_oct=(((pidbl/4.)*mt_ra_r)/15.)*15
+ deltheta_r=(pidbl/4.)/(n_theta_r_oct)
+c
+c --- set other parameters
+c
+ ri0=- 4.0 !C parameter(ri0=-20.D0)
+ ebase=2.71828182845904509
+ ifback=5 !Temperature=Salt diffusivity model background
+ !model swith.
+ ! K_H,K_S (S=N/sqrt(Ri)),Ri=backfrac*Ri_Cr)
+ ifsali=1 !Salinity model switch (Canuto's)
+ ifepson2=2 !Background (epsilon/N^2) dimensionalization
+ !of diffusivities switch.
+ ! cnst blw highst lvl frgr dies
+ epson2_ref=.288 !reference value of dissipation/N**2
+ !Value of (epsilon/N^2)/(1 cm/sec^2) used.
+ !See Canuto et al. JPO 2002 Sections 8&9.
+ !040126 Actual (epsilon/N^2) can vary with z,N and f .
+ eps_bot0=2.e-5 !The value of epsilon at the bottom in cgs,
+ !St.Laurent et al. JPO2001 give epsilon = 3to9e-9 W/kg
+ !for slopes and 2to5e-9 W/kg for crests and canyons.
+ scale_bot=5.e-4 !The scale (in cm) of exponential decrease of mixing
+ !above the bottom with height. St. Laurent et al. give
+ !150+-50 m for slopes, 500+-100 m for crests and canyons.
+ eplatidepmin=7.E-2 !Gregg et al. admit their formula eq.(2) for the
+ !latitude dependent factor L which scales turbulence
+ !won't work at the equator where it predicts epsilon=0.
+ !Introduce eplatidepmin, a minimum on the factor L .
+ wave_30=(pi/43082.0)*acosh1(5.24e-3/(pi/43082.0))
+ !reference value at 30degN with N=5.24e-3
+ !from Garerett and Munk, as used by Gregg et. al.
+ ifrafgmax=1 !Switch for limiting BackGround ra_r
+ !to at most Foreground ra_r when Ri>0
+ !for R_r in the [R_r_crit_DoubleDiffusion,
+ !R_r_crit_SaltFingers] regime.
+ ifsalback=5 !Salinity background modification switch.
+ !int.wvS=N/(Ri_i^(1/2)),Ri_icnst,
+ ! ra_r_i=cnst*ra_r_crit.(theta_r)
+ ifchengcon=0 !old ocean cnsts,near-surf prof assump
+ ifpolartablewrite=0 !Switch to write out polar 2D
+ !turbulence table .
+ ifbg_theta_interp=1 !Introduce flag for use of \theta_r
+ !arrays to interpolate background.
+ !Intrplt 2D array
+ !(slq2_r1=array for (Sl/q)^2)
+ !with (Ri,Ri_d)indices
+ back_ph_0=(6.e-5)*(1.e2/(2.e0*pidbl))
+ !for ifsalback=3 case.
+ !Gargett et. al. JPO Vol.11 p.1258-71 gives
+ !for "the deep record",
+ !\phi_0=6\times10^{-5}s^{-2}cpm^{-1}.
+ !"cpm" is 'cycles per meter'.
+ !\phi_0=6\times10^{-5}s^{-2}(2 pidbl/100)^{-1}cm
+ adjust_gargett=1.0 !Gargett et. al. favor the value,
+ !k_0 = 0.1 cpm. But k_0=0.05-0.2 cpm
+ !might be viable, see section 5 of their
+ !paper. Take k_0 = 0.1 cpm * adjust_gargett,
+ !where adjust_gargett is adjustable.
+ !Convert to radians per cm:
+ !k_0 = 0.1 (2pi/100cm) * adjust_gargett.
+ !used for ifsalback=4 case also, but set
+ !adjust_gargett=1 for ifsalback=4
+ back_k_0=(0.1)*(2.0)*pidbl*(1.e-2)*adjust_gargett
+ !Introduce the lengthscale
+ !\Delta_0 \equiv pi/k_0 .
+ !The units of \Delta_0 are centimeters,
+ !with k_0 in radians per cm.
+ !`min turb' wvnmbr (cm^-1)
+ back_del_0=pidbl/back_k_0
+ back_s2=1.e-14 !back_s2 should be smaller than any normal Shear^2
+ back_sm2=1.0/back_s2 !1/back_s2 (sec^2)
+ ri_internal=1.0 !Parameter for ifsalback=4 case.
+ backfrac = 85.e-2 !Parameter for ifback or ifsalback=5 case.
+ !ifback=5: =cnst frac{Ri_cr};
+ !ifsalback=5:=cnst frac{ra_r_crit.(\theta_r)}
+ backfact = ebase**(-1) !Parameter for ifsalback=6 case.
+ ako = 1.6 ! Kolmogorov's constant
+c
+ tpvot0 = 0.4 ! \tau_pv = {2 \over 5} \tau (B.1)
+ ! "tpv/tau" = 2/5
+ ! From the printed notes Canuto
+ ! gave Armando on 980601 have:
+ sgmt=0.72 !Make "sgmt" a parameter.
+ !Standard value was 0.72.
+ tptot0=(1.0/5.0)*(1.0/(1.0+(1.0/sgmt)))
+ ! \tau_p\theta over \tau
+ tpcot0=tptot0 !tau_pc over \tau
+ ttot0=sgmt !tau_\theta over \tau
+ tcot0=ttot0 !tau_c over \tau
+ tctot0=1.0/3.0 ! tau_c\theta } over \tau
+ tpvot = tpvot0
+ tptot = tptot0
+ tpcot = tpcot0
+ ttot = ttot0
+ tcot = tcot0
+ tctot = tctot0
+c
+ if (mnproc.eq.1) then
+ write(lp,900)
+ 900 format('nasa-giss mixed layer model selected'/
+ & 'turbulence calculated by 040128 hycom version'/
+ & 'stripped down from 030803 turb_2gi1a ncar')
+ endif !1st proc
+c
+c --- START OF SALINITY MODEL BACKGROUND LENGTHSCALE CALCULATION SECTION.
+c --- ifsali.eq. 1 therefore:
+c --- Calculate constant lengthscale for
+c --- the background for ifsalback=3,4,5
+c --- \Delta_0 ={B_1 pi \over (3 Ko)^{3/2}} l_0
+c --- l_0 = {(3 Ko)^{3/2} \over B_1 pi} \Delta_0
+c --- "back_l_0" is the constant background
+c --- l_0 in centimeters.
+c
+c --- pass back B_1 from oursal2.
+ call oursal2_1a(0.,0.,slq2b_00,smb_00,shb_00,ssb_00,
+ & c_y0,c_y00,0,0)
+c
+ back_l_0 = (((3.*ako)**(3./2.))/(b1*pi))*back_del_0
+c
+ if (mnproc.eq.1) then
+ write(lp,*) "Dubovikov Internal wave constants for background."
+ write(lp,*) "Ratio of Background to Critical ra_r"//
+ & " [\\equiv ({Ri_T}^2 + {Ri_C}^2)^(1/2)]",backfrac
+ write(lp,*) "Lengthscale, del_0/(cm) =",back_del_0
+ write(lp,*) "Lengthscale, l_0/(cm) =",back_l_0
+ call flush(lp)
+ endif !1st proc
+c
+c --- Set step-size for *both* dimensions of 2D table here.
+c --- ifsali.eq. 1
+ dri = -ri0/float(mt0)
+c
+c --- BUILD SALINITY MODEL TABLES VS. "Ri = Ri_T + Ri_C" AND "Ri_d = Ri_T - Ri_C".
+c --- Use separate loops for calculation of independent table variables.
+c
+ do iridsign=0,1
+ iridstep=(-1)**iridsign
+ do irid= 0,mt*iridstep,iridstep
+c --- Set Ri_d table values. (See NBP59,63=p#A27,30.)
+ if(abs(irid).le.mt0) then
+ ridb(irid) = float(irid)*dri
+ else
+ mt0s = mt0*iridstep
+ mtm1s = (mt0-1)*iridstep
+c --- introduction of exponential absolute val table option.
+ if(ifexpabstable.eq. 0) then
+ idifs = (abs(irid)-mt0)*iridstep
+ ridb(irid) = ridb(mt0s)*((ridb(mt0s)/
+ & ridb(mtm1s))**(idifs**2))
+ else if(ifexpabstable.eq. 1) then
+ idif = abs(irid)-mt0
+ ridb(irid) = ridb(mt0s)*((ridb(mt0s)/
+ & ridb(mtm1s))**(idif))
+ endif
+ endif
+c
+ enddo
+ enddo
+c
+ do irisign=0,1
+ iristep=(-1)**irisign
+ do iri= 0,mt*iristep,iristep
+c --- Set Ri table values. (See NBP59,63=p#A27,30.)
+ if(abs(iri).le.mt0) then
+ ribtbl(iri) = float(iri)*dri
+ else
+ mt0s = mt0*iristep
+ mtm1s = (mt0-1)*iristep
+c --- introduction of exponential absolute val table option.
+ if(ifexpabstable.eq. 0) then
+ idifs = (abs(iri)-mt0)*iristep
+ ribtbl(iri) = ribtbl(mt0s)*((ribtbl(mt0s)/
+ & ribtbl(mtm1s))**(idifs**2))
+ else if(ifexpabstable.eq. 1) then
+ idif = abs(iri)-mt0
+ ribtbl(iri) = ribtbl(mt0s)*((ribtbl(mt0s)/
+ & ribtbl(mtm1s))**(idif))
+ endif
+ endif
+c
+ enddo
+ enddo
+c
+c --- If using interp2d_expabs introduce ratio between adjacent Richardson
+c --- numbers in nonlinear part of table.***
+ rri = ribtbl(mt0)/ribtbl(mt0-1)
+c
+ do iridsign=0,1
+ iridstep=(-1)**iridsign
+ do irid= 0,mt*iridstep,iridstep
+ do irisign=0,1
+ iristep=(-1)**irisign
+ do iri= 0,mt*iristep,iristep
+c --- Need to pass back the value of B_1 from oursal2 for use here.
+ call oursal2_1a(ribtbl(iri),ridb(irid),slq2b(iri,irid),
+ & smb(iri,irid),shb(iri,irid),ssb(iri,irid),
+ & c_y0,c_y00,iri,irid)
+ if(slq2b(iri,irid).lt.0) then
+ irimax(irid) = iri - 1
+ go to 15
+ endif
+ enddo
+ 15 continue
+ enddo
+c
+ enddo
+ enddo
+c
+c --- Add writes in salinity model case.
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,*) "************************************************"
+cdiag write(lp,*) "New Temperature-Salinity Model"
+cdiag write(lp,*) "ifsali=",ifsali
+cdiag write(lp,*) "ifsalback=",ifsalback
+c
+cdiag write(lp,*) "ifepson2=",ifepson2
+cdiag if(ifepson2.GT.0) then
+cdiag write(lp,*) "epson2_ref=",epson2_ref
+cdiag WRITE(lp,*) "ifdeeplat=",ifdeeplat
+cdiag IF(ifdeeplat.GT.0) THEN
+cdiag WRITE(*,*) "eplatidepmin=",eplatidepmin
+cdiag END IF
+cdiag WRITE(*,*) "ifbotenhance=",ifbotenhance
+cdiag IF(ifbotenhance.EQ.1) THEN
+cdiag WRITE(*,*) "eps_bot0=",eps_bot0
+cdiag WRITE(*,*) "scale_bot=",scale_bot
+cdiag END IF
+cdiag END IF
+C*****CD
+c
+cdiag write(lp,*)"ifrafgmax=",ifrafgmax
+cdiag write(lp,*)"ifbg_theta_interp=",ifbg_theta_interp
+cdiag write(lp,*)
+cdiag& " i ",
+cdiag& " ribtbl(i) "," ridb(i) ",
+cdiag& "irimax(i) "
+cdiag do i= -mt,mt
+cdiag write(lp,9050) i,ribtbl(i),ridb(i),irimax(i)
+cdiag enddo
+c
+cdiag write(lp,*) " "
+cdiag write(lp,*) "irid Ri_d Ri(irimax) "
+cdiag& // "S_M S_H S_S "
+cdiag& // "S_M/S_H S_S/S_H "
+cdiag do irid= -mt,mt
+cdiag write(lp,9100) irid,ridb(irid),ribtbl(irimax(irid)),
+cdiag& smb(irimax(irid),irid),
+cdiag& shb(irimax(irid),irid),
+cdiag& ssb(irimax(irid),irid),
+cdiag& smb(irimax(irid),irid)/shb(irimax(irid),irid),
+cdiag& ssb(irimax(irid),irid)/shb(irimax(irid),irid)
+cdiag enddo
+cdiag call flush(lp)
+cdiag endif !1st proc
+c
+c --- CALCULATE "R_r_Critical" USING CANUTO'S 000228 ANALYTIC FORMULA
+c --- FOR "R_rho_Critical". See NBp.000229-3 and 000316-4.
+c --- R_rho_Canuto \equiv -Ri_C/Ri_T \equiv -R_r .
+c --- In a sheet dated 000228 Canuto gave me:
+c --- "R_\rho^{cr} = {1 \over \Deta} [1 {+\over-} \sqrt{1 - \Delta^2}]
+c --- \Delta \equiv {{\pi_2(1 + {15 \over 7} \pi_3)} \over
+c --- {\pi_3 - \pi_2 + (15 \over 14} \pi_3^2}} ".
+c --- Note that the + and - choices are reciprocals so this covers
+c --- both the Salt Fingering and Double Diffusive Critical R_\rho's.
+c --- From Ocean Turbulence III paper have:
+c --- \pi_{1,2,3,4,5} =
+c --- (\tau_pc,\tau_c\theta,\tau_c,\tau_p\theta,\tau_\theta)/\tau
+c --- R_r_Crit = [-1 -/+ \sqrt{1 - \Delta^2}]/Delta
+c --- \Delta = {{{\tau_c\theta \over \tau} ( 1 + (15/7)*{\tau_c \over \tau})}
+c --- \over {{\tau_c \over \tau} - {\tau_c\theta \over \tau} +
+c --- (15/14) {\tau_c \over \tau}^2}}
+c
+ deltanum = tctot*(1. + ((15./7.)*tcot))
+ deltaden = tcot - tctot + ((15./14.)*(tcot**2))
+ delta = deltanum/deltaden
+ rrcrn = (-1. - sqrt(1. - (delta**2)))/delta
+ rrcrp = (-1. + sqrt(1. - (delta**2)))/delta
+ theta_rcrn = atan(rrcrn)
+ theta_rcrp = atan(rrcrp)
+c
+c --- Make sure the right choice of arctan(R_r)=[\theta_r] is made.
+c --- Arctan covers the range (-pi/2,pi/2) while
+c --- \theta_r_Crit must be in the range (-pi/4,3pi/4) (The range of Ri>0.)
+c
+ if(theta_rcrn.lt.-pi/4.) theta_rcrn = theta_rcrn + pi
+ if(theta_rcrp.lt.-pi/4.) theta_rcrp = theta_rcrp + pi
+ theta_rcrn_deg = theta_rcrn*(180./pi)
+ theta_rcrp_deg = theta_rcrp*(180./pi)
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,*) " "
+cdiag write(lp,*) " "
+cdiag write(lp,*) " "
+cdiag write(lp,*) " "
+cdiag write(lp,*) "R_r_Crit+ =",rrcrp
+cdiag write(lp,*) "R_r_Crit- =",rrcrn
+cdiag write(lp,*) "\\theta_r_Crit+ =",theta_rcrp
+cdiag write(lp,*) "\\theta_r_Crit- =",theta_rcrn
+cdiag write(lp,*) "\\theta_r_Crit+ in degrees =",theta_rcrp_deg
+cdiag write(lp,*) "\\theta_r_Crit- in degrees =",theta_rcrn_deg
+cdiag write(lp,*) " "
+cdiag write(lp,*) " "
+c
+cdiag write(lp,*) " "
+cdiag write(lp,*) " "
+cdiag call flush(lp)
+cdiag endif !1st proc
+c
+c --- Increments in radial and angular coordinates in (Ri_T,Ri_C) plane.
+c
+ delra_r = 1./float(mt_ra_r)
+c deltheta_r = (pi/4.)/float(n_theta_r_oct)
+c
+c --- Natassa
+c if (mnproc.eq.1) then
+c write(53,*)nstep,igrid,jgrid,n_theta_r_oct,deltheta_r
+c endif !1st proc
+c
+c --- Calculate the ratio \sigma_sa_max \equiv S_S/S_H as a function
+c --- of the angle \theta_r in Ri_T,Ri_C space,
+c --- \theta_r \equiv arctan(Ri_C/Ri_T).
+c --- The range of angles where unrealizability occurs is
+c --- a subset of theta_r = -pi/4 to 3pi/4.
+c
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,*) "S_S/S_H at pre-maximum Ri as a function of"
+cdiag& // "\\theta_r \\equiv Arctan(Ri_C/Ri_T)"
+c
+c --- Absurd default on sisamax \equiv S_S/S_H.
+cdiag write(lp,*) "Arbitrarily show the absurd value -99.999"
+cdiag write(lp,*) "at angles where do not have "//
+cdiag& "a maximum Ri (or radius ra_r)."
+cdiag write(lp,*) " "
+cdiag write(lp,*) " \\th_r ^o ra_r "
+cdiag& // " Ri_T Ri_C Ri Ri_d "
+cdiag& // " S_M S_H S_S S_S/S_H "
+cdiag call flush(lp)
+cdiag endif !1st proc
+c
+c --- For Ri_T and Ri_C positive find the realizability limits
+c --- in polar coordinates in the (Ri_T,Ri_C) plane : (ra_r,theta_r).
+c
+ if(ifpolartablewrite.eq. 1 .and. mnproc.eq.1) then
+ open(unit=uoff+98,file="turb_ra_th",status="unknown")
+ endif
+ do itheta_r = -n_theta_r_oct,3*n_theta_r_oct
+c do ihelp = 0,4*n_theta_r_oct
+c itheta_r=ihelp-n_theta_r_oct
+ theta_r = float(itheta_r)*deltheta_r
+ theta_r_deg = theta_r*(180./pi)
+c
+c --- Introduce jtheta_r, an angle index that begins at zero
+c --- for the purposes of letting OURSAL2 know it starts at the origin.
+c
+ jtheta_r = itheta_r + n_theta_r_oct
+c
+c --- Initialize sisamax to the impossible negative value of -99.999 to
+c --- let places where the realizability limit is not reached stand out.
+ sisamax(itheta_r) = -99.999
+c
+c --- Initialize sm_r0,sh_r0,ss_r0 to the INCONSISTENT absurd value -9.999999.
+ sm_r0 = -9.999999
+ sh_r0 = -9.999999
+ ss_r0 = -9.999999
+c
+c --- Flag ibg determines if the background value of ra_r has been calculated.
+ if(ifsalback.eq. 6) ibg=0
+c
+c --- Flag ifunreal determines if realizability limit has been found.
+ ifunreal=0
+c
+c --- Make the ra_r max value not too large to try to avoid numerical trouble.
+c
+ do ira_r = 0,(mt_ra_r**2)/4
+c
+ if(ira_r.le.mt_ra_r) then
+ ra_r = float(ira_r)*delra_r
+ else
+ ra_r = ((1.+delra_r)**(ira_r - mt_ra_r))
+ & *(float(mt_ra_r)*delra_r)
+ endif
+c
+c --- Convert radius and angle, (ra_r,theta_r), to rectangular coordinates.
+ rit = ra_r*COS(theta_r)
+ ric = ra_r*SIN(theta_r)
+ ri_r = rit + ric
+ rid_r = rit - ric
+c
+c --- Calculate turbulence functions at this radius and angle in (Ri_T,Ri_C).
+c
+ call oursal2_1a(ri_r,rid_r,slq2_r,sm_r,sh_r,ss_r,
+ & c_y0,c_y00,ira_r,jtheta_r)
+c
+ if(ifpolartablewrite.eq. 1 .and. mnproc.eq.1) then
+ write(uoff+98,9001)
+ & itheta_r,theta_r_deg,ira_r,ra_r,slq2_r,sm_r,sh_r,ss_r
+ endif
+c
+c --- Calculate S_M/(S l/q) and find where it's backfact of its origin value.
+ if(ifsalback.eq. 6) then
+ smosloq_r = sm_r/sqrt(slq2_r)
+ if(ira_r.eq. 0) smosloq_0r = smosloq_r
+c --- Use radius where dimensionless K_M falls below backfact*origin value.
+ if((smosloq_r.le.backfact*smosloq_0r).AND.
+ & (ibg.eq. 0) ) then
+ ra_r1 = ra_r
+ rit1 = rit
+ ric1 = ric
+ ri_r1 = ri_r
+ rid_r1 = rid_r
+ slq2_r1(itheta_r) = slq2_r
+ sm_r1(itheta_r) = sm_r
+ sh_r1(itheta_r) = sh_r
+ ss_r1(itheta_r) = ss_r
+ ibg=1
+ endif
+ endif
+c
+ if(slq2_r.le.0.) then
+c --- Use value of last lattice point on this radius with "slq2" positive.
+c --- Calculate the ratio of the salt and heat diffusivities there.
+ sisamax(itheta_r) = ss_r0/sh_r0
+c
+c --- Store in an array the maximum radius, ra_r, at this angle, theta_r,
+c --- in the polar (Ri_T,Ri_C) [that is the (theta_r,ra_r)] plane.
+ ra_rmax(itheta_r) = ra_r0
+c
+c --- Determine the background radius, ra_r, at this \theta_r.
+ if(ifsalback.eq. 5) then
+c --- Use a constant fraction of the maximum radius before model breakdown.
+ back_ra_r(itheta_r) = backfrac*ra_rmax(itheta_r)
+c
+ else if(ifsalback.eq. 6) then
+ back_ra_r(itheta_r) = ra_r1
+ endif
+c
+ ifunreal = 1
+c
+c --- Skip straight to write out when last point reached.
+ go to 16
+ endif
+c
+ ra_r0 = ra_r
+ rit0 = rit
+ ric0 = ric
+ ri_r0 = ri_r
+ rid_r0 = rid_r
+ slq2_r0 = slq2_r
+ sm_r0 = sm_r
+ sh_r0 = sh_r
+ ss_r0 = ss_r
+c
+c --- Store c_y as c_y_0 for possible use as a guess in background calc.
+ c_y_r0(itheta_r) = c_y0
+c
+ enddo
+c
+c --- Write out stability functions, the S's and sisamax.
+ 16 continue
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,9150) theta_r_deg,ra_r0,rit0,ric0,ri_r0,rid_r0,
+cdiag& sm_r0,sh_r0,ss_r0,sisamax(itheta_r)
+cdiag call flush(lp)
+cdiag endif !1st proc
+c
+c --- Set background ra_r large at angles where unrealizability doesn't occur.
+c --- Make the ra_r max value not too large to try to avoid numerical trouble.
+ if(ifunreal.eq. 0) then
+ ipenra_r = (mt_ra_r**2)/4-1
+ back_ra_r(itheta_r) = ((1.+delra_r)**(ipenra_r - mt_ra_r))
+ & *(float(mt_ra_r)*delra_r)
+ endif
+c
+c --- For ifsalback=5 case get value for initialization of c_y calculation.
+ if(ifsalback.eq. 5) then
+ if(jtheta_r.eq. 0) then
+ c_y001 = c_y0
+ endif
+ endif
+c
+ enddo
+
+c
+ if(ifpolartablewrite.eq. 1 .and. mnproc.eq.1) then
+ close(uoff+98)
+ endif
+c
+c --- Write out stability functions at background ra_r .
+ if(ifsalback.GT.4) then
+ do itheta_r = -n_theta_r_oct,3*n_theta_r_oct
+ theta_r = float(itheta_r)*deltheta_r
+ theta_r_deg = theta_r*(180./pi)
+c
+c --- Convert radius and angle, (ra_r,theta_r), to rectangular coordinates.
+ rit1 = back_ra_r(itheta_r)*COS(theta_r)
+ ric1 = back_ra_r(itheta_r)*SIN(theta_r)
+ ri_r1 = rit1 + ric1
+ rid_r1 = rit1 - ric1
+c
+c --- Calculation of turbulence functions for ifsalback=5 case.
+ if(ifsalback.eq. 5) then
+c
+c --- Calculate turbulence functions at this radius and angle in (Ri_T,Ri_C).
+ jtheta_r = itheta_r + n_theta_r_oct
+c
+c --- Set second table index to 1 to use last step's value except at start.
+c --- Transform that "last step" value from the most recent angle step to the
+c --- final realizable ra_r step at {\it this} angle in hope of more accuracy.
+ call oursal2_1a(ri_r1,rid_r1,slq2_r1(itheta_r),
+ & sm_r1(itheta_r),sh_r1(itheta_r),ss_r1(itheta_r),
+ & c_y_r0(itheta_r),c_y001,jtheta_r,1)
+ endif
+c
+cdiag if(itheta_r.eq. -n_theta_r_oct) then
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,*) " "
+cdiag write(lp,*)
+cdiag& "Values at background ra_r=(Ri_T^2 + Ri_C^2)^(1/2)"
+cdiag write(lp,*) "\\th_r ^o ra_r "
+cdiag& // "Ri_T Ri_C Ri Ri_d "
+cdiag& // "(Sl/q)^2 S_M S_H S_S S_S/S_H "
+cdiag write(lp,*) " "
+cdiag call flush(lp)
+cdiag endif !1st proc
+cdiag endif
+c
+ sisa1 = ss_r1(itheta_r)/sh_r1(itheta_r)
+c
+* if (mnproc.eq.1) then
+* write(lp,*)
+* & 'itheta_r,theta_r_deg = ',itheta_r,theta_r_deg
+* write(lp,*)
+* & 'back_ra_r,slq2_r1 = ',
+* & back_ra_r(itheta_r),slq2_r1(itheta_r)
+* write(lp,*)
+* & 'sm_r1,sh_r1,ss_r1 = ',
+* & sm_r1(itheta_r),sh_r1(itheta_r),ss_r1(itheta_r)
+* call flush(lp)
+* endif !1st proc
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,9160) theta_r_deg,back_ra_r(itheta_r),
+cdiag& rit1,ric1,ri_r1,rid_r1,slq2_r1(itheta_r),
+cdiag& sm_r1(itheta_r),sh_r1(itheta_r),ss_r1(itheta_r),
+cdiag& sisa1
+cdiag call flush(lp)
+cdiag endif !1st proc
+c
+ if(slq2_r1(itheta_r).lt.0.) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ & "Negative (Sl/q)^2 in table of Background vs. \\theta_r."
+ write(lp,*) "itheta_r=",itheta_r,
+ & " slq2_r1(itheta_r)=",slq2_r1(itheta_r)
+ write(lp,*) "Program is stopping in turb_2."
+ endif !1st proc
+ call xcstop('(inigiss)')
+ stop '(inigiss)'
+ endif
+ enddo
+ endif
+c
+c
+ 9001 format(2(I8,' ',1pe11.3),8(1pe11.3))
+ 9050 format(I8,' ',2E16.4,I8,' ')
+ 9100 format(' ',I8,' ',2E12.4,3F11.6,2F11.4)
+ 9150 format(F11.3,5E12.4,3F10.6,F9.3)
+ 9160 format(F11.3,1x,6(E10.4,1x),3(F10.6,1x),F9.3)
+ 9200 format(I12,' ',5E16.6)
+
+c
+ return
+ end
+c
+ subroutine oursal2_1a(ri,rid,slq2,sm,sh,sc,c_y0,c_y00,iri,irid)
+c
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+c --- Replace the numerical value of 6.25 by 1/(tpvot**2) .
+c --- Version in which following OTsalche/plot000127
+c --- the timescale ratios are calculated in the 'smshsc' routine
+c --- and passed back hrough the common block bb0/
+c --- to simplify the process of adjustment of timescale ratios.
+c --- Submodule to calculate turbulence functions (Sl/q)^2 and S_M,S_H,S_S
+c --- of Ri(=Ri_T+Ri_C) and Ri_d(=Ri_T-Ri_C) in our NCAR turbulence module.
+c --- Stripped and adapted from plot981007.f.
+c --- Program to generate contour and 1 variable plots vs. Ri,Ri_d based on
+c --- Program to generate contour plots vs. Ri_T and Ri_C based on
+c --- Program to generate plots vs. Ri_T at different Ri_C values based on
+c --- .or.eC.eD PROGRAM WITH .eW VAL.e OF "p10". 'p10 = tpt*tct/(tc**2)'
+c --- Program to generate K_X/((l^2) S) for Canuto based on plot980609.f:
+c --- Program to generate data for plots of turbulence functions including
+c --- S_{M,H,C} and Canuto's new y = (\tau_pv S)^2
+c --- and n,c as functions of stability parameters in the concentration theory
+c --- (structure is a 1 point closure like the generalized Mellor-Yamada,
+c --- but the constants are derived based on Dubovikov's model according
+c --- to Ye Cheng). The concentration theory dimensionless parameters
+c --- associated with the squares of shear, temperature contribution to
+c --- Brunt Vaisala frequency and concentration contribution to it,
+c --- the new y,n,c are represented in this program by the variables
+c --- c_y,c_n,c_c.
+c --- Adapted from Cheng's program mike_12.f_980528 for the Dubovikov model.
+
+c-----------------------------------------------------------------------
+c
+c --- y=(tau*s)**2
+c --- tau=2*e/epsilon=b1*l/q
+c --- km=e*tau*sm=1/2*(b1*l)**2*s/y**(1/2)*sm
+c --- kh=e*tau*sh=1/2*(b1*l)**2*s/y**(1/2)*sh
+c --- ks=e*tau*ss=1/2*(b1*l)**2*s/y**(1/2)*ss
+c
+c --- X = {M,H,C} .
+c --- Cheng above gives K_X = (1/2)((B_1*l)^2) (S/(((\tau S)**2)^(1/2))) S_X
+c --- The "old" y used above is (\tau S)^2.
+c --- The "new" y (c_y in the program) is (\tau_pv S)^2.
+c --- The program variable "slq2" is (S l/q)^2 = y (B_1)^(-2),
+c --- since \tau=B_1 l/q. (S l/q)^2 = (\tau \over \tau_pv)^2 c_y (B_1)^(-2) .
+c --- c_y = (S l/q)^2 * [(B_1)^2 * (\tau_pv \over \tau)^2] .
+c
+c --- Take \tau_pv/\tau as being calculated in the smshsc routine instead.
+c --- From the printed notes Canuto gave me on 980601 have:
+c --- \tau_pv = {2 \over 5} \tau (B.1) or parameter(tpvot = 0.4)
+c
+ include 'common_blocks.h'
+c
+ real ri,rid,slq2,sm,sh,sc,c_y0,c_y00
+ real eeps,c_yst,c_yst0,rit,ric,c_y,val,c_n,c_c
+!DBI: all eps ==> eeps in this routine!
+ integer iri,irid,iend,ier
+ common /bb/rit,ric !rit is the temperature's part of
+ . !Ri and ric the concentration's.
+c
+ parameter(c_yst0 = 8.527882) !Need a guess for c_y for the solver
+ . !for the neutral case, c_yst. Take
+ !c_yst = 8.527882, the approximate value
+ !calculated at rit=ric=0. A variable c_y00
+ !is intended to hold the Ri=0 value of c_y
+ !from the previous Ri_d row in a table the
+ !subroutine is being called to make and a
+ !variable c_y0 is intended to hold the
+ !previous Ri value from the current Ri_d
+ !row of that table.
+ b1=16.6
+c
+c --- Commented excerpt from the file "sx"
+c
+c --- sgmt := 0.72;
+c
+c --- tpt := 1/(5*(1+1/sgmt))*tau;
+c --- tpt = .08372093019*tau
+c
+c --- tpc := 1/(5*(1+1/sgmt))*tau;
+c --- tpc = .08372093019*tau
+c
+c --- tt := sgmt*tau;
+c --- tt = .72*tau
+c
+c --- tc := sgmt*tau;
+c --- tc = .72*tau
+c
+c --- tct := 2/15*sgmt*tau;
+c --- tct = .09599999998*tau
+c
+c --- Calculate the timescale ratios in the 'smshsc' routine instead of here.
+c --- Set \sigma_t0. sgmt = .72
+c
+c --- Calculate {\tau_C \over \tau} and {\tau_{C\theta} \over \tau}.
+c --- tcot = sgmt
+c --- tctot = (2./15.)*sgmt
+c --- "tpt/tau" and "tpc/tau" from the "sx" excerpt
+c --- tptot = 1./(5.*(1+1/sgmt))
+c --- tpcot = 1./(5.*(1+1/sgmt))
+c
+c --- Timescale ratios are now calculated in the 'smshsc' subroutine.
+c --- Make dummy call with c_y=c_n=c_c=0 to get their values for initial use.
+ call smshsc_a3(0.,0.,0.,sm,sh,sc)
+c
+ eeps=1.e-6
+ iend=300
+c
+c --- rimax= ?
+c --- rtwi finds the root of x=fct_sal(x)
+c --- Need a guess at the root, c_yst. Use neighboring solution.
+c --- Initial guess for c_yst for this value of Ri_d.
+ if(iri.eq.0.and.irid.eq.0) then
+ c_yst = c_yst0
+ else if(iri.eq.0) then
+ c_yst = c_y00
+ else
+ c_yst = c_y0
+ endif
+c
+c --- Calculate Ri_T =(Ri + Ri_d)/2 and Ri_C =(Ri - Ri_d)/2.
+ rit = (ri + rid)/2.
+ ric = (ri - rid)/2.
+ call rtwi(c_y,val,c_yst,eeps,sm,sh,sc,iend,ier)
+c
+ if(ier.ne.0) then
+c --- Make error message more specific.
+ if (mnproc.eq.1) then
+ write(lp,*) "In oursal2 subroutine"
+ write(lp,*) "c_y00=",c_y00," c_y0=",c_y0
+ write(lp,*) "ri=",ri," rid=",rid
+ write(lp,*) "rit=",rit," ric=",ric
+ write(lp,*) "Initial guess for rtwi c_yst=",c_yst
+c
+ write(lp,*) "rtwi call problem, ier=",ier
+ endif !1st proc
+ call xcstop('(oursal2_1a)')
+ stop '(oursal2_1a)'
+ endif
+c
+c --- Calculate (S l/q)^2[=program variable "slq2"] from c_y.**
+c --- (S l/q)^2 = (\tau \over \tau_pv)^2 c_y (B_1)^(-2) .
+c --- (S l/q)^2 = (\tau_pv \over \tau)^(-2) c_y (B_1)^(-2) .
+ slq2 = c_y/((b1*tpvot)**2)
+c
+c --- Store value of c_y for future guesses.
+ if(c_y.ge.0) then
+ c_y0=c_y
+ else
+c --- Turbulence model becomes unphysical for c_y negative.
+c --- Realizability for negative Ri
+ if(ri.lt.0) then
+ if (mnproc.eq.1) then
+ write(lp,*) "c_y negative at negative Ri"
+ write(lp,*) "Ri=",ri," c_y=",c_y
+ write(lp,*) "Unstable realizability limit unexpected:"
+ write(lp,*) "stopping in oursal2."
+ endif !1st proc
+ call xcstop('(oursal2_1a)')
+ stop '(oursal2_1a)'
+ endif
+ endif
+c
+ if(iri.eq.0) c_y00=c_y
+ if((iri.eq.0).and.(irid.eq.0).and.
+ . (abs(c_y - c_yst0).gt.1.e-6)) then
+ if (mnproc.eq.1) then
+ write(lp,*) "Inconsistency in neutral value of c_y"
+ write(lp,*) "Value used =",c_yst0
+ write(lp,*) "Value calculated =",c_y
+ write(lp,*) "Program stopping in oursal2"
+ endif !1st proc
+ call xcstop('(oursal2_1a)')
+ stop '(oursal2_1a)'
+ endif
+c
+c --- From last page (#5) of "980608 AH Concentration Work" handwritten
+c --- sheetsC have:
+c --- n = -{{\tau_C \tau_{C\theta}} \over {\tau_{pv}}^2 } y Ri_T
+c --- c = - {{\tau_C}^2 \over {\tau_{pv}}^2} y Ri_C
+c --- Decide to use the parameter "tpvot" instead of its value 2/5 \tau .
+c --- n = -{{(\tau_C/\tau) (\tau_{C\theta}/\tau)} \over {\tau_{pv}/\tau}^2 }
+c --- y Ri_T
+c --- c = - {{\tau_C/\tau}^2 \over {\tau_{pv}/\tau}^2} y Ri_C
+c
+ c_n = -(tcot*tctot/(tpvot**2))*c_y*rit
+ c_c = -((tcot**2)/(tpvot**2))*c_y*ric
+ call smshsc_a3(c_y,c_n,c_c,sm,sh,sc)
+c
+c
+ 1003 format(12(I8))
+ 1004 format(12(1pe14.5))
+ end
+c-----------------------------------------------------------------------
+ function fct_sal(sm,sh,sc,c_y)
+c
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ real fct_sal,c_n,c_c,c_y,sm,sh,sc,bb,rit,ric
+c
+ include 'common_blocks.h'
+c
+ common /bb/rit,ric
+c
+c --- Decide to use the parameter "tpvot" instead of its value 2/5 \tau .
+ c_n = -((tcot*tctot)/(tpvot**2))*c_y*rit
+ c_c = -((tcot**2)/(tpvot**2))*c_y*ric
+ call smshsc_a3(c_y,c_n,c_c,sm,sh,sc)
+c
+c --- y(S_\nu - Ri_T S_h - Ri_C S_c) = 8/25 . 8/25 = 0.32 . S_\nu = sm.
+c --- y = 0.32/(S_\nu - Ri_T S_h - Ri_C S_c).
+ fct_sal=(2.*(tpvot**2))/(sm-rit*sh-ric*sc)
+ return
+ end
+c-----------------------------------------------------------------------
+ subroutine smshsc_a3(yyy,nnn,ccc,sm,sh,sc)
+c
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c --- .eW SUBROUTI.e WHICH calculates the "p's" from the timescale ratios.
+c --- BA.eD on "smshsc2":
+c --- SUBROUTI.e WHICH CALCULA.eS "p's" from "sgmt". BA.eD ON "smshsc1":
+c --- .eW SUBROUTI.e WHICH U.eS .e C.eNG'S .orTRAN CO.e TO CALCULA.e CONSTANTS
+c --- FROM T.e "p's" .eNT TO .e BY HIM TODAY. BA.eD ON "smshsc0".
+c --- **.or.eCT T.e VAL.e OF "p10".**
+c --- p_10 = {\tau_{p \theta} \tau_{c \theta}} \over {\tau_c ^ 2}
+c
+c --- Replace Cheng's smsh with smshsc, which includes concentration.
+c --- The y,n,c used here are Canuto's "y,n,c" called c_y,c_n,c_c
+c --- elsewhere in this program.
+ real yyy,nnn,ccc,sm,sh,sc
+ real Nm,Nh,Nc
+c
+ real p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p1m,p2m
+ real a0,a1,a2,a3,a4,a5
+ real d0,d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15
+ real D
+c
+ integer ifrecall,ifmodelconstout
+c
+c --- Switch for whether(1) or not(0) to output p's a's and d's to a file.
+ parameter(ifmodelconstout=0)
+c
+c --- Add `\tau_pv \over \tau' to the common block with timescale ratios.
+c
+c --- Calculate the p's.
+ p1 = 0.832
+ p2 = 0.545
+ p3 = (5./2.)*tpcot
+ p4 = (1./5.)*tpcot*(tcot**(-2))
+ p5 = tpcot*tctot*(tcot**(-2))
+ p6 = (1./5.)*(tcot**(-1))*(tctot**(-1))*tptot
+ p7 = 5.*tctot
+ p8 = (5./2.)*tptot
+ p9 = ttot*tptot*((tcot*tctot)**(-1))
+ p10 = tctot*tptot*(tcot**(-2))
+ p11 = tpcot*(tcot**(-1))
+ p1m = 1. - p1
+ p2m = 1. - p2
+c
+c-----------------------------------------------------------------------
+Cresults.2_1
+c --- Values of a's and d's calculated from p's using Cheng's Fortran code
+c --- to do so, from today's email from him, cheng990513.results.2_1 .
+c --- results.2_1
+C##########################
+C## Fortran code:
+C##########################
+ A0 = 12
+ A1 = p11*(12*p9+8*p6-30*p6*p8-5*p6*(p1m+3*p2m))
+ A2 = 5*(2*p4*p6*p7-p4*p9-p6*p11)*(p1m+3*p2m)+8*p6*p11+8*p4*p9-16*p
+ &4*p6*p7+12*p11*p9+12*p11*p10-12*p4*p7**2*p6-30*p6*p11*p8+30*p4*p6*
+ &p7*p8+30*p6*p4*p7*p3-30*p4*p9*p3
+ A3 = p10*(12*p11+8*p4-30*p3*p4-5*p4*(p1m+3*p2m))
+ A4 = -p6*(8-30*p8-5*p1m-15*p2m)-12*p9-12*p11
+ A5 = -p4*(8-30*p3-5*p1m-15*p2m)-12*p10-12*p11
+ D0 = 24
+ D1 = p11*((-p6-2*p9)*p1m**2+(p6+6*p9)*p2m**2+2*p6*p8*(p1m-3*p2m))
+ D2 = (2*p4*p6*p7-p4*p9-p6*p11)*(p1m**2-p2m**2)+2*(-p11*p10-p11*p9+
+ &p4*p7**2*p6)*(p1m**2-3*p2m**2)+2*(-p6*p4*p7*p3-p4*p6*p7*p8+p4*p9*p
+ &3+p6*p11*p8)*(p1m-3*p2m)
+ D3 = p10*((-p4-2*p11)*p1m**2+2*p4*p3*(p1m-3*p2m)+(6*p11+p4)*p2m**2
+ &)
+ D4 = -4*p6*p11*(3*p9+2*p6)
+ D5 = 4*p4*p6**2*p7*(4+3*p7)-4*p4*p9*(3*p11+2*p6)-4*p6*p11*(3*p9+3*
+ &p10+2*p4+2*p6)
+ D6 = 4*p4**2*p6*p7*(4+3*p7)-4*p4*p9*(2*p4+3*p11)-8*p4*p6*(p11+p10)
+ &-12*p10*p11*(p4+p6)
+ D7 = -4*p4*p10*(2*p4+3*p11)
+ D8 = (2*p9+2*p11+p6)*p1m**2-2*p6*p8*(p1m-3*p2m)-(p6+6*p9+6*p11)*p2
+ &m**2
+ D9 = (2*p10+p4+2*p11)*p1m**2-2*p4*p3*(p1m-3*p2m)-(p4+6*p10+6*p11)*
+ &p2m**2
+ D10 = 8*p6**2+4*(7*p11+3*p9)*p6+24*p11*p9
+ D11 = -8*(4+3*p7)*p4*p6*p7+4*p4*(4*p6+7*p9+3*p11)+4*p6*(3*p10+7*p1
+ &1)+24*p11*(p10+p9)
+ D12 = 4*p10*(7*p4+6*p11)+4*p4*(2*p4+3*p11)
+ D13 = 6*p2m**2-2*p1m**2
+ D14 = -28*p6-24*p9-24*p11
+ D15 = -24*p10-28*p4-24*p11
+Cresults.2_1
+c-----------------------------------------------------------------------
+c
+c --- Write out the p's.
+c --- Writeout the timescale ratios as well.
+ ifrecall=1
+ if(ifrecall.eq.0 .and. mnproc.eq.1) then
+ write(lp,*) "tau_pv/tau =",tpvot
+ write(lp,*) "tau_ptheta/tau =",tptot
+ write(lp,*) "tau_pc/tau =",tpcot
+ write(lp,*) "tau_theta/tau =",ttot
+ write(lp,*) "tau_c/tau =",tcot
+ write(lp,*) "tau_ctheta/tau =",tctot
+ write(lp,*) " "
+ write(lp,*) "p1 =",p1
+ write(lp,*) "p2 =",p2
+ write(lp,*) "p3 =",p3
+ write(lp,*) "p4 =",p4
+ write(lp,*) "p5 =",p5
+ write(lp,*) "p6 =",p6
+ write(lp,*) "p7 =",p7
+ write(lp,*) "p8 =",p8
+ write(lp,*) "p9 =",p9
+ write(lp,*) "p10=",p10
+ write(lp,*) "p11=",p11
+c
+c --- Write out the a's and d's as well.
+ write(lp,*) "a0=",a0
+ write(lp,*) "a1=",a1
+ write(lp,*) "a2=",a2
+ write(lp,*) "a3=",a3
+ write(lp,*) "a4=",a4
+ write(lp,*) "a5=",a5
+ write(lp,*) "d0=",d0
+ write(lp,*) "d1=",d1
+ write(lp,*) "d2=",d2
+ write(lp,*) "d3=",d3
+ write(lp,*) "d4=",d4
+ write(lp,*) "d5=",d5
+ write(lp,*) "d6=",d6
+ write(lp,*) "d7=",d7
+ write(lp,*) "d8=",d8
+ write(lp,*) "d9=",d9
+ write(lp,*) "d10=",d10
+ write(lp,*) "d11=",d11
+ write(lp,*) "d12=",d12
+ write(lp,*) "d13=",d13
+ write(lp,*) "d14=",d14
+ write(lp,*) "d15=",d15
+c
+c --- Output p#, a# and d# to the file model_constants if the switch is set.
+c --- Writeout the timescale ratios as well.
+ if(ifmodelconstout.eq.1 .and. mnproc.eq.1) then
+ open(unit=uoff+98,file='model_constants',status='unknown')
+ write(uoff+98,*) "tau_pv/tau =",tpvot
+ write(uoff+98,*) "tau_ptheta/tau =",tptot
+ write(uoff+98,*) "tau_pc/tau =",tpcot
+ write(uoff+98,*) "tau_theta/tau =",ttot
+ write(uoff+98,*) "tau_c/tau =",tcot
+ write(uoff+98,*) "tau_ctheta/tau =",tctot
+ write(uoff+98,*) " "
+ write(uoff+98,*) "p1 =",p1
+ write(uoff+98,*) "p2 =",p2
+ write(uoff+98,*) "p3 =",p3
+ write(uoff+98,*) "p4 =",p4
+ write(uoff+98,*) "p5 =",p5
+ write(uoff+98,*) "p6 =",p6
+ write(uoff+98,*) "p7 =",p7
+ write(uoff+98,*) "p8 =",p8
+ write(uoff+98,*) "p9 =",p9
+ write(uoff+98,*) "p10=",p10
+ write(uoff+98,*) "p11=",p11
+ write(uoff+98,*) "a0 =",a0
+ write(uoff+98,*) "a1 =",a1
+ write(uoff+98,*) "a2 =",a2
+ write(uoff+98,*) "a3 =",a3
+ write(uoff+98,*) "a4 =",a4
+ write(uoff+98,*) "a5 =",a5
+ write(uoff+98,*) "d0 =",d0
+ write(uoff+98,*) "d1 =",d1
+ write(uoff+98,*) "d2 =",d2
+ write(uoff+98,*) "d3 =",d3
+ write(uoff+98,*) "d4 =",d4
+ write(uoff+98,*) "d5 =",d5
+ write(uoff+98,*) "d6 =",d6
+ write(uoff+98,*) "d7 =",d7
+ write(uoff+98,*) "d8 =",d8
+ write(uoff+98,*) "d9 =",d9
+ write(uoff+98,*) "d10=",d10
+ write(uoff+98,*) "d11=",d11
+ write(uoff+98,*) "d12=",d12
+ write(uoff+98,*) "d13=",d13
+ write(uoff+98,*) "d14=",d14
+ write(uoff+98,*) "d15=",d15
+ close(uoff+98)
+ endif
+c
+ endif
+ ifrecall = 1
+c
+
+c --- Modification of section of "sx" containing the den and nums of the "S"'s
+
+C###############################################
+
+ D = d0 + d1*yyy*nnn**2 + d2*yyy*nnn*ccc + d3*yyy*ccc**2
+ & + d4*nnn**3 + d5*nnn**2*ccc + d6*nnn*ccc**2 + d7*ccc**3
+ & + d8*yyy*nnn + d9*yyy*ccc + d10*nnn**2 + d11*nnn*ccc
+ & + d12*ccc**2 + d13*yyy
+ & + d14*nnn + d15*ccc
+C########################################################################
+
+ Nm = a0 + a1*nnn**2 + a2*nnn*ccc + a3*ccc**2 + a4*nnn + a5*ccc
+
+C###########################################################################
+ Nh = - (30.*nnn*p6 + 30.*ccc*p4 - 60.
+ & - ( 2.*p1m + 15.*p2m**2 - 6.*p2m - 5.*p1m**2 )
+ & * yyy )
+ & * (ccc*p4*p7 - ccc*p11 - nnn*p11 + 1.)
+
+
+ Nc = (30.*nnn*p6 + 30.*ccc*p4 - 60.
+ & - ( 2.*p1m + 15.*p2m**2 - 6.*p2m - 5.*p1m**2 )
+ & * yyy )
+ & * (ccc*p10 - 1. - nnn*p6*p7 + nnn*p9)
+c --- Modification of section of "sx" containing Sm, Sh, Sc
+C*******************************************************************************
+ sm = (4./15.) * tpvot * Nm/D
+
+ sh = (4./15.) * tptot * Nh/D
+
+ sc = (4./15.) * tpcot * Nc/D
+C*******************************************************************************
+ return
+ 1004 format(12(1pe14.5))
+ end
+c-----------------------------------------------------------------------
+ subroutine rtwi(xx,val,xst,eeps,sm,sh,sc,iend,ier)
+c
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real fct_sal,xx,val,xst,eeps,sm,sh,sc
+ real tol,a,b,d,bb,rit,ric
+ integer iend,ier,i
+c
+ common /bb/rit,ric
+c
+c --- to solve general nonlinear equations of the form x=fct_sal(x)
+c --- by means of wegsteins iteration method
+c --- prepare iteration
+c
+c
+ ier=0
+ tol=xst
+ xx=fct_sal(sm,sh,sc,tol)
+ a=xx-xst
+ b=-a
+ tol=xx
+ val=xx-fct_sal(sm,sh,sc,tol)
+c
+c --- start iteration loop
+ do 6 i=1,iend
+c
+c --- Crude fix to avoid mysterious problem which occurred
+c --- with a close but not too close guess.
+ if(abs(val).lt.1.e-12) val =0.
+ if(val) 1,7,1
+c
+c --- equation is not satisfied by x
+ 1 b=b/val-1.
+ if(b) 2,8,2
+c
+c --- iteration is possible
+ 2 a=a/b
+ xx=xx+a
+ b=val
+ tol=xx
+ val=xx-fct_sal(sm,sh,sc,tol)
+c
+c --- test on satisfactory accuracy
+ tol=eeps
+ d=abs(xx)
+ if(d-1.) 4,4,3
+ 3 tol=tol*d
+ 4 if(abs(a)-tol) 5,5,6
+ 5 if(abs(val)-10.*tol) 7,7,6
+ 6 continue
+c
+c --- end of iteration loop
+c --- no convergence after iend iteration steps. error return.
+ ier=1
+ 7 return
+c
+c --- error return in case of zero divisor
+ 8 ier=2
+c
+ return
+ end
+c
+ subroutine interp2d_expabs(ri,rid,slq2,sm,sh,ss,m,m0,delta,rat)
+c
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c --- Subroutine for a modular interpolation calculation.
+c --- provides a faster interpolation calculation in the ifexpabstable=1 case.
+c
+c --- Output interpolated values: slq2,sm,sh,ss
+c
+ real ri,rid,slq2,sm,sh,ss,delta,rat
+ real deltaridta,deltarita,deltarid,deltari,dslq2_rid,dslq2_ri,
+ & dsm_rid,dsm_ri,dsh_rid,dsh_ri,dss_rid,dss_ri,
+ & tabindrid,tabindri
+ integer m,m0
+ integer lrid0,lrid1,lri0,lri1,l
+c
+c --- Take values off the edge of the table back to the table on radial lines.
+c --- Must use ratio of Ri's taken *before* the cut-off has taken place.
+ if(ri.gt.ribtbl(m)) then
+ if(abs(rid).le.ri) then
+ rid = ribtbl(m)*(rid/ri)
+ ri = ribtbl(m)
+ else if(rid.gt.ri) then
+ ri = ridb(m)*(ri/rid)
+ rid = ridb(m)
+ else if(rid.lt.-ri) then
+ ri = ridb(-m)*(ri/rid)
+ rid = ridb(-m)
+ end if
+ else if(ri.lt.ribtbl(-m)) then
+ if(abs(rid).le.-ri) then
+ rid = ribtbl(-m)*(rid/ri)
+ ri = ribtbl(-m)
+ else if(rid.gt.-ri) then
+ ri = ridb(m)*(ri/rid)
+ rid = ridb(m)
+ else if(rid.lt.ri) then
+ ri = ridb(-m)*(ri/rid)
+ rid = ridb(-m)
+ end if
+ else if(rid.gt.ridb(m)) then
+ ri = ridb(m)*(ri/rid)
+ rid = ridb(m)
+ else if(rid.lt.ridb(-m)) then
+ ri = ridb(-m)*(ri/rid)
+ rid = ridb(-m)
+ end if
+c
+c --- Interpolate points within the table range.
+c --- Table index ranges from -m to m with equal spacing for -m0 to m0.
+ if(abs(rid).lt.ridb(m0)) then
+c
+c --- Find Interpolation points in the equally spaced Ri_d part of the table.
+ lrid1 = int(rid/delta)+nint(sign(float(1),rid))
+c --- Find Interpolation points in exponential absolute value spaced Ri_d
+c --- part of the table.
+ else if((abs(rid)).ge.(ridb(m))) then
+c --- Special case where have a value which falls at the limit of the table.
+ lrid0 = nint(sign(float(m),rid))
+ lrid1 = lrid0
+ GO TO 252
+c
+ else
+ tabindrid = sign(
+ & float(m0) + ((log(abs(rid)) - log(ridb(m0)))/log(rat)),
+ & rid)
+ lrid1 = int(tabindrid)+nint(sign(float(1),rid))
+c
+ endif
+c
+c --- It is conceivable that rounding errors may in borderline cases
+c --- throw the calculated table indices for Ri_d off by one.
+c --- Check and allow moving one to either side to take care of this.
+ if ((abs(ridb(lrid1))).lt.(abs(rid))) then
+ lrid1 = lrid1 + sign(1,lrid1)
+ else if ((abs(ridb(lrid1-sign(1,lrid1)))).gt.(abs(rid))) then
+ lrid1 = lrid1 - sign(1,lrid1)
+ end if
+c
+ 250 continue
+c
+c --- Make lrid0 one less or greater than lrid1 according to sgn(rid).
+ lrid0 = lrid1 - nint(sign(float(1),rid))
+c
+ if(rid.eq.0.0) lrid1 = 1
+ 252 continue
+c
+C --- Check that the Ri_d value falls within the interpolation interval.
+ if(( rid.gt.0.0.and.
+ & (rid.lt.ridb(lrid0).or.rid.gt.ridb(lrid1))).or.
+ & ( rid.lt.0.0.and.
+ & (rid.gt.ridb(lrid0).or.rid.lt.ridb(lrid1))) ) then
+ if (mnproc.eq.1) then
+ WRITE(lp,*) "Ri_d is outside interpolation range in interp2d_e."
+ WRITE(lp,*) "rid= ",rid,"lrid0= ",lrid0,"lrid1= ",lrid1
+ WRITE(lp,*) "ridb(lrid0)= ",ridb(lrid0),
+ & " ridb(lrid1)= ",ridb(lrid1)
+ WRITE(lp,*) "Program is stopping."
+ endif !1st proc
+ call xcstop('(interp2d_expabs)')
+ stop '(interp2d_expabs)'
+ end if
+c
+c --- Artificially reduce Ri if it threatens to surpass Ri_max(Ri_d).
+c --- This is to conform to the 1D table's realizability limit treatment.
+c --- if(ri.gt.MIN(ribtbl(irimax(lrid0)),ribtbl(irimax(lrid1)))) then
+c --- ri = MIN(ribtbl(irimax(lrid0)),ribtbl(irimax(lrid1)))
+c --- end if
+c
+c --- Set turbulence to zero if Ri threatens to surpass the realizability limit.
+ if(ri.gt.MIN(ribtbl(irimax(lrid0)),ribtbl(irimax(lrid1)))) then
+ slq2=0.0
+ sm = 0.0
+ sh = 0.0
+ ss = 0.0
+ return
+ end if
+c
+c --- Table index ranges from -m to m with equal spacing for -m0 to m0.
+ if(abs(ri).lt.ribtbl(m0)) then
+c
+c --- Find Interpolation points in the equally spaced Ri part of the table.
+ lri1 = int(ri/delta)+nint(sign(float(1),ri))
+c
+c --- Find Interpolation points in exponential absolute value spaced Ri
+c --- part of the table.
+ else if((abs(ri)).ge.(ribtbl(m)))
+ & then
+c
+c --- Special case where have a value which falls at the limit of the table.
+ lri0 = nint(sign(float(m),ri))
+ lri1 = lri0
+ GO TO 272
+c
+ else
+ tabindri = sign(
+ & float(m0) + ((log(abs(ri)) - log(ribtbl(m0)))/log(rat)),
+ & ri)
+ lri1 = int(tabindri)+nint(sign(float(1),ri))
+c
+ 270 continue
+ end if
+c
+c --- It is conceivable that rounding errors will in borderline cases
+c --- throw the calculated table indices for Ri off by one.
+c --- Check and allow moving one to either side to take care of this.
+ if((abs(ribtbl(lri1))).lt.(abs(ri))) then
+ lri1 = lri1 + sign(1,lri1)
+ else if((abs(ribtbl(lri1-sign(1,lri1)))).gt.(abs(ri))) then
+ lri1 = lri1 - sign(1,lri1)
+ end if
+c
+c --- Make lri0 one less or greater than lri1 according to sgn(ri).
+ lri0 = lri1 - nint(sign(float(1),ri))
+c
+ if(ri.eq.0.0) lri1 = 1
+ 272 continue
+c
+c --- check that the Ri_d value falls within the interpolation interval.
+ if((ri.gt.0.0.and.(ri.lt.ribtbl(lri0).or.ri.gt.ribtbl(lri1)))
+ & .or.(ri.lt.0.0.and.(ri.gt.ribtbl(lri0)
+ & .or.ri.lt.ribtbl(lri1)))) then
+ if (mnproc.eq.1) then
+ WRITE(lp,*) "Ri is outside interpolation range in interp2d_e."
+ WRITE(lp,*) "ri= ",ri,"lri0= ",lri0,"lri1= ",lri1
+ WRITE(lp,*) "ribtbl(lri0)= ",ribtbl(lri0),
+ & " ribtbl(lri1)= ",ribtbl(lri1)
+ WRITE(lp,*) "Program is stopping."
+ endif !1st proc
+ call xcstop('(interp2d_expabs)')
+ stop '(interp2d_expabs)'
+ end if
+c
+c --- interpolate turbulence fields and introduce table spacing variables.
+ deltaridta = ridb(lrid1) - ridb(lrid0)
+ deltarita = ribtbl(lri1) - ribtbl(lri0)
+ deltarid = rid - ridb(lrid0)
+ deltari = ri - ribtbl(lri0)
+c
+c --- set delta field to zero in special cases falling at limit of the table.
+ if(lrid1.eq.lrid0) then
+ dslq2_rid = 0.0
+ else
+ dslq2_rid = (slq2b(lri0,lrid1) - slq2b(lri0,lrid0))/
+ & deltaridta
+ end if
+ if(lri1.eq.lri0) then
+ dslq2_ri = 0.0
+ else
+ dslq2_ri = (slq2b(lri1,lrid0) - slq2b(lri0,lrid0))/
+ & deltarita
+ end if
+ slq2 = slq2b(lri0,lrid0) + dslq2_ri*deltari + dslq2_rid*deltarid
+c
+c --- sm
+ if(lrid1.eq.lrid0) then
+ dsm_rid = 0.0
+ else
+ dsm_rid = (smb(lri0,lrid1) - smb(lri0,lrid0))/
+ & deltaridta
+ end if
+ if(lri1.eq.lri0) then
+ dsm_ri = 0.0
+ else
+ dsm_ri = (smb(lri1,lrid0) - smb(lri0,lrid0))/
+ & deltarita
+ end if
+ sm = smb(lri0,lrid0) +
+ & dsm_ri*deltari + dsm_rid*deltarid
+c
+c --- sh
+ if(lrid1.eq.lrid0) then
+ dsh_rid = 0.0
+ else
+ dsh_rid = (shb(lri0,lrid1) - shb(lri0,lrid0))/
+ & deltaridta
+ end if
+ if(lri1.eq.lri0) then
+ dsh_ri = 0.0
+ else
+ dsh_ri = (shb(lri1,lrid0) - shb(lri0,lrid0))/
+ & deltarita
+ end if
+ sh = shb(lri0,lrid0) +
+ & dsh_ri*deltari + dsh_rid*deltarid
+c
+c --- ss
+ if(lrid1.eq.lrid0) then
+ dss_rid = 0.0
+ else
+ dss_rid = (ssb(lri0,lrid1) - ssb(lri0,lrid0))/
+ & deltaridta
+ end if
+ if(lri1.eq.lri0) then
+ dss_ri = 0.0
+ else
+ dss_ri = (ssb(lri1,lrid0) - ssb(lri0,lrid0))/
+ & deltarita
+ end if
+c
+ ss = ssb(lri0,lrid0) +
+ & dss_ri*deltari + dss_rid*deltarid
+c
+ return
+ end
+c
+c> Revision history:
+c>
diff --git a/src_2.2.18_3_one/inikpp.f b/src_2.2.18_3_one/inikpp.f
new file mode 100755
index 0000000..d2313ed
--- /dev/null
+++ b/src_2.2.18_3_one/inikpp.f
@@ -0,0 +1,84 @@
+ subroutine inikpp
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer nzehat,nustar
+ parameter (nzehat=890,nustar=192)
+c
+ real, dimension (0:nzehat+1,0:nustar+1) ::
+ & wmt ! momentum velocity scale table
+ &,wst ! scalar velocity scale table
+ common/kppltr/ wmt,wst
+ save /kppltr/
+c
+c -------------------------------------------------------------------
+c --- initialize large, mc williams, doney kpp vertical mixing scheme
+c -------------------------------------------------------------------
+c
+ integer i,j
+ real zehat,zeta,am,cm,c22,zetam,as,c33,zetas,usta
+c
+ data am,cm,c22,zetam/1.257,8.380,16.0,-0.2/
+ data as,c33,zetas/-28.86,16.0,-1.0/
+c
+ include 'stmt_fns.h'
+c
+c --- 'vonk' = von karman constant
+c --- 'zmin,zmax' = zehat limits for velocity scale lookup table, m**3/s**3
+c --- 'umin,umax' = ustar limits for velocity scale lookup table
+c --- 'epsilon' = vertical coordinate scale factor
+c
+ vonk = 0.4
+ zmin = -0.4e-6
+ zmax = 0.0
+ umin = 0.0
+ umax = 0.16
+ epsilon= 0.1
+c
+c --- construct the velocity-scale lookup tables
+c
+ deltaz = (zmax-zmin)/(nzehat+1)
+ deltau = (umax-umin)/(nustar+1)
+c
+ do i=0,nzehat+1
+ zehat=deltaz*i+zmin
+ do j=0,nustar+1
+ usta=deltau*j+umin
+ zeta=zehat/(usta**3+epsil)
+ if (zehat.ge.0.) then
+ wmt(i,j)=vonk*usta/(1.+c11*zeta)
+ wst(i,j)=wmt(i,j)
+ else
+ if (zeta.gt.zetam) then
+ wmt(i,j)=vonk*usta*(1.-c22*zeta)**afourth
+ else
+ wmt(i,j)=vonk*(am*usta**3-cm*zehat)**athird
+ endif
+ if (zeta.gt.zetas) then
+ wst(i,j)=vonk*usta*(1.-c33*zeta)**ahalf
+ else
+ wst(i,j)=vonk*(as*usta**3-cs*zehat)**athird
+ endif
+ endif
+ enddo
+ enddo
+c
+c --- set derived constants
+ vtc=sqrt(.2/cs/epsilon)/vonk**2/ricr
+ cg=cstar*vonk*(cs*vonk*epsilon)**athird
+ dp0enh=2.0*dp00
+c
+ qdif0 =difm0 /difs0
+ qdifiw=difmiw/difsiw
+c
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> May 2001 - increased nustar and umax by a factor of 4
diff --git a/src_2.2.18_3_one/inimy.f b/src_2.2.18_3_one/inimy.f
new file mode 100755
index 0000000..3a1f5dd
--- /dev/null
+++ b/src_2.2.18_3_one/inimy.f
@@ -0,0 +1,65 @@
+ subroutine inimy
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c -------------------------------------------------------------
+c --- initialize mellor-yamada level 2.5 vertical mixing scheme
+c -------------------------------------------------------------
+c
+ integer i,j,k
+c
+ include 'stmt_fns.h'
+c
+ a1my = 0.92
+ b1my = 16.6
+ a2my = 0.74
+ b2my = 10.1
+ c1my = 0.08
+c
+ e1my = 1.8
+ e2my = 1.33
+ e3my = 1.0
+ sef = 1.0
+ smll = 1.e-8
+c
+c --- 'vonk' = von karman constant
+c --- 'ghc' = constant for calculating tke production
+c --- 'coef4','coef5' = coefficients for estimating viscosity/diffusivity
+c --- 'const1' = constant for estimating surface and bottom bc's
+c
+ vonk = 0.4
+ ghc = -6.0
+ coef4 = 18.*a1my*a1my+9.*a1my*a2my
+ coef5 = 9.*a1my*a2my
+ const1 = 16.6**.6666667*sef
+c
+ do j=1,jdm
+ do i=1,idm
+ do k=0,kdm+1
+ q2(i,j,k,1)=smll
+ q2(i,j,k,2)=smll
+ q2l(i,j,k,1)=smll
+ q2l(i,j,k,2)=smll
+ vctymy(i,j,k)=difmiw
+ diftmy(i,j,k)=difsiw
+ difqmy(i,j,k)=difsiw
+ enddo
+ do k=1,kdm+1
+ vcty(i,j,k)=difmiw
+ dift(i,j,k)=difsiw
+ difs(i,j,k)=difsiw
+c --- no nonlocal forcing
+ ghats(i,j,k)=0.0
+ enddo
+ enddo
+ enddo
+ return
+ end
+c
+c
+c> Revision history:
+c>
diff --git a/src_2.2.18_3_one/isnan.F b/src_2.2.18_3_one/isnan.F
new file mode 100755
index 0000000..e1e9025
--- /dev/null
+++ b/src_2.2.18_3_one/isnan.F
@@ -0,0 +1,13 @@
+ logical function hycom_isnaninf(a)
+ implicit none
+c
+ real a
+c
+c**********
+c*
+c 1) return .true. if a is NaN or +Inf or -Inf.
+c*
+c**********
+c
+ hycom_isnaninf = .not. (a.ge.-huge(a) .and. a.le.huge(a))
+ end
diff --git a/src_2.2.18_3_one/latbdy.f b/src_2.2.18_3_one/latbdy.f
new file mode 100755
index 0000000..f5deb10
--- /dev/null
+++ b/src_2.2.18_3_one/latbdy.f
@@ -0,0 +1,2795 @@
+ subroutine latbdf(n,lll)
+ use mod_xc ! HYCOM communication interface
+ use mod_tides ! HYCOM tides
+ implicit none
+ include 'common_blocks.h'
+c
+ integer n,lll
+c
+c --- apply lateral boundary conditions to barotropic flow field
+c
+c --- port flow version:
+c --- NOT similar to the standard 'Browning and Kreiss' MICOM/HYCOM open
+c --- boundary condition. This version uses algorithms based on a
+c --- 1 invariant Flather boundary condition (setting the gradient
+c --- of the incoming characteristic to zero).
+c
+c --- The tangential velocity is not constrained.
+c
+c --- see also: latbdp
+c
+c --- the code is as similar as possible to that for the standard case.
+c --- so for example, 'speed' is in fact 1/SQRT(gH) which represents
+c --- c1/g in the notation of (Bleck and Sun, Open boundary conditions
+c --- for MICOM). The 1/g allows for the use of pressure fields.
+c
+c --- Note that East, West, North and South refers to the grid
+c --- (i.e i,j points) and NOT geographic East, West, North and South
+c
+c --- the first call is made during initialization.
+c
+c --- Iris Lohmann, Carlos Lozano, NCEP, April 2006
+c
+ logical, parameter :: ldebug_latbdf=.false.
+c
+ integer, parameter :: mports=9 !maximum number of ports
+c
+ integer, parameter :: nchar =120
+c
+ logical lfatal,lfatalp
+ integer i,j,isec,ifrst,ilast,l
+ real aline(nchar),
+ & dline(itdm+jtdm),xline(itdm+jtdm),
+ & pline(itdm+jtdm),uline(itdm+jtdm)
+
+ real sum,svspin,fatal
+ character*3 char3
+c
+ integer nports
+ integer lnport(mports),kdport(mports)
+ integer jfport(mports),jlport(mports),
+ & ifport(mports),ilport(mports)
+ real svpnow(mports),svport(mports)
+
+ save lnport
+ save svpnow,svport
+ save nports,kdport,ifport,ilport,jfport,jlport
+c
+ real uportw(jtdm,mports),speedw(jtdm,mports),rspedw(jtdm,mports),
+ & uporte(jtdm,mports),speede(jtdm,mports),rspede(jtdm,mports),
+ & vportn(itdm,mports),speedn(itdm,mports),rspedn(itdm,mports),
+ & vports(itdm,mports),speeds(itdm,mports),rspeds(itdm,mports)
+ save uportw,speedw,rspedw,uporte,speede,rspede,
+ & vportn,speedn,rspedn,vports,speeds,rspeds
+
+c tides stuff
+
+ integer npts_p,kdpt_p(mports),
+ & ifpt_p(mports),ilpt_p(mports),
+ & jfpt_p(mports),jlpt_p(mports),lnpt_p(mports)
+ integer npts_v,kdpt_v(mports),
+ & ifpt_v(mports),ilpt_v(mports),
+ & jfpt_v(mports),jlpt_v(mports),lnpt_v(mports)
+ integer npts_u,kdpt_u(mports),
+ & ifpt_u(mports),ilpt_u(mports),
+ & jfpt_u(mports),jlpt_u(mports),lnpt_u(mports)
+
+c the max of itdm and jtdm is ok for any port
+c number of tidal consituents (ncon) from mod_tides
+ real z1r_p(mports,max(jtdm,itdm),ncon)
+ real z1i_p(mports,max(jtdm,itdm),ncon)
+ real z1r_u(mports,max(jtdm,itdm),ncon)
+ real z1i_u(mports,max(jtdm,itdm),ncon)
+ real z1r_v(mports,max(jtdm,itdm),ncon)
+ real z1i_v(mports,max(jtdm,itdm),ncon)
+ real tmp1, tmp2
+
+ real tmpr(max(itdm,jtdm),ncon), tmpi(max(itdm,jtdm),ncon)
+
+ real upred(max(itdm,jtdm)),zpred(max(itdm,jtdm))
+ real udpred(max(itdm,jtdm))
+ real vpred(max(itdm,jtdm))
+ real ulow(max(itdm,jtdm),mports),plow(max(itdm,jtdm),mports)
+ real uu(max(itdm,jtdm)),vv(max(itdm,jtdm))
+ integer bnd_init(mports)
+
+ real*8 d_time
+ real*8 timermp,frmp
+ logical astroflag
+ integer jn,in,ic
+
+ save z1r_p, z1i_p
+ save z1r_u, z1i_u
+ save bnd_init
+ save ulow,plow
+c
+ character*13 fmt
+ save fmt
+ data fmt / '(i4,1x,120i1)' /
+c
+c USER-INPUT: optimization coefficients for the 1 inv algorithm.
+ real w_1,w_1c
+ save w_1
+ data w_1 / 0.1 /
+c
+ integer lcount
+ save lcount
+ data lcount / 0 /
+
+c
+c Comment out the next line to run without
+c boundary tides
+ d_time = time_8 + lll*dlt/86400.d0
+
+c add 15384 for obtaining mjd
+ lcount = lcount + 1
+c
+c set 1-invariant coefficient
+ w_1c=1.0-w_1
+c
+c
+c --- the first call just initializes data structures.
+c
+ if (lcount.eq.1) then
+c
+ open(unit=uoff+99,file=trim(flnminp)//'ports.input')
+c
+c --- 'nports' = number of boundary port sections.
+ call blkini(nports,'nports')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ if (nports.lt.0 .or. nports.gt.mports) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdf - illegal nports value'
+ if (nports.gt.mports) then
+ write(lp,*) 'increase parameter mports to',nports
+ endif
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+c
+c --- read in the ports one at a time
+c
+ do l= 1,nports
+c
+c --- port location is w.r.t. u (EW) or v (NS) grid
+c --- and identifies the sea at the port
+c --- the minimum index is 0
+c
+c --- 'kdport' = port orientation (1=N, 2=S, 3=E, 4=W, 5=S(Fundy))
+c --- 'ifport' = first i-index
+c --- 'ilport' = last i-index (=ifport for N or S orientation)
+c --- 'jfport' = first j-index
+c --- 'jlport' = last j-index (=jfport for E or W orientation)
+c --- 'svpnow' = existing port transport in Sv (+ve towards E or S)
+c --- 'svport' = target port transport in Sv (+ve towards E or S)
+c --- 'lnport' = port length (calculated, not input)
+ call blkini(kdport(l),'kdport')
+ call blkini(ifport(l),'ifport')
+ call blkini(ilport(l),'ilport')
+ call blkini(jfport(l),'jfport')
+ call blkini(jlport(l),'jlport')
+ call blkinr(svpnow(l),'svpnow','(a6," =",f10.4," Sv")')
+ call blkinr(svport(l),'svport','(a6," =",f10.4," Sv")')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+c
+ lnport(l) = ilport(l)-ifport(l)+jlport(l)-jfport(l)+1
+c
+c --- sanity check.
+c
+ if (kdport(l).eq.3.or.kdport(l).eq.4) then
+ if (ifport(l).ne.ilport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ else
+ if (jfport(l).ne.jlport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ endif
+ if (ifport(l).gt.ilport(l) .or.
+ & jfport(l).gt.jlport(l) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port',
+ & ' location is not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ enddo
+c
+ close(unit=uoff+99)
+
+c **********************************************
+
+c------ read low frequency input-file
+
+c initialize the low-frequency u and eta to zero
+
+ do i = 1,max(itdm,jtdm)
+ do j = 1,mports
+ ulow(i,j) =0.0
+ plow(i,j) =0.0
+ enddo
+ enddo
+
+ open(unit=uoff+99,file=trim(flnminp)//'lowfreq.input')
+
+c the file is read in order west, east, south, north
+
+ do l= 1,nports
+
+ if (kdport(l).eq.4) then
+c western port
+ do j= jfport(l),jlport(l)
+ read(uoff+99,*) ulow(j,l),plow(j,l)
+ enddo
+ elseif (kdport(l).eq.3) then
+c eastern port
+ do j= jfport(l),jlport(l)
+ read(uoff+99,*) ulow(j,l),plow(j,l)
+ enddo
+ elseif (kdport(l).eq.2) then
+c southern port
+ do i= ifport(l),ilport(l)
+ read(uoff+99,*) ulow(i,l),plow(i,l)
+ enddo
+ elseif (kdport(l).eq.1) then
+c northern port
+ do i= ifport(l),ilport(l)
+ read(uoff+99,*) ulow(i,l),plow(i,l)
+ enddo
+ endif !kdport
+
+ enddo !l=1,nports
+
+ close(uoff+99)
+
+c************************************************
+c ****** READ TIDAL CONSTITUENTS ****************
+
+ if (tidflg.ge.1) then
+
+
+c initialize the tidal constituents to zero
+
+ do i = 1,mports
+ do j = 1,max(itdm,jtdm)
+ do ic = 1,ncon
+ z1r_p(i,j,ic) = 0.
+ z1i_p(i,j,ic) = 0.
+ z1r_u(i,j,ic) = 0.
+ z1i_u(i,j,ic) = 0.
+ z1r_v(i,j,ic) = 0.
+ z1i_v(i,j,ic) = 0.
+ enddo
+ enddo
+ enddo
+
+
+ do j = 1,max(itdm,jtdm)
+ uu(j) = 0.
+ vv(j) = 0.
+ upred(j) = 0.
+ vpred(j) = 0.
+ zpred(j) = 0.
+ enddo
+
+c --------------------------------------------------------
+
+c Now the P points
+
+ open(unit=uoff+99,file=trim(flnminp)//'tidalports_p.input')
+
+c --- 'nports' = number of boundary port sections.
+ call blkini(npts_p,'npts_p')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+
+ if (npts_p.ne.nports) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error number of ports needs to be same'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+
+ do l= 1,nports
+c
+c --- port location is w.r.t. u (EW) or v (NS) grid
+c --- and identifies the sea at the port
+c --- the minimum index is 0
+c
+c --- 'kdport' = port orientation (1=N, 2=S, 3=E, 4=W, 5=Fundy(S))
+c --- 'ifport' = first i-index
+c --- 'ilport' = last i-index (=ifport for N or S orientation)
+c --- 'jfport' = first j-index
+c --- 'jlport' = last j-index (=jfport for E or W orientation)
+c --- 'lnport' = port length (calculated, not input)
+
+
+ call blkini(kdpt_p(l),'kdpt_p')
+
+ if (kdpt_p(l).ne.kdport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the kdport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(ifpt_p(l),'ifpt_p')
+
+ if (ifpt_p(l).ne.ifport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the ifport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(ilpt_p(l),'ilpt_p')
+ if (ilpt_p(l).ne.ilport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the ilport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(jfpt_p(l),'jfpt_p')
+
+ if (jfpt_p(l).ne.jfport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the jfport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+
+ call blkini(jlpt_p(l),'jlpt_p')
+
+ if (jlpt_p(l).ne.jlport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the jlport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ do j= jfport(l),jlport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_p(l,j,ic) = tmp1
+ z1i_p(l,j,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+
+ do j= jfport(l),jlport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_p(l,j,ic) = tmp1
+ z1i_p(l,j,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ do i= ifport(l),ilport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_p(l,i,ic) = tmp1
+ z1i_p(l,i,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ do i= ifport(l),ilport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_p(l,i,ic) = tmp1
+ z1i_p(l,i,ic) = tmp2
+ enddo
+ enddo
+
+ endif !kdport=
+
+c Close the l = 1, nports loop
+ enddo !nports
+
+ close(uoff+99)
+
+c -------------------------------------------------------------
+c Now the normal-velocity points
+
+
+ open(unit=uoff+99,file=trim(flnminp)//'tidalports_v.input')
+
+c --- 'nports' = number of boundary port sections.
+ call blkini(npts_u,'npts_u')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+
+ if (npts_u.ne.nports) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error number of ports needs to be same'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+ do l= 1,nports
+c
+c --- port location is w.r.t. u (EW) or v (NS) grid
+c --- and identifies the sea at the port
+c --- the minimum index is 0
+c
+c --- 'kdport' = port orientation (1=N, 2=S, 3=E, 4=W, 5=Fundy(S))
+c --- 'ifport' = first i-index
+c --- 'ilport' = last i-index (=ifport for N or S orientation)
+c --- 'jfport' = first j-index
+c --- 'jlport' = last j-index (=jfport for E or W orientation)
+c --- 'svpnow' = existing port transport in Sv (+ve towards E or S)
+c --- 'svport' = target port transport in Sv (+ve towards E or S)
+c --- 'lnport' = port length (calculated, not input)
+
+
+
+ call blkini(kdpt_u(l),'kdpt_u')
+
+ if (kdpt_u(l).ne.kdport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the kdport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(ifpt_u(l),'ifpt_u')
+
+ if (ifpt_u(l).ne.ifport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the ifport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(ilpt_u(l),'ilpt_u')
+ if (ilpt_u(l).ne.ilport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the ilport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(jfpt_u(l),'jfpt_u')
+
+ if (jfpt_u(l).ne.jfport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the jfport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ call blkini(jlpt_u(l),'jlpt_u')
+
+ if (jlpt_u(l).ne.jlport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'Mismatch of the jlport'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+
+
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+
+ do j= jfport(l),jlport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_u(l,j,ic) = tmp1
+ z1i_u(l,j,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+
+ do j= jfport(l),jlport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_u(l,j,ic) = tmp1
+ z1i_u(l,j,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ do i= ifport(l),ilport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_u(l,i,ic) = tmp1
+ z1i_u(l,i,ic) = tmp2
+ enddo
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ do i= ifport(l),ilport(l)
+ do ic = 1, ncon
+ read(uoff+99,*) tmp1, tmp2
+ z1r_u(l,i,ic) = tmp1
+ z1i_u(l,i,ic) = tmp2
+ enddo
+ enddo
+
+ endif !kdport=
+
+c Close the l = 1, nports loop
+ enddo !nports
+
+ close(uoff+99)
+
+c*****************END OF READING THE TIDAL CONSTITUENTS
+ endif !tidflg.ge.1
+
+c
+c --- check ports against masks,
+c --- mark the port locations on masks and print them out.
+c
+ lfatal = .false.
+ do l= 1,nports
+ lfatalp = .false.
+c
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.1 .or. i.gt.itdm-2 .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0+1,j-j0).ne.1 .or.
+ & iu(i-i0+2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.3 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0-1,j-j0).ne.1 .or.
+ & iu(i-i0-2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.3 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0-1).ne.1 .or.
+ & iv(i-i0,j-j0-2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2.or.kdport(l).eq.5) then
+c
+c southern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm-2 ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0+1).ne.1 .or.
+ & iv(i-i0,j-j0+2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ endif !kdport=
+c
+ if (lfatalp) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port ',l,' mislocated',
+ & ' (mnproc = ',mnproc,')'
+ write(lp,*)
+ call flush(lp)
+ endif
+ lfatal = lfatal .or. lfatalp
+
+ enddo !nports
+c
+c local lfatal to global lfatal
+c
+ if (lfatal) then
+ fatal = 1.0
+ else
+ fatal = 0.0
+ endif
+ call xcmaxr(fatal)
+ lfatal = fatal.gt.0.5
+c
+c --- write out -iu- and -iv- arrays, if they are not too big
+c --- data are written in strips nchar points wide
+ if (lfatal .or. max(itdm,jtdm).le.2*nchar) then
+ util1(1:ii,1:jj) = iu(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iu array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+ util1(1:ii,1:jj) = iv(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iv array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+ endif ! small region
+c
+ if (lfatal) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - bad port(s)'
+ write(lp,*)
+ call flush(lp)
+ call xchalt('(latbdp)')
+ stop '(latbdp)'
+ endif
+c
+c --- restore iu and iv, and zero iuopn and ivopn.
+c
+! $OMP PARALLEL DO PRIVATE(j,i)
+! $OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ iu(i,j) = max( iu(i,j), 0 )
+ iv(i,j) = max( iv(i,j), 0 )
+ enddo
+ enddo
+! $OMP PARALLEL DO PRIVATE(j,i)
+! $OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ iuopn(i,j) = 0
+ ivopn(i,j) = 0
+ enddo
+ enddo
+
+c
+c --- initialize the ports
+c
+ do l= 1,nports
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ sum = 0.0
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(dline(j),lnport(l), depths,i,j,0,1, 0)
+ call xclget(xline(j),lnport(l), scuy, i, j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ sum = sum + dline(j)*xline(j)
+ enddo
+ sum = 1.e6/sum
+ do j= jfport(l),jlport(l)
+ uportw(j,l) = sum
+ speedw(j,l) = sqrt(1.0*thref/(onem*dline(j)))
+ rspedw(j,l) = 1.0/speedw(j,l)
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ iuopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ sum = 0.0
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(dline(j),lnport(l), depths,i, j,0,1, 0)
+ call xclget(xline(j),lnport(l), scuy, i+1,j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ sum = sum + dline(j)*xline(j)
+ enddo
+ sum = 1.e6/sum
+ do j= jfport(l),jlport(l)
+ uporte(j,l) = sum
+ speede(j,l) = sqrt(1.0*thref/(onem*dline(j)))
+ rspede(j,l) = 1.0/speede(j,l)
+ if (i+1.ge.i0+ 1-nbdy .and.
+ & i+1.le.i0+ii+nbdy .and.
+ & j .ge.j0+ 1-nbdy .and.
+ & j .le.j0+jj+nbdy ) then
+ iuopn(i-i0+1,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ sum = 0.0
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(dline(i),lnport(l), depths,i,j, 1,0, 0)
+ call xclget(xline(i),lnport(l), scuy, i,j+1,1,0, 0)
+ do i= ifport(l),ilport(l)
+ sum = sum + dline(i)*xline(i)
+ enddo
+ sum = 1.e6/sum
+ do i= ifport(l),ilport(l)
+ vportn(i,l) = sum
+ speedn(i,l) = sqrt(1.0*thref/(onem*dline(i)))
+ rspedn(i,l) = 1.0/speedn(i,l)
+ if (i .ge.i0+ 1-nbdy .and.
+ & i .le.i0+ii+nbdy .and.
+ & j+1.ge.j0+ 1-nbdy .and.
+ & j+1.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0+1) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2.or.kdport(l).eq.5) then
+c
+c southern port
+c
+ sum = 0.0
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(dline(i),lnport(l), depths,i,j,1,0, 0)
+ call xclget(xline(i),lnport(l), scuy, i,j, 1,0, 0)
+ do i= ifport(l),ilport(l)
+ sum = sum + dline(i)*xline(i)
+ enddo
+ sum = 1.e6/sum
+ do i= ifport(l),ilport(l)
+ vports(i,l) = sum
+ speeds(i,l) = sqrt(1.0*thref/(onem*dline(i)))
+ rspeds(i,l) = 1.0/speeds(i,l)
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ endif
+c
+ enddo !nports
+
+ if (mnproc.eq.1) then
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c end of initialization
+c
+ call xcsync(flush_lp)
+ return
+ endif !lcount=1
+c
+c --- 'wellposed' treatment of pressure and normal velocity fields
+c --- not in fact wellposed with this exterior data
+c
+c --- set ramping factor
+c when ramp_time=0:no ramping of tide (=full tide)
+c when ramp_time>0: ramping of tide, if...
+c ...ramp_orig<=timermp<=(ramp_orig+ramp_time)
+ if(ramp_time.gt.0.0 ) then
+ timermp=d_time
+ if(timermp.ge.ramp_orig)then
+ timermp=(timermp-ramp_orig)/ramp_time
+c frmp=(1-exp(-10*timermp))
+ frmp=(1-exp(-5*timermp))
+ else
+ frmp=0.0
+ endif
+ else
+ frmp=1.0
+ endif
+
+c
+ do l=1,nports
+
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(dline(j), lnport(l),
+ & depthu, i,j,0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+ call xclget(uline(j),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j,0,1, 0)
+
+
+ if (tidflg.ge.1) then !tide
+
+ do jn= jfport(l),jlport(l)
+ do ic = 1, ncon
+ tmpr(jn,ic) = z1r_u(l,jn,ic)
+ tmpi(jn,ic) = z1i_u(l,jn,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,uu,j,max(itdm,jtdm),lnport(l)) !normal
+
+c Note!! uu and vv from tpx are transports
+ do jn= jfport(l),jlport(l)
+ upred(jn)=uu(jn)*frmp*onem/dline(jn)
+ enddo
+
+ do jn= jfport(l),jlport(l)
+ do ic = 1, ncon
+ tmpr(jn,ic) = z1r_p(l,jn,ic)
+ tmpi(jn,ic) = z1i_p(l,jn,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,zpred,j,max(itdm,jtdm),lnport(l))
+
+ do j= jfport(l),jlport(l)
+ zpred(j)=zpred(j)*onem*frmp
+ enddo
+
+
+ do j= jfport(l),jlport(l)
+c ----set both u and eta at boundary; 1 invariant weighted:
+ uline(j)=ulow(j,l)+upred(j)
+ & +w_1*speedw(j,l)*((plow(j,l)+zpred(j))-pline(j))
+ pline(j)=w_1c*(plow(j,l)+zpred(j))+w_1*pline(j)
+
+ enddo
+
+
+ else !no bnd-tide
+
+
+ do j= jfport(l),jlport(l)
+c ---- set both u and eta; 1 invariant weighted:
+ uline(j)=ulow(j,l)+
+ & w_1*speedw(j,l)*(plow(j,l)-pline(j))
+ pline(j)=w_1c*plow(j,l)+w_1*pline(j)
+
+
+ enddo
+
+ endif !tide/no tide
+
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1)
+ call xclput(uline(j),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j,0,1)
+c
+
+ elseif (kdport(l).eq.3) then
+
+c eastern port
+c
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(dline(j), lnport(l),
+ & depthu, i+1,j,0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+ call xclget(uline(j),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+
+
+ if (tidflg.ge.1) then !tide
+
+ do jn= jfport(l),jlport(l)
+ do ic = 1, ncon
+ tmpr(jn,ic) = z1r_u(l,jn,ic)
+ tmpi(jn,ic) = z1i_u(l,jn,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,uu,j,max(itdm,jtdm),lnport(l)) !normal
+
+c Note!! uu and vv from tpx are transports
+ do jn= jfport(l),jlport(l)
+ upred(jn)=uu(jn)*frmp*onem/dline(jn)
+ enddo
+
+ do jn= jfport(l),jlport(l)
+ do ic = 1, ncon
+ tmpr(jn,ic) = z1r_p(l,jn,ic)
+ tmpi(jn,ic) = z1i_p(l,jn,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,zpred,j,max(itdm,jtdm),lnport(l))
+
+
+ do j= jfport(l),jlport(l)
+ zpred(j) = zpred(j)*onem*frmp
+ enddo
+
+ do j= jfport(l),jlport(l)
+c ----set u and eta on boundary; 1 invariant weighted:
+ uline(j)=ulow(j,l)+upred(j)
+ & +w_1*speede(j,l)*(pline(j)-(plow(j,l)+zpred(j)))
+ pline(j)=w_1c*(plow(j,l)+zpred(j))+w_1*pline(j)
+ enddo
+
+
+ else !no bnd-tide
+
+
+ do j= jfport(l),jlport(l)
+c ----set u and eta on boundary; 1 invariant weighted:
+ uline(j)=ulow(j,l)
+ & -w_1*speede(j,l)*(plow(j,l)-pline(j))
+ pline(j)=w_1c*plow(j,l)+w_1*pline(j)
+ enddo
+
+ endif !tide/no tide
+
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1)
+ call xclput(uline(j),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j,0,1)
+
+
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(dline(i), lnport(l),
+ & depthv, i,j+1,1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+ call xclget(uline(i),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+
+
+ if (tidflg.ge.1) then !tide
+
+ do in= ifport(l),ilport(l)
+ do ic = 1, ncon
+ tmpr(in,ic) = z1r_u(l,in,ic)
+ tmpi(in,ic) = z1i_u(l,in,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,uu,i,max(itdm,jtdm),lnport(l)) !normal
+
+c Note!! uu and vv from tpx are transports
+ do in= ifport(l),ilport(l)
+ vpred(in)=uu(in)*frmp*onem/dline(in)
+ enddo
+
+ do in= ifport(l),ilport(l)
+ do ic = 1, ncon
+ tmpr(in,ic) = z1r_p(l,in,ic)
+ tmpi(in,ic) = z1i_p(l,in,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,zpred,i,max(itdm,jtdm),lnport(l))
+
+ do i= ifport(l),ilport(l)
+ zpred(i) =zpred(i)*onem*frmp
+ enddo
+
+ do i= ifport(l),ilport(l)
+c ----set u and eta at boundary; 1 invariant weighted:
+ uline(i)=ulow(i,l)+vpred(i)
+ & +w_1*speedn(i,l)*(pline(i)-(plow(i,l)+zpred(i)))
+ pline(i)=w_1c*(plow(i,l)+zpred(i))+w_1*pline(i)
+ enddo
+
+ else !no bnd-tide
+
+ do i= ifport(l),ilport(l)
+c ----set u and eta at boundary; 1 invariant weighted:
+ uline(i)=ulow(i,l)-
+ & w_1*speedn(i,l)*(plow(i,l)-pline(i))
+ pline(i)=w_1c*plow(i,l)+w_1*pline(i)
+ enddo
+
+ endif !tide/no-tide
+
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+ call xclput(uline(i),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j+1,1,0)
+c
+
+ elseif (kdport(l).eq.2.or.kdport(l).eq.5) then
+c
+c southern port
+c
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(dline(i), lnport(l),
+ & depthv, i,j, 1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+ call xclget(uline(i),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j+1,1,0, 0)
+
+
+ if (tidflg.ge.1) then !tide
+
+ do in= ifport(l),ilport(l)
+ do ic = 1, ncon
+ tmpr(in,ic) = z1r_u(l,in,ic)
+ tmpi(in,ic) = z1i_u(l,in,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,uu,i,max(itdm,jtdm),lnport(l)) !normal
+
+c Note!! uu and vv from tpx are transports
+ do in= ifport(l),ilport(l)
+ vpred(in)=uu(in)*frmp*onem/dline(in)
+ enddo
+
+ do in= ifport(l),ilport(l)
+ do ic = 1, ncon
+ tmpr(in,ic) = z1r_p(l,in,ic)
+ tmpi(in,ic) = z1i_p(l,in,ic)
+ enddo
+ enddo
+
+ call tides_driver(tmpr,tmpi,d_time,
+ & astroflag,zpred,i,max(itdm,jtdm),lnport(l))
+
+ do i= ifport(l),ilport(l)
+ zpred(i) = zpred(i)*onem*frmp
+ enddo
+
+ do i= ifport(l),ilport(l)
+c ----set u and eta at boundary; 1 invariant weighted:
+ uline(i)=ulow(i,l)+vpred(i)
+ & +w_1*speeds(i,l)*(pline(i)-(plow(i,l)+zpred(i)))
+ pline(i)=w_1c*(plow(i,l)+zpred(i))+w_1*pline(i)
+ enddo
+
+ else !no bnd-tide
+
+ do i= ifport(l),ilport(l)
+c ----set u and eta at boundary; 1 invariant weighted:
+ uline(i)=ulow(i,l)+
+ & w_1*speeds(i,l)*(plow(i,l)-pline(i))
+ pline(i)=w_1c*plow(i,l)+w_1*pline(i)
+ enddo
+
+ endif !tide/no-tide
+
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+ call xclput(uline(i),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+c
+ endif !kdport
+
+ enddo !nports
+c
+ return
+ end
+ subroutine latbdp(n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer n
+c
+c --- apply lateral boundary conditions to barotropic flow field
+c
+c --- port flow version:
+c --- similar to the standard 'Browning and Kreiss' MICOM/HYCOM open
+c --- boundary condition, except that the exterior normal velocity
+c --- is constant in time and exterior pressure = interior pressure.
+c --- tangential velocity is not constrained.
+c
+c --- see also: latbdp
+c
+c --- the code is as similar as possible to that for the standard case.
+c --- so for example, 'speed' is in fact 1/SQRT(gH) which represents
+c --- c1/g in the notation of (Bleck and Sun, Open boundary conditions
+c --- for MICOM). The 1/g allows for the use of pressure fields.
+c
+c --- Note that East, West, North and South refers to the grid
+c --- (i.e i,j points) and NOT geographic East, West, North and South
+c
+c --- the first call is made during initialization.
+c
+c --- Alan J. Wallcraft, NRL, November 1999.
+c
+ logical, parameter :: ldebug_latbdp=.false.
+c
+ integer, parameter :: mports=9 !maximum number of ports
+c
+ integer, parameter :: nchar=120
+c
+ logical lfatal,lfatalp
+ integer i,j,isec,ifrst,ilast,l
+ real aline(nchar),
+ & dline(itdm+jtdm),xline(itdm+jtdm),
+ & pline(itdm+jtdm),uline(itdm+jtdm,2)
+ real crs,fin,sum,svspin,uvscl,uvscl2,fatal
+ real*8 tstep
+ character*3 char3
+c
+ integer nports,kdport(mports),
+ & ifport(mports),ilport(mports),
+ & jfport(mports),jlport(mports),lnport(mports)
+ real pefold,svpnow(mports),svport(mports)
+ real*8 refold
+ save nports,kdport,ifport,ilport,jfport,jlport,lnport
+ save pefold,svpnow,svport,refold
+c
+ real uportw(jtdm),speedw(jtdm),rspedw(jtdm),
+ & uporte(jtdm),speede(jtdm),rspede(jtdm),
+ & vportn(itdm),speedn(itdm),rspedn(itdm),
+ & vports(itdm),speeds(itdm),rspeds(itdm)
+ save uportw,speedw,rspedw,uporte,speede,rspede,
+ & vportn,speedn,rspedn,vports,speeds,rspeds
+c
+ character*13 fmt
+ save fmt
+ data fmt / '(i4,1x,120i1)' /
+c
+ integer lcount
+ save lcount
+ data lcount / 0 /
+c
+ lcount = lcount + 1
+c
+c --- the first call just initializes data structures.
+c
+ if (lcount.eq.1) then
+c
+ open(unit=uoff+99,file=trim(flnminp)//'ports.input')
+c
+c --- 'nports' = number of boundary port sections.
+ call blkini(nports,'nports')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ if (nports.lt.0 .or. nports.gt.mports) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - illegal nports value'
+ if (nports.gt.mports) then
+ write(lp,*) 'increase parameter mports to',nports
+ endif
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+c
+c --- 'pefold' = port transport e-folding time in days
+ call blkinr(pefold,'pefold','(a6," =",f10.4," days")')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+c
+c --- switch units from days to baroclinic time steps
+c --- shift lcount to prevent underflow (lcount*refold.ge.0.001)
+c
+ tstep = pefold*(86400.d0/batrop)
+ refold = 1.d0/tstep
+ lcount = lcount + int(tstep)/1000
+c
+c --- read in the ports one at a time
+c
+ do l= 1,nports
+c
+c --- port location is w.r.t. u (EW) or v (NS) grid
+c --- and identifies the sea at the port
+c --- the minimum index is 0
+c
+c --- 'kdport' = port orientation (1=N, 2=S, 3=E, 4=W)
+c --- 'ifport' = first i-index
+c --- 'ilport' = last i-index (=ifport for N or S orientation)
+c --- 'jfport' = first j-index
+c --- 'jlport' = last j-index (=jfport for E or W orientation)
+c --- 'svpnow' = existing port transport in Sv (+ve towards E or S)
+c --- 'svport' = target port transport in Sv (+ve towards E or S)
+c --- 'lnport' = port length (calculated, not input)
+ call blkini(kdport(l),'kdport')
+ call blkini(ifport(l),'ifport')
+ call blkini(ilport(l),'ilport')
+ call blkini(jfport(l),'jfport')
+ call blkini(jlport(l),'jlport')
+ call blkinr(svpnow(l),'svpnow','(a6," =",f10.4," Sv")')
+ call blkinr(svport(l),'svport','(a6," =",f10.4," Sv")')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+c
+ lnport(l) = ilport(l)-ifport(l)+jlport(l)-jfport(l)+1
+c
+c --- sanity check.
+c
+ if (kdport(l).gt.2) then
+ if (ifport(l).ne.ilport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ else
+ if (jfport(l).ne.jlport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ endif
+ if (ifport(l).gt.ilport(l) .or.
+ & jfport(l).gt.jlport(l) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port',
+ & ' location is not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdp)')
+ stop '(latbdp)'
+ endif
+ enddo
+c
+ close(unit=uoff+99)
+c
+c --- check ports against masks,
+c --- mark the port locations on masks and print them out.
+c
+ lfatal = .false.
+ do l= 1,nports
+ lfatalp = .false.
+c
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.1 .or. i.gt.itdm-2 .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0+1,j-j0).ne.1 .or.
+ & iu(i-i0+2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.3 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0-1,j-j0).ne.1 .or.
+ & iu(i-i0-2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.3 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0-1).ne.1 .or.
+ & iv(i-i0,j-j0-2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm-2 ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0+1).ne.1 .or.
+ & iv(i-i0,j-j0+2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ endif
+c
+ if (lfatalp) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - port ',l,' mislocated',
+ & ' (mnproc = ',mnproc,')'
+ write(lp,*)
+ call flush(lp)
+ endif
+ lfatal = lfatal .or. lfatalp
+ enddo
+c
+c local lfatal to global lfatal
+c
+ if (lfatal) then
+ fatal = 1.0
+ else
+ fatal = 0.0
+ endif
+ call xcmaxr(fatal)
+ lfatal = fatal.gt.0.5
+c
+c --- write out -iu- and -iv- arrays, if they are not too big
+c --- data are written in strips nchar points wide
+ if (lfatal .or. max(itdm,jtdm).le.2*nchar) then
+ util1(1:ii,1:jj) = iu(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iu array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+ util1(1:ii,1:jj) = iv(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iv array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+ endif ! small region
+c
+ if (lfatal) then
+ write(lp,*)
+ write(lp,*) 'error in latbdp - bad port(s)'
+ write(lp,*)
+ call flush(lp)
+ call xchalt('(latbdp)')
+ stop '(latbdp)'
+ endif
+c
+c --- restore iu and iv, and zero iuopn and ivopn.
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ iu(i,j) = max( iu(i,j), 0 )
+ iv(i,j) = max( iv(i,j), 0 )
+ enddo
+ enddo
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ iuopn(i,j) = 0
+ ivopn(i,j) = 0
+ enddo
+ enddo
+c
+c --- initialize the ports
+c
+ do l= 1,nports
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ sum = 0.0
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(dline(j),lnport(l), depths,i+1,j,0,1, 0)
+ call xclget(xline(j),lnport(l), scuy, i, j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ sum = sum + dline(j)*xline(j)
+ enddo
+ sum = 1.e6/sum
+ do j= jfport(l),jlport(l)
+ uportw(j) = sum
+ speedw(j) = sqrt(thref/(onem*dline(j)))
+ rspedw(j) = 1.0/speedw(j)
+ if (mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1p2e12.5)')
+ & 'w port: ',l,i,j,uportw(j),speedw(j)
+ endif
+c
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ iuopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ sum = 0.0
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(dline(j),lnport(l), depths,i, j,0,1, 0)
+ call xclget(xline(j),lnport(l), scuy, i+1,j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ sum = sum + dline(j)*xline(j)
+ enddo
+ sum = 1.e6/sum
+ do j= jfport(l),jlport(l)
+ uporte(j) = sum
+ speede(j) = sqrt(thref/(onem*dline(j)))
+ rspede(j) = 1.0/speede(j)
+ if (mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1p2e12.5)')
+ & 'e port: ',l,i,j,uporte(j),speede(j)
+ endif
+c
+ if (i+1.ge.i0+ 1-nbdy .and.
+ & i+1.le.i0+ii+nbdy .and.
+ & j .ge.j0+ 1-nbdy .and.
+ & j .le.j0+jj+nbdy ) then
+ iuopn(i-i0+1,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ sum = 0.0
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(dline(i),lnport(l), depths,i,j, 1,0, 0)
+ call xclget(xline(i),lnport(l), scuy, i,j+1,1,0, 0)
+ do i= ifport(l),ilport(l)
+ sum = sum + dline(i)*xline(i)
+ enddo
+ sum = 1.e6/sum
+ do i= ifport(l),ilport(l)
+ vportn(i) = sum
+ speedn(i) = sqrt(thref/(onem*dline(i)))
+ rspedn(i) = 1.0/speedn(i)
+ if (mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1p2e12.5)')
+ & 'n port: ',l,i,j,vportn(i),speedn(i)
+ endif
+c
+ if (i .ge.i0+ 1-nbdy .and.
+ & i .le.i0+ii+nbdy .and.
+ & j+1.ge.j0+ 1-nbdy .and.
+ & j+1.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0+1) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ sum = 0.0
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(dline(i),lnport(l), depths,i,j+1,1,0, 0)
+ call xclget(xline(i),lnport(l), scuy, i,j, 1,0, 0)
+ do i= ifport(l),ilport(l)
+ sum = sum + dline(i)*xline(i)
+ enddo
+ sum = 1.e6/sum
+ do i= ifport(l),ilport(l)
+ vports(i) = sum
+ speeds(i) = sqrt(thref/(onem*dline(i)))
+ rspeds(i) = 1.0/speeds(i)
+ if (mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1p2e12.5)')
+ & 's port: ',l,i,j,vports(i),speeds(i)
+ endif
+c
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ endif
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'port, now/target velocity = ',
+ & l,svpnow(l)*sum,svport(l)*sum
+ call flush(lp)
+ endif
+ enddo
+ if (mnproc.eq.1) then
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c end of initialization
+c
+ call xcsync(flush_lp)
+ return
+ endif
+c
+c --- 'wellposed' treatment of pressure and normal velocity fields
+c --- not in fact wellposed with this exterior data
+c
+ tstep = lcount
+ svspin = exp( -tstep*refold )
+ do l= 1,nports
+ uvscl = svport(l) + svspin*(svpnow(l)-svport(l))
+c
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(dline(j), lnport(l),
+ & depthu, i+1,j,0,1, 0)
+ call xclget(xline(j), lnport(l),
+ & scuy, i, j,0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+ call xclget(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j,0,1, 0)
+ call xclget(uline(j,2),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+2,j,0,1, 0)
+ sum = 0.0
+ do j= jfport(l),jlport(l)
+ crs=uvscl*uportw(j)+speedw(j)*pline(j)
+ fin=1.5*uline(j,1)-.5*uline(j,2)-speedw(j)*pline(j)
+ sum=sum+((crs+fin)-uline(j,1))*dline(j)*xline(j)
+ enddo
+ uvscl2 = uvscl + (uvscl - sum/(onem*1.e6))
+ sum = 0.0
+ do j= jfport(l),jlport(l)
+ crs=uvscl2*uportw(j)+speedw(j)*pline(j)
+ fin=1.5*uline(j,1)-.5*uline(j,2)-speedw(j)*pline(j)
+ pline(j) =.5*(crs-fin)*rspedw(j)
+ uline(j,1)=(crs+fin)-uline(j,1)
+ sum=sum+uline(j,1)*dline(j)*xline(j)
+ enddo
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1)
+ call xclput(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j,0,1)
+c
+ if (ldebug_latbdp .and. mnproc.eq.1) then
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(pb - ',
+ & l,lnport(l),i, j,0,1
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(ub - ',
+ & l,lnport(l),i, j,0,1
+ call flush(lp)
+ endif
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(dline(j), lnport(l),
+ & depthu, i+1,j,0,1, 0)
+ call xclget(xline(j), lnport(l),
+ & scuy, i+1,j,0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+ call xclget(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j,0,1, 0)
+ call xclget(uline(j,2),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i-1,j,0,1, 0)
+ sum = 0.0
+ do j= jfport(l),jlport(l)
+ crs=uvscl*uporte(j)-speede(j)*pline(j)
+ fin=1.5*uline(j,1)-.5*uline(j,2)+speede(j)*pline(j)
+ sum=sum+((crs+fin)-uline(j,1))*dline(j)*xline(j)
+ enddo
+ uvscl2 = uvscl + (uvscl - sum/(onem*1.e6))
+ sum = 0.0
+ do j= jfport(l),jlport(l)
+ crs=uvscl2*uporte(j)-speede(j)*pline(j)
+ fin=1.5*uline(j,1)-.5*uline(j,2)+speede(j)*pline(j)
+ pline(j) =.5*(fin-crs)*rspede(j)
+ uline(j,1)=(fin+crs)-uline(j,1)
+ sum=sum+uline(j,1)*dline(j)*xline(j)
+* if (mnproc.eq.1) then
+* write(lp,'(a,i2,2i5,1p2e12.5)')
+* & 'e port: ',l,i,j,pline(j),uline(j,1)
+* endif
+ enddo
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j,0,1)
+ call xclput(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j,0,1)
+c
+ if (ldebug_latbdp .and. mnproc.eq.1) then
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(pb - ',
+ & l,lnport(l),i, j,0,1
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(ub - ',
+ & l,lnport(l),i+1,j,0,1
+ call flush(lp)
+ endif
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(dline(i), lnport(l),
+ & depthv, i,j+1,1,0, 0)
+ call xclget(xline(i), lnport(l),
+ & scux, i,j+1,1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+ call xclget(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+ call xclget(uline(i,2),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j-1,1,0, 0)
+ sum = 0.0
+ do i= ifport(l),ilport(l)
+ crs=uvscl*vportn(i)-speedn(i)*pline(i)
+ fin=1.5*uline(i,1)-.5*uline(i,2)+speedn(i)*pline(i)
+ sum=sum+((fin+crs)-uline(i,1))*dline(i)*xline(i)
+ enddo
+ uvscl2 = uvscl + (uvscl - sum/(onem*1.e6))
+ sum = 0.0
+ do i= ifport(l),ilport(l)
+ crs=uvscl2*vportn(i)-speedn(i)*pline(i)
+ fin=1.5*uline(i,1)-.5*uline(i,2)+speedn(i)*pline(i)
+ pline(i) =.5*(fin-crs)*rspedn(i)
+ uline(i,1)=(fin+crs)-uline(i,1)
+ sum=sum+uline(i,1)*dline(i)*xline(i)
+ enddo
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+ call xclput(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j+1,1,0)
+c
+ if (ldebug_latbdp .and. mnproc.eq.1) then
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(pb - ',
+ & l,lnport(l),i,j, 1,0
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(vb - ',
+ & l,lnport(l),i,j+1,1,0
+ call flush(lp)
+ endif
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(dline(i), lnport(l),
+ & depthv, i,j, 1,0, 0)
+ call xclget(xline(i), lnport(l),
+ & scux, i,j, 1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0, 0)
+ call xclget(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j+1,1,0, 0)
+ call xclget(uline(i,2),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j+2,1,0, 0)
+ sum = 0.0
+ do i= ifport(l),ilport(l)
+ crs=uvscl*vports(i)+speeds(i)*pline(i)
+ fin=1.5*uline(i,1)-.5*uline(i,2)-speeds(i)*pline(i)
+ sum=sum+((crs+fin)-uline(i,1))*dline(i)*xline(i)
+ enddo
+ uvscl2 = uvscl + (uvscl - sum/(onem*1.e6))
+ sum = 0.0
+ do i= ifport(l),ilport(l)
+ crs=uvscl2*vports(i)+speeds(i)*pline(i)
+ fin=1.5*uline(i,1)-.5*uline(i,2)-speeds(i)*pline(i)
+ pline(i) =.5*(crs-fin)*rspeds(i)
+ uline(i,1)=(crs+fin)-uline(i,1)
+ sum=sum+uline(i,1)*dline(i)*xline(i)
+ enddo
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+ call xclput(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i,j, 1,0)
+c
+ if (ldebug_latbdp .and. mnproc.eq.1) then
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(pb - ',
+ & l,lnport(l),i,j, 1,0
+ write(lp,'(a,i2,3i5,2i2)') 'l,xclput(vb - ',
+ & l,lnport(l),i,j, 1,0
+ call flush(lp)
+ endif
+c
+ endif
+c
+* if (mod(lcount,512).eq.0) then
+* if (mnproc.eq.1) then
+* write(lp,*) 'latbdp - l,sv,sum = ',l,uvscl,sum/(onem*1.e6)
+* call flush(lp)
+* endif
+* endif
+ enddo
+c
+ return
+ end
+ subroutine latbdt(n,lll)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer n,lll
+c
+c --- apply lateral boundary conditions to barotropic flow field
+c
+c --- nested sub-region version:
+c --- Uses the 'Browning and Kreiss' MICOM open boundary condition.
+c
+c --- Note that 'speed' is in fact thref*SQRT(gH) which represents
+c --- c1*thref/g in the notation of (Bleck and Sun, Open boundary conditions
+c --- for MICOM). The thref/g allows for the use of pressure fields.
+c
+c --- Note that East, West, North and South refers to the grid
+c --- (i.e i,j points) and NOT geographic East, West, North and South
+c
+c --- the first call is made during initialization.
+c
+c --- Alan J. Wallcraft, NRL, July, 2001.
+c
+ logical, parameter :: ldebug_latbdt=.false.
+c
+ integer, parameter :: mports=9 !maximum number of ports
+c
+ integer, parameter :: nchar=120
+c
+ logical lfatal,lfatalp
+ integer i,j,isec,ifrst,ilast,l,npf,npi,npl
+ real aline(nchar),
+ & pline(itdm+jtdm),uline(itdm+jtdm,2)
+ real crs,fin,fatal
+ character*3 char3
+c
+ integer nports,kdport(mports),
+ & ifport(mports),ilport(mports),
+ & jfport(mports),jlport(mports),lnport(mports)
+ save nports,kdport,ifport,ilport,jfport,jlport,lnport
+c
+ real speedw(jtdm),rspedw(jtdm),
+ & speede(jtdm),rspede(jtdm),
+ & speedn(itdm),rspedn(itdm),
+ & speeds(itdm),rspeds(itdm)
+ real plnstw(jtdm),ulnstw(jtdm),vlnstw(jtdm),
+ & plnste(jtdm),ulnste(jtdm),vlnste(jtdm),
+ & plnstn(itdm),ulnstn(itdm),vlnstn(itdm),
+ & plnsts(itdm),ulnsts(itdm),vlnsts(itdm)
+ save speedw,rspedw,plnstw,ulnstw,vlnstw,
+ & speede,rspede,plnste,ulnste,vlnste,
+ & speedn,rspedn,plnstn,ulnstn,vlnstn,
+ & speeds,rspeds,plnsts,ulnsts,vlnsts
+c
+ character*13 fmt
+ save fmt
+ data fmt / '(i4,1x,120i1)' /
+c
+ integer lcount
+ save lcount
+ data lcount / 0 /
+c
+ lcount = lcount + 1
+c
+c --- the first call just initializes data structures.
+c
+ if (lcount.eq.1) then
+c
+ open(unit=uoff+99,file=trim(flnminp)//'ports.input')
+c
+c --- 'nports' = number of boundary port sections.
+ call blkini(nports,'nports')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+ if (nports.lt.0 .or. nports.gt.mports) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - illegal nports value'
+ if (nports.gt.mports) then
+ write(lp,*) 'increase parameter mports to',nports
+ endif
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdt)')
+ stop '(latbdt)'
+ endif
+c
+c --- read in the ports one at a time
+c
+ do l= 1,nports
+c
+c --- port location is w.r.t. u (EW) or v (NS) grid
+c --- and identifies the sea at the port
+c --- the minimum index is 0
+c
+c --- 'kdport' = port orientation (1=N, 2=S, 3=E, 4=W)
+c --- 'ifport' = first i-index
+c --- 'ilport' = last i-index (=ifport for N or S orientation)
+c --- 'jfport' = first j-index
+c --- 'jlport' = last j-index (=jfport for E or W orientation)
+c --- 'lnport' = port length (calculated, not input)
+ call blkini(kdport(l),'kdport')
+ call blkini(ifport(l),'ifport')
+ call blkini(ilport(l),'ilport')
+ call blkini(jfport(l),'jfport')
+ call blkini(jlport(l),'jlport')
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif
+c
+ lnport(l) = ilport(l)-ifport(l)+jlport(l)-jfport(l)+1
+c
+c --- sanity check.
+c
+ if (kdport(l).gt.2) then
+ if (ifport(l).ne.ilport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdt)')
+ stop '(latbdt)'
+ endif
+ else
+ if (jfport(l).ne.jlport(l)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - port direction',
+ & ' and orientation are not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdt)')
+ stop '(latbdt)'
+ endif
+ endif
+ if (ifport(l).gt.ilport(l) .or.
+ & jfport(l).gt.jlport(l) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - port',
+ & ' location is not consistent'
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('(latbdt)')
+ stop '(latbdt)'
+ endif
+ enddo
+c
+ close(unit=uoff+99)
+c
+c --- check ports against masks,
+c --- mark the port locations on masks and print them out.
+c
+ lfatal = .false.
+ do l= 1,nports
+ lfatalp = .false.
+c
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.1 .or. i.gt.itdm-2 .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0+1,j-j0).ne.1 .or.
+ & iu(i-i0+2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.lt.3 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iu(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 9 !indicate an error
+ else
+ iu(i-i0,j-j0) = -1
+ endif
+ if (iu(i-i0-1,j-j0).ne.1 .or.
+ & iu(i-i0-2,j-j0).ne.1 ) then
+ lfatalp = .true.
+ iu(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.3 .or. j.gt.jtdm ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0-1).ne.1 .or.
+ & iv(i-i0,j-j0-2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.lt.1 .or. i.gt.itdm .or.
+ & j.lt.1 .or. j.gt.jtdm-2 ) then
+ lfatalp = .true.
+ elseif (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ elseif (iv(i-i0,j-j0).ne.0) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 9 !indicate an error
+ else
+ iv(i-i0,j-j0) = -1
+ endif
+ if (iv(i-i0,j-j0+1).ne.1 .or.
+ & iv(i-i0,j-j0+2).ne.1 ) then
+ lfatalp = .true.
+ iv(i-i0,j-j0) = 7 !indicate an error
+ endif
+ enddo
+c
+ endif
+c
+ if (lfatalp) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - port ',l,' mislocated',
+ & ' (mnproc = ',mnproc,')'
+ write(lp,*)
+ call flush(lp)
+ endif
+ lfatal = lfatal .or. lfatalp
+ enddo !l=1,nports
+c
+c local lfatal to global lfatal
+c
+ if (lfatal) then
+ fatal = 1.0
+ else
+ fatal = 0.0
+ endif
+ call xcmaxr(fatal)
+ lfatal = fatal.gt.0.5
+c
+c --- write out -iu- and -iv- arrays, if they are not too big
+c --- data are written in strips nchar points wide
+c
+ if (lfatal .or. max(itdm,jtdm).le.2*nchar) then
+ util1(1:ii,1:jj) = iu(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iu array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+ util1(1:ii,1:jj) = iv(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'iv array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+ endif ! small region
+c
+ if (lfatal) then
+ write(lp,*)
+ write(lp,*) 'error in latbdt - bad port(s)'
+ write(lp,*)
+ call flush(lp)
+ call xchalt('(latbdt)')
+ stop '(latbdt)'
+ endif
+c
+c --- restore iu and iv, and zero iuopn and ivopn.
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ iu(i,j) = max( iu(i,j), 0 )
+ iv(i,j) = max( iv(i,j), 0 )
+ enddo
+ enddo
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ iuopn(i,j) = 0
+ ivopn(i,j) = 0
+ enddo
+ enddo
+c
+c --- define the nested boundary input mask.
+c
+ do j= 1,jj
+ do i= 1,ii
+ maskbc(i,j) = 0
+ enddo
+ enddo
+c
+ do l= 1,nports
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ do j= jfport(l),jlport(l)
+ if (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ else
+ maskbc(i-i0,j-j0) = 1
+ endif
+ enddo
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)-1
+ do j= jfport(l),jlport(l)
+ if (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ else
+ maskbc(i-i0,j-j0) = 1
+ endif
+ enddo
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ do i= ifport(l),ilport(l)
+ if (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ else
+ maskbc(i-i0,j-j0) = 1
+ endif
+ enddo
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ do i= ifport(l),ilport(l)
+ if (i.le.i0 .or. i.gt.i0+ii .or.
+ & j.le.j0 .or. j.gt.j0+jj ) then
+ cycle ! not on this tile.
+ else
+ maskbc(i-i0,j-j0) = 1
+ endif
+ enddo
+ endif
+ enddo !l=1,nports
+c
+ if (ldebug_latbdt) then
+ util1(1:ii,1:jj) = maskbc(1:ii,1:jj) ! xclget is for real arrays
+ isec=(itdm-1)/nchar
+ do ifrst=0,nchar*isec,nchar
+ ilast=min(itdm,ifrst+nchar)
+ write (char3,'(i3)') ilast-ifrst
+ fmt(8:10)=char3
+ if (mnproc.eq.1) then
+ write (lp,'(a,i5,a,i5)')
+ & 'bc array, cols',ifrst+1,' --',ilast
+ endif
+ do j= jtdm,1,-1
+ call xclget(aline,ilast-ifrst, util1,ifrst+1,j,1,0, 1)
+ if (mnproc.eq.1) then
+ write (lp,fmt) j,(nint(aline(i)),i=1,ilast-ifrst)
+ endif
+ enddo
+ enddo
+ if (mnproc.eq.1) then
+ write (lp,*)
+ endif
+ call xcsync(flush_lp)
+ endif !ldebug_latbdt
+c
+c --- initialize the ports
+c
+ do l= 1,nports
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(pline(j),lnport(l), depths,i,j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ speedw(j) = sqrt(thref/(onem*pline(j)))
+ rspedw(j) = 1.0/speedw(j)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1pe12.5)')
+ & 'w port: ',l,i,j,speedw(j)
+ endif
+c
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ iuopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(pline(j),lnport(l), depths,i,j,0,1, 0)
+ do j= jfport(l),jlport(l)
+ speede(j) = sqrt(thref/(onem*pline(j)))
+ rspede(j) = 1.0/speede(j)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1pe12.5)')
+ & 'e port: ',l,i,j,speede(j)
+ endif
+c
+ if (i+1.ge.i0+ 1-nbdy .and.
+ & i+1.le.i0+ii+nbdy .and.
+ & j .ge.j0+ 1-nbdy .and.
+ & j .le.j0+jj+nbdy ) then
+ iuopn(i-i0+1,j-j0) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(pline(i),lnport(l), depths,i,j,1,0, 0)
+ do i= ifport(l),ilport(l)
+ speedn(i) = sqrt(thref/(onem*pline(i)))
+ rspedn(i) = 1.0/speedn(i)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1pe12.5)')
+ & 'n port: ',l,i,j,speedn(i)
+ endif
+c
+ if (i .ge.i0+ 1-nbdy .and.
+ & i .le.i0+ii+nbdy .and.
+ & j+1.ge.j0+ 1-nbdy .and.
+ & j+1.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0+1) = 1
+ endif
+ enddo
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(pline(i),lnport(l), depths,i,j,1,0, 0)
+ do i= ifport(l),ilport(l)
+ speeds(i) = sqrt(thref/(onem*pline(i)))
+ rspeds(i) = 1.0/speeds(i)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ write(lp,'(a,i2,2i5,1pe12.5)')
+ & 's port: ',l,i,j,speeds(i)
+ endif
+c
+ if (i.ge.i0+ 1-nbdy .and.
+ & i.le.i0+ii+nbdy .and.
+ & j.ge.j0+ 1-nbdy .and.
+ & j.le.j0+jj+nbdy ) then
+ ivopn(i-i0,j-j0) = 1
+ endif
+ enddo
+c
+ endif
+ enddo !l=1,nports
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ write(lp,*)
+ call flush(lp)
+ endif
+c
+c end of initialization
+c
+ call xcsync(flush_lp)
+ return
+ endif
+c
+c --- nested input only required on first barotropic time step.
+c
+ if (lll.eq.1) then
+ do j= 1,jj
+ do i= 1,ii
+ if (maskbc(i,j).eq.1) then
+ util1(i,j) = ubnest(i,j,ln0)*wb0+ubnest(i,j,ln1)*wb1
+ util2(i,j) = vbnest(i,j,ln0)*wb0+vbnest(i,j,ln1)*wb1
+ util3(i,j) = pbnest(i,j,ln0)*wb0+pbnest(i,j,ln1)*wb1
+ util4(i,j) = ubpnst(i,j,ln0)*wb0+ubpnst(i,j,ln1)*wb1
+ util5(i,j) = vbpnst(i,j,ln0)*wb0+vbpnst(i,j,ln1)*wb1
+ endif
+ enddo
+ enddo
+c
+ do l= 1,nports
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(plnstw(j), lnport(l),
+ & util3(1-nbdy,1-nbdy), i, j, 0,1, 0) ! pbnest
+ call xclget(ulnstw(j), lnport(l),
+ & util4(1-nbdy,1-nbdy), i, j, 0,1, 0) ! ubpnst
+ call xclget(vlnstw(j+1),lnport(l)-1,
+ & util2(1-nbdy,1-nbdy), i, j+1,0,1, 0) ! vbnest
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(plnste(j), lnport(l),
+ & util3(1-nbdy,1-nbdy), i, j, 0,1, 0) ! pbnest
+ call xclget(ulnste(j), lnport(l),
+ & util4(1-nbdy,1-nbdy), i, j, 0,1, 0) ! ubpnst
+ call xclget(vlnste(j+1),lnport(l)-1,
+ & util2(1-nbdy,1-nbdy), i, j+1,0,1, 0) ! vbnest
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(plnstn(i), lnport(l),
+ & util3(1-nbdy,1-nbdy), i, j, 1,0, 0) ! pbnest
+ call xclget(vlnstn(i), lnport(l),
+ & util5(1-nbdy,1-nbdy), i, j, 1,0, 0) ! vbpnst
+ call xclget(ulnstn(i+1),lnport(l)-1,
+ & util1(1-nbdy,1-nbdy), i+1,j, 1,0, 0) ! ubnest
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(plnsts(i), lnport(l),
+ & util3(1-nbdy,1-nbdy), i, j, 1,0, 0) ! pbnest
+ call xclget(vlnsts(i), lnport(l),
+ & util5(1-nbdy,1-nbdy), i, j, 1,0, 0) ! vbpnst
+ call xclget(ulnsts(i+1),lnport(l)-1,
+ & util1(1-nbdy,1-nbdy), i+1,j, 1,0, 0) ! ubnest
+ endif
+ enddo !l=1,nports
+ endif !lll.eq.1
+c
+c --- 'wellposed' treatment of pressure and velocity fields.
+c --- alternate order of ports in case corners are open.
+c
+ if (mod(lll,2).eq.1) then
+ npf = 1
+ npl = nports
+ npi = 1
+ else
+ npf = nports
+ npl = 1
+ npi = -1
+ endif
+ do l= npf,npl,npi
+c
+ if (kdport(l).eq.4) then
+c
+c western port
+c
+ i = ifport(l)
+ j = jfport(l)
+ call xclget(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j, 0,1, 0)
+ call xclget(uline(j,2),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+2,j, 0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 0,1, 0)
+ do j= jfport(l),jlport(l)
+ crs= ulnstw(j) +speedw(j)*plnstw(j)
+ fin=1.5*uline(j,1)-0.5*uline(j,2)-speedw(j)*pline( j)
+ pline(j) =0.5*(crs-fin)*rspedw(j)
+ uline(j,1)= (crs+fin)-uline(j,1)
+ enddo
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 0,1)
+ call xclput(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j, 0,1) ! normal
+ call xclput(vlnstw(j+1),lnport(l)-1,
+ & vbavg(1-nbdy,1-nbdy,n), i, j+1,0,1) ! tangential
+c
+ elseif (kdport(l).eq.3) then
+c
+c eastern port
+c
+ i = ifport(l)-1
+ j = jfport(l)
+ call xclget(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i, j, 0,1, 0)
+ call xclget(uline(j,2),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i-1,j, 0,1, 0)
+ call xclget(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 0,1, 0)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ j=jlport(l)
+ write(lp,'(a,i4,1p2e12.5)') 'e port, uline:',j,uline(j,1:2)
+ write(lp,'(a,i4,1p1e12.5)') 'e port, pline:',j,pline(j)
+ write(lp,'(a,i4,1p1e12.5)') 'e port, plnst:',j,plnste(j)
+ write(lp,'(a,i4,1p1e12.5)') 'e port, ulnst:',j,ulnste(j)
+ endif
+ do j= jfport(l),jlport(l)
+ crs= ulnste(j) -speede(j)*plnste(j)
+ fin=1.5*uline(j,1)-0.5*uline(j,2)+speede(j)*pline( j)
+ pline(j) =0.5*(fin-crs)*rspede(j)
+ uline(j,1)= (fin+crs)-uline(j,1)
+ enddo
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ j=jlport(l)
+ write(lp,'(a,i4,1p2e12.5)') 'e port, crs:',j,crs,fin
+ write(lp,'(a,i4,1p1e12.5)') 'e port, pbavg:',j,pline(j)
+ write(lp,'(a,i4,1p1e12.5)') 'e port, ubavg:',j,uline(j,1)
+ write(lp,'(a,i4,1p1e12.5)') 'e port, vbavg:',j,vlnste(j)
+ write(lp,*)
+ call flush(lp)
+ endif
+ j = jfport(l)
+ call xclput(pline(j), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 0,1)
+ call xclput(uline(j,1),lnport(l),
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j, 0,1) ! normal
+ call xclput(vlnste(j+1),lnport(l)-1,
+ & vbavg(1-nbdy,1-nbdy,n), i, j+1,0,1) ! tangential
+c
+ elseif (kdport(l).eq.1) then
+c
+c northern port
+c
+ j = jfport(l)-1
+ i = ifport(l)
+ call xclget(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j, 1,0, 0)
+ call xclget(uline(i,2),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j-1,1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 1,0, 0)
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ i=ilport(l)
+ write(lp,'(a,i4,1p2e12.5)') 'n port, uline:',i,uline(i,1:2)
+ write(lp,'(a,i4,1p1e12.5)') 'n port, pline:',i,pline(i)
+ write(lp,'(a,i4,1p1e12.5)') 'n port, plnst:',i,plnstn(i)
+ write(lp,'(a,i4,1p1e12.5)') 'n port, vlnst:',i,vlnstn(i)
+ endif
+ do i= ifport(l),ilport(l)
+ crs= vlnstn(i) -speedn(i)*plnstn(i)
+ fin=1.5*uline(i,1)-0.5*uline(i,2)+speedn(i)*pline( i)
+ pline(i) =0.5*(fin-crs)*rspedn(i)
+ uline(i,1)= (fin+crs)-uline(i,1)
+ enddo
+ if (ldebug_latbdt .and. mnproc.eq.1) then
+ i=ilport(l)
+ write(lp,'(a,i4,1p2e12.5)') 'n port, crs:',i,crs,fin
+ write(lp,'(a,i4,1p1e12.5)') 'n port, pbavg:',i,pline(i)
+ write(lp,'(a,i4,1p1e12.5)') 'n port, vbavg:',i,uline(i,1)
+ write(lp,'(a,i4,1p1e12.5)') 'n port, ubavg:',i,ulnstn(i)
+ write(lp,*)
+ call flush(lp)
+ endif
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 1,0)
+ call xclput(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j+1,1,0) ! normal
+ call xclput(ulnstn(i+1),lnport(l)-1,
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j, 1,0) ! tangential
+c
+ elseif (kdport(l).eq.2) then
+c
+c southern port
+c
+ j = jfport(l)
+ i = ifport(l)
+ call xclget(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j+1,1,0, 0)
+ call xclget(uline(i,2),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j+2,1,0, 0)
+ call xclget(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 1,0, 0)
+ do i= ifport(l),ilport(l)
+ crs= vlnsts(i) +speeds(i)*plnsts(i)
+ fin=1.5*uline(i,1)-0.5*uline(i,2)-speeds(i)*pline( i)
+ pline(i) =0.5*(crs-fin)*rspeds(i)
+ uline(i,1)= (crs+fin)-uline(i,1)
+ enddo
+ i = ifport(l)
+ call xclput(pline(i), lnport(l),
+ & pbavg(1-nbdy,1-nbdy,n), i, j, 1,0)
+ call xclput(uline(i,1),lnport(l),
+ & vbavg(1-nbdy,1-nbdy,n), i, j, 1,0) ! normal
+ call xclput(ulnsts(i+1),lnport(l)-1,
+ & ubavg(1-nbdy,1-nbdy,n), i+1,j, 1,0) ! tangential
+c
+ endif
+c
+ enddo !l=1,nports
+c
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> Mar. 2004 -- fixed bug in latbdp's speed calculation
+c> Nov. 2006 -- added latbdf
diff --git a/src_2.2.18_3_one/machi_c.c b/src_2.2.18_3_one/machi_c.c
new file mode 100755
index 0000000..babad86
--- /dev/null
+++ b/src_2.2.18_3_one/machi_c.c
@@ -0,0 +1,72 @@
+#if defined(SGI)
+/*
+ --- Fortran-callable routine ZUNDER that sets the bit to specify
+ --- that underflows are flushed to zero in hardware on SGI R10000.
+ --- See man handle_sigfpes
+ --- Alan J. Wallcraft, NRL, October 1997.
+*/
+#include
+void zunder_()
+{
+ union fpc_csr n;
+ n.fc_word = get_fpc_csr();
+ n.fc_struct.flush = 1;
+ set_fpc_csr(n.fc_word);
+}
+#endif /* SGI */
+
+#if defined(AIX)
+/*
+ --- Fortran-callable function WTIME that returns the wall time in seconds.
+ --- Probably not thread-safe, only for Power-PC systems.
+ --- Alan J. Wallcraft, NRL, May 2001.
+ --- Based on notes by Bob Walkup (10x faster than MPI_WTIME).
+*/
+#include
+#include
+double wtime(void)
+{
+ struct timebasestruct TB;
+ static int first_call;
+ static double tb_factor;
+ double tb_top,tb_bot;
+ if (first_call == 0) {
+ first_call = 1;
+ tb_top = (double) _system_configuration.Xint;
+ tb_bot = (double) _system_configuration.Xfrac;
+ tb_factor = tb_top/tb_bot;
+ }
+ read_real_time(&TB, TIMEBASE_SZ);
+ return ( tb_factor * ( 4.294967296*((double) TB.tb_high) + 1.0e-9*((double) TB.tb_low) ) );
+}
+#endif /* AIX */
+
+#if defined(ENDIAN_IO)
+/*
+ --- Fortran-callable routine ZAIO_ENDIAN to swap the endian-ness of an array
+ --- Brent Anderson, ASC MSRC, July 2007.
+*/
+#include
+void zaio_endian_(uint32_t *, uint32_t *);
+
+#define swap4bytes(data) \
+ ( (((data) >> 24) & 0x000000FF) | \
+ (((data) >> 8) & 0x0000FF00) | \
+ (((data) << 8) & 0x00FF0000) | \
+ (((data) << 24) & 0xFF000000) )
+
+/** Swaps the byte-order in a 32-bit word from
+ big- to little-endianness or vice-versa. */
+
+void zaio_endian_(uint32_t aa[], uint32_t *nn) {
+ uint32_t ii;
+ for( ii=0; ii<*nn; ii++ ) {
+ aa[ii] = swap4bytes ( aa[ii] );
+ }
+ return;
+}
+#endif /* ENDIAN_IO */
+
+void machine_c()
+{
+}
diff --git a/src_2.2.18_3_one/machine.F b/src_2.2.18_3_one/machine.F
new file mode 100755
index 0000000..04aab99
--- /dev/null
+++ b/src_2.2.18_3_one/machine.F
@@ -0,0 +1,76 @@
+c
+c --- machine-specific Fortran routines
+c
+ subroutine machine()
+c
+c --- always called once at the start of the program.
+c
+#if defined(SGI)
+ call zunder() ! C-wrapper to flush underflow to zero on R10000
+#endif
+ end
+#if defined(AIX)
+ subroutine flush(iunit)
+ implicit none
+ integer iunit
+c
+c --- wrapper for flush system call under AIX.
+c
+ integer*4 iunit4
+c
+ iunit4=iunit
+ call flush_(iunit4)
+ return
+ end
+#endif /* AIX */
+#if defined(X1)
+ subroutine x1flush(iunit)
+ implicit none
+ integer iunit
+c
+c --- wrapper for flush system call on the Cray X1.
+c
+ integer ierr
+c
+ call FLUSH(iunit,ierr)
+ return
+ end
+#endif /* X1 */
+#if defined(IFC)
+ subroutine flush(iunit)
+ implicit none
+ integer iunit
+c
+c --- disable the flush system call under Intel's IFC compiler.
+c
+ return
+ end
+#endif /* IFC */
+#if defined(SUN)
+ subroutine ieee_retrospective()
+c
+c dummy routine to turn off ieee warning messages on a Sun.
+c
+ end
+#endif /* SUN */
+#if defined(T3E) || defined(YMP) || defined(X1)
+ subroutine getenv(cname, cvalue)
+ implicit none
+c
+ character*(*) cname,cvalue
+c
+c this subroutine provides getenv functionality
+c on the t3e, using pxfgetenv.
+c
+ integer iname,ivalue,ierr
+c
+ iname = 0
+ ierr = 0
+ call pxfgetenv(cname,iname, cvalue,ivalue, ierr)
+ if (ierr.ne.0) then
+ cvalue = ' '
+ endif
+ return
+c end of getenv.
+ end
+#endif /* T3E || YMP || X1 */
diff --git a/src_2.2.18_3_one/matinv.f b/src_2.2.18_3_one/matinv.f
new file mode 100755
index 0000000..2f2c7e6
--- /dev/null
+++ b/src_2.2.18_3_one/matinv.f
@@ -0,0 +1,165 @@
+c ------------------------------------------------------------------
+c --- matrix inversion subroutines for implicit solution of vertical
+c --- diffusion equation - tri-diagonal matrix
+c ------------------------------------------------------------------
+c
+ subroutine tridcof(diff,tri,nlayer,tcu,tcc,tcl)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c --- compute coefficients for tridiagonal matrix (dimension=kdm).
+c --- Note: tcu(1) = 0. and tcl(kdm+1) = 0. are necessary conditions.
+c
+c --- input
+ real diff(kdm+1) ! diffusivity profile on interfaces
+ integer nlayer
+c
+c --- output
+ real tcu(kdm), ! upper coeff. for (k-1) on k line of trid.matrix
+ & tcc(kdm), ! central ... (k ) ..
+ & tcl(kdm) ! lower ..... (k-1) ..
+c --- common tridiagonal factors
+ real tri(kdm,0:1) ! dt/dz/dz factors in trid. matrix
+c
+c --- local
+ integer k
+c
+c --- in the surface layer
+ tcu(1)=0.
+ tcc(1)=1.+tri(1,1)*diff(2) ! 1.+ delt1/h(1)/dzb(1)*diff(2)
+ tcl(1)= -tri(1,1)*diff(2) ! - delt1/h(1)/dzb(1)*diff(2)
+c
+c --- inside the domain
+ do 10 k=2,nlayer
+ tcu(k)= -tri(k,0)*diff(k )
+ tcc(k)=1.+tri(k,1)*diff(k+1)+tri(k,0)*diff(k)
+ tcl(k)= -tri(k,1)*diff(k+1)
+ 10 continue
+c
+c --- in the bottom layer
+ tcl(nlayer)= 0.
+ return
+ end
+
+***********************************************************************
+
+ subroutine tridrhs(h,yo,diff,ghat,ghatflux,tri,nlayer,rhs)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+c --- compute right hand side of tridiagonal matrix for scalar fields:
+c --- = yo (old field)
+c --- + flux-divergence of ghat
+c --- + flux-divergence of non-turbulant fluxes
+c
+c --- note: if surface and bottom fluxes are nonzero, the following must apply
+c --- sfc. lyr. needs +delt1/h(1)*surfaceflux
+c --- bot. lyr. needs +delt1/h(nlayer)*diff(nlayer+1)/
+c --- dzb(nlayer)*yo(nlayer+1)
+c
+c --- input
+ real h(kdm), ! layer thickness
+ & yo(kdm+1), ! old profile
+ & diff(kdm+1), ! diffusivity profile on interfaces
+ & ghat(kdm+1), ! ghat turbulent flux
+ & ghatflux ! surface flux for ghat: includes solar flux
+ integer nlayer
+c
+c --- output
+ real rhs(kdm) ! right hand side
+c
+ real tri(kdm,0:1) ! dt/dz/dz factors in trid. matrix
+c
+c --- local
+ integer k
+c
+c --- in the top layer
+ rhs(1)=yo(1)+delt1/h(1)*(ghatflux*diff(2)*ghat(2))
+c
+c --- inside the domain
+ do 10 k=2,nlayer-1
+ rhs(k)=yo(k)+delt1/h(k)*
+ & (ghatflux*(diff(k+1)*ghat(k+1)-diff(k)*ghat(k)))
+ 10 continue
+c
+c --- in the bottom layer
+ k=nlayer
+ rhs(k)=yo(k)+delt1/h(k)*
+ & (ghatflux*(diff(k+1)*ghat(k+1)-diff(k)*ghat(k)))
+c
+ return
+ end
+
+***********************************************************************
+
+ subroutine tridmat(tcu,tcc,tcl,nlayer,h,rhs,yo,yn,diff, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- solve tridiagonal matrix for new vector yn, given right hand side
+c --- vector rhs.
+c
+c --- note: if surface and bottom fluxes are nonzero, the following must apply
+c --- surface layer needs +delt1*surfaceflux/(h(1)*bet)
+c --- bottom layer needs +tri(nlayer,1)*diff(nlayer+1)*yo(nlayer+1))/bet
+c
+ include 'common_blocks.h'
+c
+c --- input
+ real tcu (kdm), ! upper coeff. for (k-1) on k line of tridmatrix
+ & tcc (kdm), ! central ... (k ) ..
+ & tcl (kdm), ! lower ..... (k-1) ..
+ & h (kdm), ! layer thickness
+ & rhs(kdm), ! right hand side
+ & yo(kdm+1), ! old field
+ & diff(kdm+1), ! diffusivity profile
+ & gam(kdm) ! temporary array for tridiagonal solver
+ real bet ! ...
+ integer nlayer, ! number of active layers <=kdm
+ & i,j ! local grid point
+c
+c --- output
+ real yn(kdm+1) ! new field
+c
+c --- local
+ integer k
+c
+c --- solve tridiagonal matrix.
+ bet=tcc(1)
+ yn(1)=rhs(1)/bet ! surface
+ do 21 k=2,nlayer
+ gam(k)=tcl(k-1)/bet
+ bet=tcc(k)-tcu(k)*gam(k)
+ if(bet.eq.0.) then
+ write(lp,*)
+ write(lp,*) '** algorithm for solving tridiagonal matrix fails'
+ write(lp,*) '** i,j=',i0+i,j0+j !global grid point
+ write(lp,*) '** bet=',bet
+ write(lp,*) '** k=',k,' tcc=',tcc(k),' tcu=',tcu(k),
+ & ' gam=',gam(k)
+ call flush(lp)
+ call xchalt('(tridmat)')
+ stop '(tridmat)'
+* bet=1.E-12
+ endif
+ yn(k) = (rhs(k) - tcu(k) *yn(k-1) )/bet
+c to avoid "Underflow" at single precision on the sun
+c yni = (rhs(k) - tcu(k) *yn(k-1) )/bet
+c if(yni.lt.0.) then
+c yn(k) =min( (rhs(k) - tcu(k) *yn(k-1) )/bet ,-1.E-12 )
+c else
+c yn(k) = max( (rhs(k) - tcu(k) *yn(k-1) )/bet , 1.E-12 )
+c endif
+ 21 continue
+c
+ do 22 k=nlayer-1,1,-1
+ yn(k)=yn(k)-gam(k+1)*yn(k+1)
+ 22 continue
+c
+ yn(nlayer+1)=yo(nlayer+1)
+c
+ return
+ end
diff --git a/src_2.2.18_3_one/mod_OICPL.F b/src_2.2.18_3_one/mod_OICPL.F
new file mode 100755
index 0000000..af44604
--- /dev/null
+++ b/src_2.2.18_3_one/mod_OICPL.F
@@ -0,0 +1,368 @@
+#define OI_REGRID_CHOICE 0 /* ocean and seaice have the same grid and layout */
+
+ module mod_OICPL
+c
+c --- ESMF Framework module
+ use ESMF_Mod
+c
+ implicit none
+ private
+c
+ public OICPL_SetServices
+c
+c --- phase info
+ integer, parameter, public :: ice2ocn_phase = 1
+ integer, parameter, public :: ocn2ice_phase = 2
+c
+c --- VM and PET info
+ type(ESMF_VM), save :: vm
+ integer, save :: petCount,localPet
+c --- Misc field stuff
+ type(ESMF_Bundle), save :: ocnBundle, iceBundle
+ integer(ESMF_KIND_I4), save :: numOcnFields, numIceFields
+ type(ESMF_Field), save :: ocnField, iceField
+ real(ESMF_KIND_R4),pointer,save :: ocnData(:,:), iceData(:,:)
+#if OI_REGRID_CHOICE != 0
+c
+c --- Route handles for regridding and redistribution
+ type(ESMF_RouteHandle), allocatable, save ::
+ & i2oRouteHandle(:), o2iRouteHandle(:)
+#endif /* OI_REGRID_CHOICE != 0 */
+
+ contains
+
+ subroutine OICPL_SetServices(cplComp, rc)
+c
+ type(ESMF_CplComp) :: cplComp
+ integer :: rc
+c
+ call ESMF_CplCompSetEntryPoint(
+ & cplComp,
+ & ESMF_SETINIT,
+ & OICPL_Init,
+ & ESMF_SINGLEPHASE,
+ & rc)
+ call ESMF_CplCompSetEntryPoint(
+ & cplComp,
+ & ESMF_SETRUN,
+ & OICPL_Run_I2O,
+ & ice2ocn_phase,
+ & rc)
+ call ESMF_CplCompSetEntryPoint(
+ & cplComp,
+ & ESMF_SETRUN,
+ & OICPL_Run_O2I,
+ & ocn2ice_phase,
+ & rc)
+ call ESMF_CplCompSetEntryPoint(
+ & cplComp,
+ & ESMF_SETFINAL,
+ & OICPL_Final,
+ & ESMF_SINGLEPHASE,
+ & rc)
+c
+ end subroutine OICPL_SetServices
+
+
+ subroutine OICPL_Init(cplComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_CplComp) :: cplComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- Locals
+ integer :: i
+ character(ESMF_MAXSTR) :: msg
+ type(ESMF_State) :: oiState, oeState, iiState, ieState
+c
+c --- Report
+ call ESMF_LogWrite("OICPL initialize routine called",
+ & ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c --- Get VM
+ call ESMF_CplCompGet(cplComp, vm=vm, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get VM failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get PET info
+ call ESMF_VMGet(vm, petCount=petCount, localPET=localPet, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get VM info failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get OCEAN and SEAICE import states
+ CALL ESMF_StateGetState(impState, "OCEAN Import", oiState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get OCEAN impState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ CALL ESMF_StateGetState(impState, "SEAICE Import", iiState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get SEAICE impState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get OCEAN and SEAICE export states
+ CALL ESMF_StateGetState(expState, "OCEAN Export", oeState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get OCEAN expState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ CALL ESMF_StateGetState(expState, "SEAICE Export", ieState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get SEAICE expState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Initialize I2O
+c
+c --- Get bundle for ice
+ call ESMF_StateGetBundle(ieState, "CICE", iceBundle, rc=rc)
+c
+c --- Get number of ice fields from bundle
+ call ESMF_BundleGet(iceBundle, fieldCount=numIceFields, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGet numIceFields failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+#if OI_REGRID_CHOICE != 0
+c
+c --- Allocate route handles for I2O
+ allocate(i2oRouteHandle(numIceFields))
+c
+c --- Setup I2O route handles
+ call ESMF_StateGetBundle(oiState, "HYCOM", ocnBundle, rc=rc)
+ do i = 1,numIceFields
+c this works because ocn and ice fields are in the same order.
+ call ESMF_BundleGetField(iceBundle, i, iceField, rc=rc)
+ call ESMF_BundleGetField(ocnBundle, i, ocnField, rc=rc)
+#if OI_REGRID_CHOICE == 1
+ i2oRouteHandle(i) = ESMF_RouteHandleCreate(rc)
+ call ESMF_FieldRedistStore(iceField, ocnField, vm,
+ & routeHandle=i2oRouteHandle(i), rc=rc)
+ call ESMF_FieldRedist(iceField, ocnField,
+ & i2oRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ i2oRouteHandle(i) = ESMF_RouteHandleCreate(rc)
+ call ESMF_FieldRegridStore(iceField, ocnField, vm,
+ & routeHandle=i2oRouteHandle(i),
+ & regridMethod=ESMF_REGRID_METHOD_BILINEAR, rc=rc)
+ call ESMF_FieldRegrid(iceField, ocnField,
+ & i2oRouteHandle(i), rc=rc)
+#endif
+ enddo !i
+#endif /* OI_REGRID_CHOICE != 0 */
+c
+c Initialize O2I
+c
+c
+c --- Get bundle for ocn
+ call ESMF_StateGetBundle(oeState, "HYCOM", ocnBundle, rc=rc)
+c
+c --- Get number of ocn fields from bundle
+ call ESMF_BundleGet(ocnBundle, fieldCount=numOcnFields, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGet numOcnFields failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+#if OI_REGRID_CHOICE != 0
+c
+c --- Allocate route handles for O2I
+ allocate(o2iRouteHandle(numOcnFields))
+c
+c --- Setup O2I route handles
+ call ESMF_StateGetBundle(iiState, "CICE", iceBundle, rc=rc)
+ do i = 1,numOcnFields
+c this works because ocn and ice fields are in the same order.
+ call ESMF_BundleGetField(ocnBundle, i, ocnField, rc=rc)
+ call ESMF_BundleGetField(iceBundle, i, iceField, rc=rc)
+#if OI_REGRID_CHOICE == 1
+ o2iRouteHandle(i) = ESMF_RouteHandleCreate(rc)
+ call ESMF_FieldRedistStore(ocnField, iceField, vm,
+ & routeHandle=o2iRouteHandle(i),
+ & rc=rc)
+ call ESMF_FieldRedist(ocnField, iceField,
+ & o2iRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ o2iRouteHandle(i) = ESMF_RouteHandleCreate(rc)
+ call ESMF_FieldRegridStore(ocnField, iceField, vm,
+ & routeHandle=o2iRouteHandle(i),
+ & regridMethod=ESMF_REGRID_METHOD_BILINEAR,
+ & rc=rc)
+ call ESMF_FieldRegrid(ocnField, iceField,
+ & o2iRouteHandle(i), rc=rc)
+#endif
+ enddo !i
+#endif /* OI_REGRID_CHOICE != 0 */
+c
+ return
+ end subroutine OICPL_Init
+
+ subroutine OICPL_Run_I2O(cplComp, impState, expState, extClock,
+ & rc)
+c
+c --- Calling parameters
+ type(ESMF_CplComp) :: cplComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- Locals
+ integer :: i
+ character(ESMF_MAXSTR) :: msg
+ type(ESMF_State) :: oiState, oeState, iiState, ieState
+c
+c --- Report
+ write(msg,'(a,i3)')
+ & "OICPL I2O run routine called, numIceFields =",numIceFields
+ call ESMF_LogWrite(trim(msg), ESMF_LOG_INFO) !OICPL I2O run
+!-----call ESMF_LogFlush
+c
+c --- Get OCEAN import state
+ CALL ESMF_StateGetState(impState, "OCEAN Import", oiState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get OCEAN impState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get SEAICE export state
+ CALL ESMF_StateGetState(expState, "SEAICE Export", ieState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get SEAICE expState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get bundle for ice
+ call ESMF_StateGetBundle(ieState, "CICE", iceBundle, rc=rc)
+c
+c --- Transfer fields from ice state to ocn state
+ call ESMF_StateGetBundle(oiState, "HYCOM", ocnBundle, rc=rc)
+ do i = 1,numIceFields
+c this works because ocn and ice fields are in the same order.
+ call ESMF_BundleGetField(iceBundle, i, iceField, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGetField iceEx failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ call ESMF_BundleGetField(ocnBundle, i, ocnField, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGetField ocnIm failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+#if OI_REGRID_CHOICE == 0
+ call ESMF_FieldGetDataPointer(iceField, iceData,
+ & copyFlag=ESMF_DATA_REF, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "FieldGetDataP iceEx failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ call ESMF_FieldGetDataPointer(ocnField, ocnData,
+ & copyFlag=ESMF_DATA_REF, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "FieldGetDataP ocnIm failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ ocnData(:,:) = iceData(:,:)
+#elif OI_REGRID_CHOICE == 1
+ call ESMF_FieldRedist(iceField, ocnField,
+ & i2oRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ call ESMF_FieldRegrid(iceField, ocnField,
+ & i2oRouteHandle(i), rc=rc)
+#endif
+ enddo !i
+c
+ return
+ end subroutine OICPL_Run_I2O
+
+ subroutine OICPL_Run_O2I(cplComp, impState, expState, extClock,
+ & rc)
+c
+c --- Calling parameters
+ type(ESMF_CplComp) :: cplComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- Locals
+ integer :: i
+ character(ESMF_MAXSTR) :: msg
+ type(ESMF_State) :: oiState, oeState, iiState, ieState
+c
+c --- Report
+ write(msg,'(a,i3)')
+ & "OICPL O2I run routine called, numOcnFields =",numOcnFields
+ call ESMF_LogWrite(trim(msg), ESMF_LOG_INFO) !OICPL O2I run
+!-----call ESMF_LogFlush
+c
+c --- Get SEAICE import state
+ CALL ESMF_StateGetState(impState, "SEAICE Import", iiState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get SEAICE impState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get OCEAN export state
+ CALL ESMF_StateGetState(expState, "OCEAN Export", oeState, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "Get OCEAN expState failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+c
+c --- Get bundle for first nest of ocn
+ call ESMF_StateGetBundle(oeState, "HYCOM", ocnBundle, rc=rc)
+c
+c --- Transfer fields from ocn state to ice state
+ call ESMF_StateGetBundle(iiState, "CICE", iceBundle, rc=rc)
+ do i = 1,numOcnFields
+c this works because ocn and ice fields are in the same order.
+ call ESMF_BundleGetField(ocnBundle, i, ocnField, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGetField ocnEx failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ call ESMF_BundleGetField(iceBundle, i, iceField, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "BundleGetField iceIm failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+#if OI_REGRID_CHOICE == 0
+ call ESMF_FieldGetDataPointer(ocnField, ocnData,
+ & copyFlag=ESMF_DATA_REF, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "FieldGetDataP ocnEx failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ call ESMF_FieldGetDataPointer(iceField, iceData,
+ & copyFlag=ESMF_DATA_REF, rc=rc)
+ IF (ESMF_LogMsgFoundError(rc, "FieldGetDataP iceIm failed",
+ & rc)) call ESMF_Finalize(rc=rc)
+ iceData(:,:) = ocnData(:,:)
+#elif OI_REGRID_CHOICE == 1
+ call ESMF_FieldRedist(ocnField, iceField,
+ & o2iRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ call ESMF_FieldRegrid(ocnField, iceField,
+ & o2iRouteHandle(i), rc=rc)
+#endif
+ enddo !i
+c
+ return
+ end subroutine OICPL_Run_O2I
+
+ subroutine OICPL_Final(cplComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_CplComp) :: cplComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- Locals
+ integer :: i
+ character(ESMF_MAXSTR) :: msg
+ type(ESMF_State) :: oiState, oeState, iiState, ieState
+c
+c --- Report
+ call ESMF_LogWrite("OICPL finalize routine called", ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+#if OI_REGRID_CHOICE != 0
+c
+c --- Release i2o regrid/redist route handles
+ do i = 1,numIceFields
+#if OI_REGRID_CHOICE == 1
+ call ESMF_FieldRedistRelease(i2oRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ call ESMF_FieldRegridRelease(i2oRouteHandle(i), rc=rc)
+#endif
+ enddo
+c
+c --- Release o2i regrid/redist route handles
+ do i = 1,numOcnFields
+#if OI_REGRID_CHOICE == 1
+ call ESMF_FieldRedistRelease(o2iRouteHandle(i), rc=rc)
+#elif OI_REGRID_CHOICE == 2
+ call ESMF_FieldRegridRelease(o2iRouteHandle(i), rc=rc)
+#endif
+ enddo
+c
+c --- Deallocate regrid/redist route handles
+ deallocate(i2oRouteHandle,o2iRouteHandle)
+#endif /* OI_REGRID_CHOICE != 0 */
+c
+ return
+ end subroutine OICPL_Final
+
+ end module mod_OICPL
diff --git a/src_2.2.18_3_one/mod_dimensions.F b/src_2.2.18_3_one/mod_dimensions.F
new file mode 100755
index 0000000..f833b04
--- /dev/null
+++ b/src_2.2.18_3_one/mod_dimensions.F
@@ -0,0 +1,6 @@
+ module mod_dimensions
+c
+c module needed for CCSM3 integration
+c
+ include 'dimensions.h'
+ end module mod_dimensions
diff --git a/src_2.2.18_3_one/mod_floats.F b/src_2.2.18_3_one/mod_floats.F
new file mode 100755
index 0000000..2af90e3
--- /dev/null
+++ b/src_2.2.18_3_one/mod_floats.F
@@ -0,0 +1,2678 @@
+ module mod_floats
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+c
+ implicit none
+c
+c --- HYCOM synthetic floats, drifters and moorings
+c --- See subroutine floats (below) for more information
+c
+ integer, parameter, public ::
+ & nfldim=400 !maximum number of synthetic floats
+
+ real, allocatable, dimension(:,:,:),
+ & save, public ::
+ & wveli, ! interface vertical velocity
+ & uold2,
+ & vold2,
+ & wold2u,
+ & wold2d
+
+ real, allocatable, dimension(:,:),
+ & save, public ::
+ & dlondx,
+ & dlondy,
+ & dlatdx,
+ & dlatdy
+
+ real, allocatable, dimension(:,:,:),
+ & save, private ::
+ & wvelup,
+ & wveldn
+
+ real, allocatable, dimension(:,:),
+ & save, private ::
+ & dpdxup,
+ & dpdyup,
+ & dpdxdn,
+ & dpdydn
+
+ real, save :: flt(nfldim,13),
+ & deltfl,fldepm,tbvar,tdecri,dtturb,uturb0
+
+ integer, save :: kfloat(nfldim),iflnum(nfldim),ifltyp(nfldim),
+ & nflsam,nfldta,fltflg,nfladv,intpfl,iturbv,ismpfl,
+ & nflout,nfl,nflt,nstepfl
+
+ logical, save :: synflt,turbvel,samplfl,wvelfl,hadvfl,nonlatlon
+
+ character*48 , save :: flnmflti,flnmflto,flnmfltio
+
+ contains
+
+ subroutine floats_init(m,n,time0)
+ integer m,n
+ real time0
+c
+ include 'common_blocks.h'
+c
+c --- read initial float data
+c --- initialize parameters and arrays required for floats
+c
+ integer i,j,k,l
+ integer nbcday,nsmday,ityp
+c
+ include 'stmt_fns.h'
+c
+c --- initialize flags
+c
+c --- wvelfl: calculate vertical velocity?
+ wvelfl=.false.
+c
+c --- hadvfl: horizontally advect the float?
+ hadvfl=.false.
+c
+c --- nonlatlon: does the model grid cross latitude/longitude lines anywhere
+c --- in the domain?
+ nonlatlon=.false.
+c
+c --- initialize file names
+ flnmflti = 'floats.input'
+ flnmflto = 'floats_out'
+ flnmfltio= 'floats.input_out'
+c
+c -------------------------
+c --- set timing parameters
+c -------------------------
+c
+c --- must have an integer number of baroclinic time steps per day
+ nbcday=nint(86400.0/baclin)
+ if (float(nbcday).ne.86400.0/baclin) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - need integer no. of bacl. time steps/day'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(floats_init)')
+ stop '(floats_init)'
+ endif
+c
+c --- parameter nfladv is entered in blkdat.input as the number of
+c --- baroclinic time steps between updates of float position. at model
+c --- time nstep when the float is to be advected, velocity fields saved
+c --- at times nstep, nstep-nfladv/2, and nstep-nfladv are used to perform
+c --- the runga-kutta time interpolation.
+c
+c --- nfladv must be set so the float is advected every 2-4 hours, but
+c --- also must be no smaller than 4. This ensures that the runga-
+c --- kutta time interpolation is performed with a delta-time of 1-2 hours.
+c
+c --- if all floats are stationary (synthetic moorings), then nfladv
+c --- must still be no smaller than 4, but the above time restrection
+c --- is not necessary. this allows the user to sample at very high
+c --- frequency. for example, if baclin is 360 seconds, then setting
+c --- nfladv to 10 will allow water properties to be sampled once per hour
+c
+c --- set variable nfldta to nfladv/2 so that it equals the number of time
+c --- steps separating the velocity fields input into the runga-kutta
+c --- interpolation
+c
+ nfldta=nfladv/2
+c
+c --- make sure that the float will be advected at an integer number of
+c --- temporal points per day
+ nsmday=nbcday/nfladv
+ if (int(float(nbcday)/float(2*nfldta)).ne.nsmday) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - need integer no. of adv. times per day'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(floats_init)')
+ stop '(floats_init)'
+ endif
+c
+c --- test to make sure that the advection time interval is between 2
+c --- and 4 hours. only stop the program later if there are floats to
+c --- be advected
+ if (nfladv.ne.4 .and. (nsmday.gt.12 .or. nsmday.lt.6)) then
+ nfladv=-nfladv
+ endif
+c
+c --- initialize number of time steps between float output
+ if (nflsam.gt.0) then
+ nflsam=nflsam*nbcday
+ elseif (nflsam.eq.0) then
+ nflsam=iabs(nfladv)
+ endif
+c
+c --- calculate the time interval for the runga-kutta interpolation
+c --- as 1/2 of the advection time interval
+ deltfl=nfldta*baclin
+c
+c --- set minimum float depth (m)
+ fldepm=1.0
+c
+c --- -------------------------------------------------------------
+c --- initialize synthetic drifters, floats, and moored instruments
+c --- -------------------------------------------------------------
+c
+ open(unit=uoff+99,file=trim(flnminp)//flnmflti,status='old') !on all nodes
+c
+c --- first line in float input file is the number of floats
+ read(uoff+99,*) nflt
+ if (nflt.gt.nfldim) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - increase nfldim in mod_floats.F'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(floats_init)')
+ stop '(floats_init)'
+ endif
+ if (nflt.eq.0) then
+ synflt=.false.
+ endif
+c
+c --- second line in float input file is the initial float time step
+c --- this number is set to zero for the first model run segment
+ read(uoff+99,*) nstepfl
+c
+ do nfl=1,nflt
+c
+c --- read input file containing the following information for each float:
+c ---
+c --- column 1 - initial sequential float number
+c --- column 2 - float type
+c --- 1 = 3-d lagrangian (vertically advected by diagnosed w)
+c --- 2 = isopycnic
+c --- 3 = isobaric (surface drifter when released in sfc. layer)
+c --- 4 = stationary (synthetic moored instrument)
+c --- column 3 - deployment time (days from model start, 0.0 = immediate)
+c --- column 4 - termination time (days from model start, 0.0 = forever)
+c --- column 5 - initial longitude (must be between minimum and maximum
+c --- longitudes defined in regional.grid.b)
+c --- column 6 - initial latitude (must be between minimum and maximum
+c --- latitudes defined in regional.grid.b)
+c --- column 7 - initial depth (or reference sigma for isopycnic floats)
+c
+ read(uoff+99,*) iflnum(nfl),ifltyp(nfl),flt(nfl,8),flt(nfl,9),
+ & flt(nfl,1),flt(nfl,2),flt(nfl,3)
+ if (ifltyp(nfl).eq.1 .or. ifltyp(nfl).eq.4) then
+ wvelfl=.true.
+ endif
+ if (ifltyp(nfl).ne.4) then
+ hadvfl=.true.
+c
+c --- since this float is to be advected, stop if the advection time interval
+c --- is not between 2 and 4 hr
+ if (nfladv.lt.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - set nfladv to advect floats every 2-4 hr'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(floats_init)')
+ stop '(floats_init)'
+ endif
+c
+ endif
+c
+ flt(nfl,4)=0.0
+ flt(nfl,5)=0.0
+ flt(nfl,6)=0.0
+ flt(nfl,7)=0.0
+ if(ifltyp(nfl).eq.2) then
+ flt(nfl,7)=flt(nfl,3)
+ flt(nfl,3)=0.0
+ endif
+ flt(nfl,10)=0.0
+ flt(nfl,11)=0.0
+ flt(nfl,12)=0.0
+ flt(nfl,13)=0.0
+c
+ kfloat(nfl)=-1
+c
+ enddo
+c
+ nfladv=iabs(nfladv)
+c
+ close(unit=uoff+99) !file='float.input'
+c
+ if (mnproc.eq.1) then
+ write(lp,955) nflt
+ write(lp,956) nfladv
+ write(lp,957) nflsam
+ write(lp,958) min(nflt,10)
+ 955 format(' read initial data for',i6,' floats, time step',i9)
+ 956 format(' float advected every',i7,' baroclinic time steps')
+ 957 format(' float sampled every',i8,' baroclinic time steps'/)
+ 958 format(' input data for first',i3,' floats')
+ do nfl=1,min(nflt,10)
+ write(lp,959) nfl,(flt(nfl,i),i=1,9)
+ 959 format(3x,i2,1p,5e13.5/5x,4e13.5/)
+ enddo
+ call flush(lp)
+ endif !1st tile
+c
+c ---------------------------------------------------------------------------
+c --- allocate arrays for floats
+c ---------------------------------------------------------------------------
+c
+ allocate( wvelup(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & wveldn(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & dpdxup(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dpdyup(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dpdxdn(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dpdydn(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( wveli( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy, kdm+1),
+ & uold2( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm),
+ & vold2( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm),
+ & wold2u(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm),
+ & wold2d(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,2*kdm),
+ & dlondx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dlondy(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dlatdx(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & dlatdy(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ if (synflt) then
+!$OMP PARALLEL DO PRIVATE(j,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ do k=1,kk
+ uold2( i,j,k )=huge
+ uold2( i,j,k+kk)=huge
+ vold2( i,j,k )=huge
+ vold2( i,j,k+kk)=huge
+ wold2u(i,j,k )=huge
+ wold2u(i,j,k+kk)=huge
+ wold2d(i,j,k )=huge
+ wold2d(i,j,k+kk)=huge
+ wveli( i,j,k) =huge
+ enddo !k
+ wveli(i,j,kk+1)=huge
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ endif !synflt
+c
+c ---------------------------------------------------------------------------
+c --- initialize old horizontal velocities for runga-kutta time interpolation
+c --- calculate dlondx, dlondy, dlatdx, dlatdy required to convert u, v to
+c --- longitude/time and latitude/time for float advection
+c ---------------------------------------------------------------------------
+c
+ margin = nbdy - 1
+c
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ do k=1,kk
+ uold2(i,j,k )=u(i,j,k,n)+ubavg(i,j,n)
+ uold2(i,j,k+kk)=u(i,j,k,n)+ubavg(i,j,n)
+ enddo
+ dlondx(i,j)=(plon(i ,j)*scpy(i ,j)-
+ & plon(i-1,j)*scpy(i-1,j))/scu2(i,j)
+ dlatdx(i,j)=(plat(i ,j)*scpy(i ,j)-
+ & plat(i-1,j)*scpy(i-1,j))/scu2(i,j)
+ if (plat(i,j)-plat(i-1,j).ne.0.0) then
+ nonlatlon=.true.
+ endif
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ do k=1,kk
+ vold2(i,j,k )=v(i,j,k,n)+vbavg(i,j,n)
+ vold2(i,j,k+kk)=v(i,j,k,n)+vbavg(i,j,n)
+ enddo
+ dlondy(i,j)=(plon(i,j )*scpx(i,j )-
+ & plon(i,j-1)*scpx(i,j-1))/scv2(i,j)
+ dlatdy(i,j)=(plat(i,j )*scpx(i,j )-
+ & plat(i,j-1)*scpx(i,j-1))/scv2(i,j)
+ if (plon(i,j)-plon(i,j-1).ne.0.0) then
+ nonlatlon=.true.
+ endif
+ enddo
+ enddo
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ wold2u(i,j,k )=0.0
+ wold2d(i,j,k )=0.0
+ wold2u(i,j,k+kk)=0.0
+ wold2d(i,j,k+kk)=0.0
+ wveli (i,j,k )=0.0
+ enddo
+ wveli(i,j,kk+1)=0.0
+ enddo
+ enddo
+c
+ enddo !j
+c
+c ----------------------------------------
+c --- turbulent horizontal velocity option
+c ----------------------------------------
+c
+c --- initialize turbulence constants
+c
+c --- tdecri is in inverse days and dtturb is the turbulent time step in days
+c
+c --- dtturb is set to the runga-kutta interpolation time step, which must
+c --- be within 1 and 2 hours
+c
+ if (turbvel) then
+ dtturb=deltfl/86400.0
+ uturb0=sqrt(2.*tbvar*tdecri*dtturb)
+ endif
+c
+ return
+ end subroutine floats_init
+
+ subroutine floats_restart
+c
+c -----------------------------
+c --- output float restart file
+c -----------------------------
+c
+ integer i,k,l
+c
+ if (mnproc.eq.1) then
+c
+c --- first remove floats that have run aground or left the domain
+ i=0
+ do l=1,nflt
+ if (flt(l,1).gt.-999.0) then
+ i=i+1
+ endif
+ enddo !1
+c
+ write(lp,*) 'writing new float input file for restart'
+ call flush(lp)
+c
+ open(unit=uoff+802,file=flnmfltio,
+ & form='formatted',status='new')
+ write(uoff+802,970) i
+ write(uoff+802,970) nstepfl
+ do l=1,nflt
+ if (flt(l,1).gt.-999.0) then
+ if (ifltyp(l).ne.2) then
+ write(uoff+802,971) iflnum(l),ifltyp(l),flt(l,8),flt(l,9),
+ & (flt(l,k),k=1,3)
+ else
+ write(uoff+802,971) iflnum(l),ifltyp(l),flt(l,8),flt(l,9),
+ & (flt(l,k),k=1,2),flt(l,7)
+ endif
+ endif
+ enddo !l
+ close(uoff+802)
+ endif !1st tile
+
+ 970 format(i9)
+ 971 format(i6,i2,2f9.2,3f15.9)
+
+ return
+ end subroutine floats_restart
+
+ subroutine floats(m,n,timefl,ioflag)
+c
+ integer, parameter :: nfl_debug = -1 !no debugging
+* integer, parameter :: nfl_debug = 6 !debug float nfl_debug
+c
+ include 'common_blocks.h'
+c
+ integer m,n,ioflag
+ real timefl
+c
+c --- local variables
+ integer i,j,k,l
+ real tflt,sflt,thlo,thhi,thflt,
+ & uflt1,uflt2,uflt3,uflt4,uflt,
+ & vflt1,vflt2,vflt3,vflt4,vflt,
+ & wflt1,wflt2,wflt3,wflt4,wflt,
+ & vkflt,tkflt,skflt,xpos0,xpos1,xpos2,xpos3,
+ & ypos0,ypos1,ypos2,ypos3,depflt,plo,phi,q,
+ & depiso,wvhi,wvlo,uvfctr,qisop,ufltm,vfltm,
+ & alomin,alomax,alamin,alamax
+ real uturb,vturb,uturb1,vturb1,dlodx,dlody,dladx,dlady
+ real*4 rtab(200,2)
+ integer ifltll(3),jfltll(3),ngood(3)
+ integer kflt,k1,k2,k3,ier,ngrid,kold1w,kold2w,kold1,kold2,
+ & ntermn,i1,j1,ngoodi
+ integer ied,iede,ifladv
+c
+ integer*4 seed,numran,inisee,iflag
+ integer*2 iseed1,iseed2
+ equivalence ( iseed1, iseed2, seed )
+c
+c --- local velocity component storage for synthetic moorings
+ real fltloc(nflt,3)
+c
+c --- 2-d local arrays used for the 16-point box horizontal interpolation
+ real varb2d(4,4),ptlon(4,4,3),ptlat(4,4,3)
+ logical maskpt(4,4,3),maskpi(4,4)
+c
+c --- arrays required for parallelization
+ real flt1(12*nflt),flt3(17*nflt)
+ integer iproc
+c
+ real timer1, timer2, totime
+ real*8 wtime
+c
+ include 'stmt_fns.h'
+c
+c -------------------------------------------------------------------------
+c --- floats.f (hycom version 2.2)
+c -------------------------------------------------------------------------
+c
+c --- synthetic floats, drifters, and mooring instruments
+c
+c --- optionally samples time series of dynamical/thermodynamical variables
+c --- at the location of each float
+c
+c --- four float types are presently supported:
+c --- 3-d lagrangian (vertically advected by diagnosed vertical velocity)
+c --- isopycnic (remains on specified density surface)
+c --- isobaric (remains at the pressure depth where it was released)
+c --- stationary (synthetic instrument/mooring)
+c
+c --- horizontal advection, along with vertical advection of lagrangian floats,
+c --- is performed using the MICOM runga-kutta-4 time interpolation algorithm
+c --- developed by Zulema Garraffo
+c
+c --- works on any curvilinear grid
+c
+c --- float position is stored as longitude and latitude
+c
+c --- to horizontal advect the float, u and v are first converted to
+c --- d(longitude)/dt and d(latitude)/dt as follows:
+c
+c --- u_lon = u*dlondx + v*dlondy
+c --- v_lat = u*dlatdx + v*dlatdy
+c
+c --- to horizontally advect the float, terms u*dlondx and u*dlatdx are
+c --- calculated on u grid points while terms v*dlondy and v*dlatdy are
+c --- calculated on v grid ponts. these terms are then interpolated to
+c --- the float locations from the surrounding u and v grid points,
+c --- respectively
+c
+c --- since the terms v*dlondy and u*dlatdx are always zero when the model
+c --- x,y axes are everywhere lines of constant latitude and longitude,
+c --- respectively, logical variable 'nonlatlon' prevents horizontal
+c --- interpolation of these terms in this case
+c
+c --- horizontal interpolation to the float location follows the MICOM
+c --- procedure of Zulema Garraffo - second-order interpolation from the 16
+c --- surrounding grid points is performed unless fewer than nptmin (presently
+c --- set to 10 in subroutine intrph) water points are available, in which
+c --- case nearest-neighbor interpolation is used.
+c
+c --- variables are horizontally interpolated from their native grid (p, u,
+c --- or v)
+c
+c --- adapted for hycom by george halliwell
+c --- code parallelized by remy baraille
+c
+c --- the second-order interpolation subroutine included here is the one
+c --- included in the mariano and brown parameter matrix objective analysis
+c --- algorithm to estimate the large scale trend surface - it is different
+c --- from the algorithm used by Garraffo in MICOM
+c
+c --- float initialization is performed in floats_init - information
+c --- about the input file containing initial float information is
+c --- presented in that subroutine.
+c
+c --- variables in array flt(nfl,n) are:
+c
+c --- n = 1 longitude
+c --- n = 2 latitude
+c --- n = 3 float depth
+c --- n = 4 water depth
+c --- n = 5 temperature
+c --- n = 6 salinity
+c --- n = 7 water density
+c --- n = 8 float start time (in days from start of model run)
+c --- n = 9 float end time (in days from start of model run)
+c
+c --- time series of several variables are interpolated to the location of each
+c --- float and saved every nflsam time steps when ioflag is set to 1
+c
+c --- variables output onto file float.out for each float are:
+c
+c --- 1. initial sequential float number
+c --- 2. time (in days from start of model run)
+c --- 3. model layer number that contains the float
+c --- 4. longitude (u for synthetic moorings)
+c --- 5. latitude (v for synthetic moorings)
+c --- 6. float depth (w for synthetic moorings)
+c --- 7. water depth
+c --- 8. temperature
+c --- 9. salinity
+c --- 10. water density (remains constant for isopycnic floats)
+c
+ call xctilr(dp( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_ps)
+ call xctilr(dpu( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_vs)
+ call xctilr(dpv( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_vs)
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_vv)
+ call xctilr(ubavg( 1-nbdy,1-nbdy, n),1, 1, 6,6, halo_uv)
+ call xctilr(vbavg( 1-nbdy,1-nbdy, n),1, 1, 6,6, halo_vv)
+ call xctilr(temp( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_ps)
+ call xctilr(saln( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_ps)
+ call xctilr(th3d( 1-nbdy,1-nbdy,1,n),1,kk, 6,6, halo_ps)
+c
+c --- calculate vertical velocity at interfaces as the sum of the
+c --- vertical interface velocity estimated in cnuity.f and the
+c --- advective component due to flow parallel to interfaces.
+c --- wvelup and wveldn represent velocity at the top and bottom of
+c --- layer k
+c
+ margin = 6
+c
+c --- set pressure array at p points
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ k1=k+1
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ enddo
+ enddo
+ enddo
+ enddo
+c
+c --- set pressure array at u and v points
+c --- calculate dpdx, dpdy at interfaces above and below layer k for
+c --- estimating wvel within layer k
+c
+ do k=1,kk
+c
+ margin = 5
+c
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,n)
+ if (wvelfl) then
+ dpdxup(i,j)=
+ & (p(i,j,k )*scpy(i,j)-p(i-1,j,k )*scpy(i-1,j))
+ & /scu2(i,j)
+ dpdxdn(i,j)=
+ & (p(i,j,k+1)*scpy(i,j)-p(i-1,j,k+1)*scpy(i-1,j))
+ & /scu2(i,j)
+ endif
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,n)
+ if (wvelfl) then
+ dpdyup(i,j)=
+ & (p(i,j,k )*scpx(i,j)-p(i,j-1,k )*scpx(i,j-1))
+ & /scv2(i,j)
+ dpdydn(i,j)=
+ & (p(i,j,k+1)*scpx(i,j)-p(i,j-1,k+1)*scpx(i,j-1))
+ & /scv2(i,j)
+ endif
+ enddo
+ enddo
+c
+ enddo !j
+c
+c --- calculate the vertical velocity arrays
+c
+ margin = 4
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (wvelfl) then
+ wveli(i,j,k+1)=deltfl*wveli(i,j,k+1)/delt1
+ if (dp(i,j,k,n).gt.tencm) then
+ wvelup(i,j,k)=-0.5*deltfl*
+ & ((u(i ,j ,k,n)+ubavg(i ,j ,n))*dpdxup(i ,j )+
+ & (u(i+1,j ,k,n)+ubavg(i+1,j ,n))*dpdxup(i+1,j )+
+ & (v(i ,j ,k,n)+vbavg(i ,j ,n))*dpdyup(i ,j )+
+ & (v(i ,j+1,k,n)+vbavg(i ,j+1,n))*dpdyup(i ,j+1))
+ & /onem+wveli(i,j,k )
+ wveldn(i,j,k)=-0.5*deltfl*
+ & ((u(i ,j ,k,n)+ubavg(i ,j ,n))*dpdxdn(i ,j )+
+ & (u(i+1,j ,k,n)+ubavg(i+1,j ,n))*dpdxdn(i+1,j )+
+ & (v(i ,j ,k,n)+vbavg(i ,j ,n))*dpdydn(i ,j )+
+ & (v(i ,j+1,k,n)+vbavg(i ,j+1,n))*dpdydn(i ,j+1))
+ & /onem+wveli(i,j,k+1)
+ else
+ wvelup(i,j,k)=0.0
+ wveldn(i,j,k)=0.0
+ endif
+ endif
+ enddo
+ enddo
+ enddo !j
+c
+ enddo !k
+c
+* call xctilr(wvelup(1-nbdy,1-nbdy,1),1, kk, 4,4, halo_ps)
+* call xctilr(wveldn(1-nbdy,1-nbdy,1),1, kk, 4,4, halo_ps)
+c
+c --- set old velocity indices used for interpolation of float position
+c --- perform full float update every two times this subroutine is called;
+c --- at the intermediate times, just store old velocity fields for the next
+c --- call
+c
+ if (mod(nstepfl,nfladv).eq.nfldta) then
+ kold1 =kk
+ kold1w=kk+1
+ kold2 =0
+ kold2w=0
+ go to 10
+ else
+ kold1 =0
+ kold1w=0
+ kold2 =kk
+ kold2w=kk+1
+ endif
+c
+c --- turbulent horizontal velocity option
+c
+c --- to customize the parameter settings in blkdat.input that control
+c --- the calculated turbulent velocity (tbvar, tdecri), refer to
+c --- Griffa (1996), "Aplications of stochastic particles models to
+c --- oceanographic problems" in "Stochatic Modelling in Physical
+c --- Oceanography", pp. 114-140, Adler, Muller, and Rozovoskii, editors
+c
+ if (turbvel) then
+c
+c --- initialize random seeds and create random number table
+c --- if iflag=1 (iflag=0), then time() is (is not) used to generate seeds
+c
+ iflag=1
+ call system_clock(inisee)
+ seed = 414957000-inisee
+ iede = iseed1
+ ied = iseed2
+ if (iede .lt. 0) iede = iabs(iede)
+ if (ied .lt. 0) ied = iabs(ied)
+c
+ call rantab_ini(rtab,iseed1,iseed2,iflag)
+ endif
+c
+c --- get particle locations from processor 1
+ if (mnproc.eq.1) then
+ do nfl=1,nflt
+ do i=1,9
+ flt1( i+12*(nfl-1)) = flt(nfl,i)
+ enddo
+ flt1(10+12*(nfl-1)) = kfloat(nfl)
+ flt1(11+12*(nfl-1)) = iflnum(nfl)
+ flt1(12+12*(nfl-1)) = ifltyp(nfl)
+ enddo
+ endif !1st tile
+ call xcastr(flt1(1:12*nflt), 1)
+ if (mnproc.ne.1) then
+ do nfl=1,nflt
+ do i=1,9
+ flt(nfl,i) = flt1( i+12*(nfl-1))
+ enddo
+ kfloat(nfl) = flt1(10+12*(nfl-1))
+ iflnum(nfl) = flt1(11+12*(nfl-1))
+ ifltyp(nfl) = flt1(12+12*(nfl-1))
+ enddo
+ endif !1st tile
+c
+c ----------------------
+c --- begin float loop
+c ----------------------
+c
+ do nfl=1,nflt
+c
+c --- skip if float has previously run aground or exceeded termination time
+ if(flt(nfl,1).le.-999.) then
+ go to 22
+ endif
+c
+c --- ier = error flag for horizontal interpolation
+c --- ntermn = float termination flag
+c --- -10 => reached termination time
+c --- -5 => exited domain
+c --- >0 => ran aground
+c --- ifladv = float horizontal advection flag
+ ier=0
+ ntermn=0
+ ifladv=1
+c
+c --- suppress float advection if this is the first time step so that
+c --- the initial position on the output file is exactly the position
+c --- specified on the input file
+ if (nstepfl.eq.1) then
+ ifladv=0
+ endif
+c
+c --- check if model time has reached float deployment time
+c --- when it does, again suppress float advection during first pass
+ if (timefl-flt(nfl,8).lt.-0.001) then
+ go to 22
+ endif
+ if (kfloat(nfl).lt.0) then
+ ifladv=0
+ endif
+c
+c --- check if model time has reached float termination time
+ if (flt(nfl,9).gt.0.0 .and.
+ & timefl-flt(nfl,9).gt. 0.001) then
+ ntermn=-10
+ endif
+c
+c ---------------------------------------------------------------------------
+c --- search for the processor controlling the tile containing the grid point
+c --- search for the surrounding 16 grid points on the p, u, and v grids
+c ---------------------------------------------------------------------------
+c
+c --- processeur sur lequel va se derouler le calcul
+c
+ iproc=0
+c
+ margin = 0
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- search for the surrounding p-grid points
+ if (i+i0.lt.itdm .and. j+j0.lt.jtdm) then
+ alomin=min(plon(i ,j),plon(i ,j+1),
+ & plon(i+1,j),plon(i+1,j+1))
+ alomax=max(plon(i ,j),plon(i ,j+1),
+ & plon(i+1,j),plon(i+1,j+1))
+ alamin=min(plat(i ,j),plat(i ,j+1),
+ & plat(i+1,j),plat(i+1,j+1))
+ alamax=max(plat(i ,j),plat(i ,j+1),
+ & plat(i+1,j),plat(i+1,j+1))
+ if (flt(nfl,1).ge.alomin.and.flt(nfl,1).lt.alomax.and.
+ & flt(nfl,2).ge.alamin.and.flt(nfl,2).lt.alamax) then
+ ifltll(1)=i
+ jfltll(1)=j
+c
+c --- determine if float has exited domain
+ if (i+i0.lt.2 .or. i+i0.gt.itdm-1 .or.
+ & j+j0.lt.2 .or. j+j0.gt.jtdm-1) then
+ ntermn=-5
+ endif
+c
+c --- search for the surrounding u-grid points
+ do i1=i-1,i+1
+ do j1=j-1,j+1
+ if (i1+i0.lt.itdm .and. j1+j0.lt.jtdm) then
+ alomin=min(ulon(i1 ,j1),ulon(i1 ,j1+1),
+ & ulon(i1+1,j1),ulon(i1+1,j1+1))
+ alomax=max(ulon(i1 ,j1),ulon(i1 ,j1+1),
+ & ulon(i1+1,j1),ulon(i1+1,j1+1))
+ alamin=min(ulat(i1 ,j1),ulat(i1 ,j1+1),
+ & ulat(i1+1,j1),ulat(i1+1,j1+1))
+ alamax=max(ulat(i1 ,j1),ulat(i1 ,j1+1),
+ & ulat(i1+1,j1),ulat(i1+1,j1+1))
+ if (flt(nfl,1).ge.alomin .and.
+ & flt(nfl,1).lt.alomax .and.
+ & flt(nfl,2).ge.alamin .and.
+ & flt(nfl,2).lt.alamax) then
+ ifltll(2)=i1
+ jfltll(2)=j1
+c
+c --- determine if float has exited domain
+ if (i1+i0.lt.2 .or. i1+i0.gt.itdm-1 .or.
+ & j1+j0.lt.2 .or. j1+j0.gt.jtdm-1) then
+ ntermn=-5
+ endif
+ go to 11
+ endif
+ endif
+ enddo !j1
+ enddo !i1
+ 11 continue
+c
+c --- search for the surrounding v-grid points
+ do i1=i-1,i+1
+ do j1=j-1,j+1
+ if (i1+i0.lt.itdm .and. j1+j0.lt.jtdm) then
+ alomin=min(vlon(i1 ,j1),vlon(i1 ,j1+1),
+ & vlon(i1+1,j1),vlon(i1+1,j1+1))
+ alomax=max(vlon(i1 ,j1),vlon(i1 ,j1+1),
+ & vlon(i1+1,j1),vlon(i1+1,j1+1))
+ alamin=min(vlat(i1 ,j1),vlat(i1 ,j1+1),
+ & vlat(i1+1,j1),vlat(i1+1,j1+1))
+ alamax=max(vlat(i1 ,j1),vlat(i1 ,j1+1),
+ & vlat(i1+1,j1),vlat(i1+1,j1+1))
+ if (flt(nfl,1).ge.alomin .and.
+ & flt(nfl,1).lt.alomax .and.
+ & flt(nfl,2).ge.alamin .and.
+ & flt(nfl,2).lt.alamax) then
+ ifltll(3)=i1
+ jfltll(3)=j1
+c
+c --- determine if float has exited domain
+ if (i1+i0.lt.2 .or. i1+i0.gt.itdm-1 .or.
+ & j1+j0.lt.2 .or. j1+j0.gt.jtdm-1) then
+ ntermn=-5
+ endif
+ go to 12
+ endif
+ endif
+ enddo !j1
+ enddo !i1
+ 12 continue
+c
+c --- set processor number for the tile containing the float and exit grid
+c --- point search
+ iproc=mnproc
+ go to 13
+ endif
+ endif
+ enddo !i
+ enddo !l
+ enddo !j
+c
+ 13 continue
+c
+c --- float nfl is now updated by the processor running the tile containing
+c --- the float
+c
+ if (iproc.gt.0) then
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,100) nfl,nflt,nstep,nstepfl
+ write(lp,101) nfl,ntermn,flt(nfl,1),flt(nfl,2),
+ & (ifltll(i)+i0,jfltll(i)+j0,i=1,3),
+ & mnproc,
+ & plon(ifltll(1),jfltll(1)),
+ & plat(ifltll(1),jfltll(1))
+ 100 format(/'diagnostics for float',i6,' of',i6,', time step',
+ & i9/'float time step',i9)
+ 101 format('float',i6,' ntermn:',i6,' position:',2(1pe12.4)/
+ & 'lower left points, p,u,v:',3(2i5,2x)/
+ & 'mnproc =',i4,' plon,plat =',1pe12.4,1pe12.4)
+ call flush(lp)
+ endif !nfl_debug
+c
+c --- if float has exited domain or run aground as determined previously,
+c --- jump ahead to the float termination code bloci
+ if (ntermn.eq.-5 .or. ntermn.eq.1) then
+ go to 30
+ endif
+c
+c --- set ptlon, ptlat for all horizontal interpolations from each grid
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ ptlon(i1,j1,ngrid)=plon(i,j)
+ ptlat(i1,j1,ngrid)=plat(i,j)
+ enddo
+ enddo
+c
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ ptlon(i1,j1,ngrid)=ulon(i,j)
+ ptlat(i1,j1,ngrid)=ulat(i,j)
+ enddo
+ enddo
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ ptlon(i1,j1,ngrid)=vlon(i,j)
+ ptlat(i1,j1,ngrid)=vlat(i,j)
+ enddo
+ enddo
+c
+c --- the float is assumed to remain within the same layer that it was in
+c --- during the previous update unless it is the first advection time step
+c --- for the float, in which case it is initially assumed to be in layer 1
+c
+ k=max(1,kfloat(nfl))
+c
+c --- mask p grid points that are on land or where the layer containing the
+c --- float is a zero or nearly-zero thickness layer at the bottom
+ ngrid=1
+ ngood(ngrid)=0
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (depths(i,j).lt.0.01 .or. depths(i,j).eq.huge .or.
+ & depths(i,j)*onem-p(i,j,k).lt.tencm) then
+ maskpt(i1,j1,ngrid)=.true.
+ else
+ maskpt(i1,j1,ngrid)=.false.
+ ngood(ngrid)=ngood(ngrid)+1
+ endif
+ enddo
+ enddo
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,102) ngood(1)
+ 102 format('initial masking: no. of good p points',i4)
+ endif !nfl_debug
+c
+c --------------------------------------------------
+c --- determine the model layer containing the float
+c --------------------------------------------------
+c
+c --- if this is not the first advection time step for the float, determine
+c --- if the float has transited to another model layer
+c
+ if (kfloat(nfl).ge.1) then
+c
+c --- check if the float is deeper than the interpolated bottom
+c --- depth - if so, reset the depth to 0.1 m above the bottom - this
+c --- prevents from running aground too frequently in coastal regions
+ if (ifltyp(nfl).ne.4) then
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,kk+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,plo,ier)
+ flt(nfl,3)=max(fldepm,min(flt(nfl,3),(plo-tencm)/onem))
+ endif
+c
+c --- has the float remained in the same layer?
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,k)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,phi,ier)
+c
+c --- terminate float because it has run aground
+ if (ier.eq.999) then
+ ntermn=2
+ go to 30
+ endif
+c
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,plo,ier)
+ phi=phi/onem
+ plo=plo/onem
+c
+c --- if the float is in the same model layer, skip ahead
+ if (flt(nfl,3).gt.phi .and. flt(nfl,3).le.plo) then
+ kflt=kfloat(nfl)
+ go to 40
+ endif
+c
+c --- determine the new model layer containing the float
+c
+c --- did the float move up one layer?
+ if (flt(nfl,3).le.phi .and. kfloat(nfl).gt.1) then
+ k=kfloat(nfl)-1
+ plo=phi
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,k)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,phi,ier)
+ phi=phi/onem
+ if (flt(nfl,3).gt.phi .and. flt(nfl,3).le.plo) then
+ kflt=k
+ go to 40
+ endif
+ endif
+c
+c --- did the float move down one layer?
+ if (flt(nfl,3).gt.plo .and. kfloat(nfl).lt.kk) then
+ k=kfloat(nfl)+1
+ phi=plo
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,k)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,plo,ier)
+ plo=plo/onem
+ if (flt(nfl,3).gt.phi .and. flt(nfl,3).le.plo) then
+ kflt=k
+ go to 40
+ endif
+ endif
+c
+ endif
+c
+c --- if the float did not move up or down one layer, or if this is the
+c --- first time step after float initialization, search for the layer
+c --- containg the float from top to bottom
+ ngrid=1
+ plo=0.
+ k2=0
+ k3=0
+ do k=1,kk
+ k1=min(k+3,kk+1)
+c
+c --- if the depth of interface k1 is not deeper than the float at any
+c --- surrounding grid points, skip to end of k-loop
+ if (k2.eq.0) then
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (.not.maskpt(i1,j1,ngrid) .and.
+ & p(i,j,k1)/onem.gt.flt(nfl,3)) then
+ k2=1
+ endif
+ enddo
+ enddo
+ endif
+ if (k2.eq.0) then
+ go to 42
+ endif
+c
+c --- mask points where the layer being tested rests on the bottom
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (k2.eq.1) then
+ maskpi(i1,j1)=maskpt(i1,j1,ngrid)
+ endif
+ if (.not.maskpi(i1,j1) .and.
+ & depths(i,j)*onem-p(i,j,k).lt.tencm) then
+ maskpi(i1,j1)=.true.
+ ngood(ngrid)=ngood(ngrid)-1
+ endif
+ enddo
+ enddo
+ k2=2
+c
+c --- if too few good points remain, float has run aground
+ if (ngood(ngrid).le.2) then
+ ntermn=3
+ go to 30
+ endif
+c
+c --- interpolate to find plo
+ phi=plo
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=p(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,plo,ier)
+ plo=plo/onem
+ if(plo-phi.gt.0.1) then
+ k3=k
+ else
+ kflt=k3
+ do i1=1,4
+ do j1=1,4
+ maskpt(i1,j1,ngrid)=maskpi(i1,j1)
+ enddo
+ enddo
+ go to 40
+ endif
+ if (flt(nfl,3).lt.plo) then
+ kflt=k
+ do i1=1,4
+ do j1=1,4
+ maskpt(i1,j1,ngrid)=maskpi(i1,j1)
+ enddo
+ enddo
+ go to 40
+ endif
+ 42 continue
+ enddo
+c
+c --- if layer selection fails, assume float has run aground
+ print *,'warning - selection of float layer failed'
+ ntermn=4
+ go to 30
+c
+c --- we now know the model layer containing the float
+ 40 kfloat(nfl)=kflt
+c
+c ------------------------------------------
+c --- set grid masks for u and v grid points
+c ------------------------------------------
+c
+ k=kflt
+ ngrid=2
+ ngood(ngrid)=0
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (depthu(i,j).lt.onecm .or. depthu(i,j).eq.huge .or.
+ & depthu(i,j)-pu(i,j,k).lt.tencm) then
+ maskpt(i1,j1,ngrid)=.true.
+ else
+ maskpt(i1,j1,ngrid)=.false.
+ ngood(ngrid)=ngood(ngrid)+1
+ endif
+ enddo
+ enddo
+c
+ ngrid=3
+ ngood(ngrid)=0
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (depthv(i,j).lt.onecm .or. depthv(i,j).eq.huge .or.
+ & depthv(i,j)-pv(i,j,k).lt.tencm) then
+ maskpt(i1,j1,ngrid)=.true.
+ else
+ maskpt(i1,j1,ngrid)=.false.
+ ngood(ngrid)=ngood(ngrid)+1
+ endif
+ enddo
+ enddo
+c
+c --- if too few good p, u, v grid points, assume float has run aground
+ if (ngood(1).le.2 .or. ngood(2).le.2 .or. ngood(3).le.2) then
+ ntermn=5
+ go to 30
+ endif
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,103) nfl,k,phi,flt(nfl,3),plo,q
+ write(lp,104) ngood
+ 103 format('nfl,k,phi,pflt,plo,q',i6,i3,1p,4e12.4)
+ 104 format('number of good points, p,u,v',3i4)
+ endif !nfl_debug
+c
+c --- set vertical indices, and also set q for vertical interpolation
+ k=kfloat(nfl)
+ k1=max(1,k-1)
+ k2=min(kk,k+1)
+ q=(plo-flt(nfl,3))/max(0.001,plo-phi)
+c
+c ----------------------------------------------------------
+c --- advect the float horizontally, then move it vertically
+c --- do not move float if it is a mooring instrument
+c ----------------------------------------------------------
+c
+c ----------------------------------
+c --- horizontal advection of floats
+c ----------------------------------
+c
+ if (ifltyp(nfl).ne.4) then
+c
+c --- interpolate u,v to float location - velocities at the new time and
+c --- at two earlier times are used for the runga-kutta time interpolation
+c
+ xpos0=flt(nfl,1)
+ ypos0=flt(nfl,2)
+c
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondx(i,j)*uold2(i,j,k+kold2)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,uflt1,ier)
+c
+c --- terminate float because it has run aground
+ if (ier.eq.999) then
+ ntermn=6
+ go to 30
+ endif
+c
+ if (nonlatlon) then
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondy(i,j)*vold2(i,j,k+kold2)
+ enddo
+ enddo
+ if (l.eq.1) then
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,ufltm,ier)
+ uflt1=uflt1+ufltm
+ endif
+c
+c --- terminate float because it has run aground
+ if (ier.eq.999) then
+ ntermn=7
+ go to 30
+ endif
+ endif
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdy(i,j)*vold2(i,j,k+kold2)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vflt1,ier)
+c
+c --- terminate float because it has run aground
+ if (ier.eq.999) then
+ ntermn=8
+ go to 30
+ endif
+c
+ if (nonlatlon) then
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdx(i,j)*uold2(i,j,k+kold2)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vfltm,ier)
+ vflt1=vflt1+vfltm
+c
+c --- terminate float because it has run aground
+ if (ier.eq.999) then
+ ntermn=9
+ go to 30
+ endif
+ endif
+c
+ xpos1=flt(nfl,1)+uflt1
+ ypos1=flt(nfl,2)+vflt1
+c
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondx(i,j)*uold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos1,ypos1,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,uflt2,ier)
+c
+ if (nonlatlon) then
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondy(i,j)*vold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,ufltm,ier)
+ uflt2=uflt2+ufltm
+ endif
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdy(i,j)*vold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos1,ypos1,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vflt2,ier)
+c
+ if (nonlatlon) then
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdx(i,j)*uold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vfltm,ier)
+ vflt2=vflt2+vfltm
+ endif
+c
+ xpos2=flt(nfl,1)+uflt2
+ ypos2=flt(nfl,2)+vflt2
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondx(i,j)*uold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos2,ypos2,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,uflt3,ier)
+c
+ if (nonlatlon) then
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondy(i,j)*vold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,ufltm,ier)
+ uflt3=uflt3+ufltm
+ endif
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdy(i,j)*vold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos2,ypos2,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vflt3,ier)
+c
+ if (nonlatlon) then
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdx(i,j)*uold2(i,j,k+kold1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vfltm,ier)
+ vflt3=vflt3+vfltm
+ endif
+c
+ endif
+c
+ if (ifltyp(nfl).ne.4) then
+ xpos3=flt(nfl,1)+2.0*uflt3
+ ypos3=flt(nfl,2)+2.0*vflt3
+ else
+ xpos3=flt(nfl,1)
+ ypos3=flt(nfl,2)
+ endif
+c
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (ifltyp(nfl).ne.4) then
+ varb2d(i1,j1)=dlondx(i,j)*(u(i,j,k,n)+ubavg(i,j,n))
+ else
+ varb2d(i1,j1)=u(i,j,k,n)+ubavg(i,j,n)
+ endif
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos3,ypos3,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,uflt4,ier)
+c
+ if (nonlatlon .and. ifltyp(nfl).ne.4) then
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondy(i,j)*(v(i,j,k,n)+vbavg(i,j,n))
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,ufltm,ier)
+ uflt4=uflt4+ufltm
+ endif
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (ifltyp(nfl).ne.4) then
+ varb2d(i1,j1)=dlatdy(i,j)*(v(i,j,k,n)+vbavg(i,j,n))
+ else
+ varb2d(i1,j1)=v(i,j,k,n)+vbavg(i,j,n)
+ endif
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos3,ypos3,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vflt4,ier)
+c
+ if (nonlatlon .and. ifltyp(nfl).ne.4) then
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdx(i,j)*(u(i,j,k,n)+ubavg(i,j,n))
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vfltm,ier)
+ vflt4=vflt4+vfltm
+ endif
+c
+ if (ifltyp(nfl).ne.4) then
+ uflt=(uflt1+2.0*uflt2+2.0*uflt3+uflt4)/6.0
+ vflt=(vflt1+2.0*vflt2+2.0*vflt3+vflt4)/6.0
+c
+c --- add turbulent velocity to u and v if requested
+c
+ if (turbvel) then
+ call rantab(rtab,iseed1,iseed2,numran)
+ uturb=uturb0*rtab(numran, 2)
+ call rantab(rtab,iseed1,iseed2,numran)
+ vturb=uturb0*rtab(numran, 2)
+c
+c --- convert uturb, vturb to d(longitude)/dt, d(latitude)/dt
+c --- interpolate dlondx, dlondy, dlatdx, dlatdy to the float location
+c
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondx(i,j)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,dlodx,ier)
+ if (nonlatlon) then
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdx(i,j)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,dladx,ier)
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlondy(i,j)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,dlody,ier)
+ else
+ dladx=0.0
+ dlody=0.0
+ endif
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=dlatdy(i,j)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,dlady,ier)
+c
+c --- add turbulent velocity to uflt, vflt
+c
+ uturb1=uturb*dlodx+vturb*dlody
+ vturb1=uturb*dladx+vturb*dlady
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,105) nfl,uflt,uturb1,vflt,vturb1
+ 105 format('nfl,uflt,uturb1,vflt,vturb1',i5,1p,4e12.4)
+ endif !nfl_debug
+c
+ uflt=(1.0-dtturb*tdecri)*uflt+uturb1
+ vflt=(1.0-dtturb*tdecri)*vflt+vturb1
+c
+ endif
+c
+c --- update float horizontal position
+c
+ if (ifladv.eq.1) then
+ flt(nfl,1)=flt(nfl,1)+2.0*deltfl*uflt
+ flt(nfl,2)=flt(nfl,2)+2.0*deltfl*vflt
+ endif
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,106) nfl,flt(nfl,1),xpos1,xpos2,xpos3,
+ & uflt1,uflt2,uflt3,uflt4,2.0*deltfl*uflt
+ write(lp,107) nfl,flt(nfl,2),ypos1,ypos2,ypos3,
+ & vflt1,vflt2,vflt3,vflt4,2.0*deltfl*vflt
+ write(lp,108) nfl,uflt,vflt,flt(nfl,1),flt(nfl,2)
+ 106 format('nfl,x-position',i6,1p,4e12.4/' u-velocity',6x,5e12.4)
+ 107 format('nfl,y-position',i6,1p,4e12.4/' v-velocity',6x,5e12.4)
+ 108 format('nfl,udeg,vdeg',i6,1p,2e13.5/'new position',2e13.5)
+ endif !nfl_debug
+c
+ endif
+c
+c -----------------------------------------------
+c --- vertical advection of 3-d lagrangian floats
+c -----------------------------------------------
+c
+c --- horizontally interpolate diagnosed vertical velocity to the float
+c --- location at the new time and at two earlier times to execute the
+c --- runga-kutta time interpolation
+c
+ if (wvelfl .and. ifltyp(nfl).eq.1) then
+c
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ wvhi=wold2u(i,j,k+kold2)
+ wvlo=wold2d(i,j,k+kold2)
+ varb2d(i1,j1)=q*wvhi+(1.0-q)*wvlo
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos0,ypos0,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,wflt1,ier)
+c
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ wvhi=wold2u(i,j,k+kold1)
+ wvlo=wold2d(i,j,k+kold1)
+ varb2d(i1,j1)=q*wvhi+(1.0-q)*wvlo
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos1,ypos1,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,wflt2,ier)
+c
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos2,ypos2,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,wflt3,ier)
+c
+ endif
+c
+ if (wvelfl) then
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ wvhi=wvelup(i,j,k)
+ wvlo=wveldn(i,j,k)
+ varb2d(i1,j1)=q*wvhi+(1.0-q)*wvlo
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & xpos3,ypos3,maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,wflt4,ier)
+ endif
+c
+ if (ifltyp(nfl).eq.1) then
+c
+c --- dividing by 3 gives total vertical displacement over interval 2*deltfl
+ wflt=(wflt1+2.0*wflt2+2.0*wflt3+wflt4)/3.0
+ if (ifladv.eq.1) then
+ flt(nfl,3)=max(fldepm,flt(nfl,3)-wflt)
+ endif
+ if (nfl.eq.nfl_debug) then
+ write(lp,109) nfl,wflt,flt(nfl,3)
+ 109 format('nfl,w,new depth',i6,1p,2e13.5)
+ endif !nfl_debug
+c
+ elseif (ifltyp(nfl).eq.2) then
+c
+c ---------------------------------------
+c --- vertical motion of isopycnic floats
+c ---------------------------------------
+c
+c --- set float depth to the vertically interpolated depth of the specified
+c --- density interface
+c
+c --- assume float runs aground if no water denser than the specified density
+c --- exists in the water column
+c
+c --- limit float depth to fldepm if no water lighter than the specified
+c --- density exists in the water column
+c
+c --- find smallest k where float density is exceeded by the density in
+c --- layer k at at least one of the good 16 surrounding grid points
+ thflt=flt(nfl,7)-thbase
+ ngrid=1
+ ngoodi=ngood(ngrid)
+ do k=1,kk
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ maskpi(i1,j1)=maskpt(i1,j1,ngrid)
+ if (.not.maskpi(i1,j1)) then
+ if (th3d(i,j,k,n).gt.thflt) then
+ kflt=k
+ go to 33
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+ 33 continue
+c
+c --- move downward from layer kflt to find the two layers with densities
+c --- bracketing the assigned float density
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (.not.maskpi(i1,j1)) then
+ if (kflt.eq.1) then
+ phi=0.
+ plo=.5*dp(i,j,kflt,n)/onem
+ thflt=flt(nfl,7)-thbase
+ if(thflt.le.th3d(i,j,kflt,n)) then
+ varb2d(i1,j1)=max(fldepm,plo)
+ go to 50
+ endif
+ endif
+ do k=max(2,kflt),kk
+ phi=p(i,j,k-1)/onem
+ plo=p(i,j,k )/onem
+ thhi=th3d(i,j,k-1,n)
+ thlo=th3d(i,j,k ,n)
+ if(thflt.gt.thhi .and. thflt.le.thlo) then
+ qisop=max(0.0,min(1.0,(thlo-thflt)/
+ & max(epsil,thlo-thhi)))
+ varb2d(i1,j1)=max(fldepm,qisop*phi+(1.-qisop)*plo)
+ if (depths(i,j)-varb2d(i1,j1).lt.0.1) then
+ maskpi(i1,j1)=.true.
+ ngoodi=ngoodi-1
+ endif
+ go to 50
+ endif
+ enddo
+ 50 continue
+ endif
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpi,
+ & ngoodi,ngrid,intpfl,radian,depiso,ier)
+ flt(nfl,3)=max(fldepm,depiso)
+ if (nfl.eq.nfl_debug) then
+ write(lp,110) nfl,flt(nfl,3)
+ 110 format('nfl,new isopycnic depth',i6,1p,e13.5)
+ endif !nfl_debug
+c
+ elseif (ifltyp(nfl).eq.4) then
+c
+ wflt=wflt4/deltfl
+c
+ endif
+c
+c --------------------------------------------------------------
+c --- interpolate water properties to the present float location
+c --------------------------------------------------------------
+c
+ if (ioflag.eq.1 .and. samplfl) then
+c
+c --- recalculate q. assume float does not leave the layer that it was
+c --- originally diagnosed to be within.
+c
+ q=max(0.0,min(1.0,(plo-flt(nfl,3))/max(0.001,plo-phi)))
+c
+c --- water depth interpolation
+ if (ifltyp(nfl).ne.4 .or. flt(nfl,4).eq.0.0) then
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=depths(i,j)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & 16,ngrid,intpfl,radian,depflt,ier)
+ flt(nfl,4)=depflt
+ endif
+c
+c --- temperature interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (ifltyp(nfl).eq.4) then
+ k1=max(1 ,k-1)
+ k2=min(kk,k+1)
+ varb2d(i1,j1)=
+ & 0.5*( q *(temp(i,j,k1,n)+temp(i,j,k,n))+
+ & (1.0-q)*(temp(i,j,k2,n)+temp(i,j,k,n)))
+ else
+ varb2d(i1,j1)=temp(i,j,k,n)
+ endif
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,tflt,ier)
+ flt(nfl,5)=tflt
+c
+c --- salinity interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ if (ifltyp(nfl).eq.4) then
+ k1=max(1 ,k-1)
+ k2=min(kk,k+1)
+ varb2d(i1,j1)=
+ & 0.5*( q *(saln(i,j,k1,n)+saln(i,j,k,n))+
+ & (1.0-q)*(saln(i,j,k2,n)+saln(i,j,k,n)))
+ else
+ varb2d(i1,j1)=saln(i,j,k,n)
+ endif
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,sflt,ier)
+ flt(nfl,6)=sflt
+c
+c --- calculate density
+ if (ifltyp(nfl).ne.2) then
+ thflt=sig(tflt,sflt)
+ flt(nfl,7)=thflt
+ else
+ tflt=tofsig(flt(nfl,7),sflt)
+ flt(nfl,5)=tflt
+ endif
+c
+c --- interpolate model fields for float type 4 (stationary)
+ if (ifltyp(nfl).eq.4) then
+c
+c --- 3-d u and v interpolation
+ ngrid=2
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ k1=max(1 ,k-1)
+ k2=min(kk,k+1)
+ varb2d(i1,j1)=ubavg(i,j,n)+
+ & 0.5*( q *(u(i,j,k1,n)+u(i,j,k,n))+
+ & (1.0-q)*(u(i,j,k2,n)+u(i,j,k,n)))
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,uflt,ier)
+c
+ ngrid=3
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ k1=max(1 ,k-1)
+ k2=min(kk,k+1)
+ varb2d(i1,j1)=vbavg(i,j,n)+
+ & 0.5*( q *(v(i,j,k1,n)+v(i,j,k,n))+
+ & (1.0-q)*(v(i,j,k2,n)+v(i,j,k,n)))
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vflt,ier)
+c
+c --- wveli interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=q*wveli(i,j,k)+(1.0-q)*wveli(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,wflt1,ier)
+ flt(nfl,10)=wflt1/deltfl
+c
+c --- vertical viscosity coefficient interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=q*vcty(i,j,k)+(1.0-q)*vcty(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,vkflt,ier)
+ flt(nfl,11)=max(1.0e-4,vkflt)
+c
+c --- vertical temperature diffusivity coefficient interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=q*dift(i,j,k)+(1.0-q)*dift(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,tkflt,ier)
+ flt(nfl,12)=max(1.0e-5,tkflt)
+c
+c --- vertical scalar diffusivity coefficient interpolation
+ ngrid=1
+ do i1=1,4
+ i=i1+ifltll(ngrid)-2
+ do j1=1,4
+ j=j1+jfltll(ngrid)-2
+ varb2d(i1,j1)=q*difs(i,j,k)+(1.0-q)*difs(i,j,k+1)
+ enddo
+ enddo
+ call intrph(varb2d,ptlon(1,1,ngrid),ptlat(1,1,ngrid),
+ & flt(nfl,1),flt(nfl,2),maskpt(1,1,ngrid),
+ & ngood(ngrid),ngrid,intpfl,radian,skflt,ier)
+ flt(nfl,13)=max(1.0e-5,skflt)
+c
+ endif ! float type 4
+c
+ if (nfl.eq.nfl_debug) then
+ write(lp,111) nfl,tflt,sflt,thflt
+ 111 format('new t,s,th, float',i5,2x,3f9.3)
+ endif !nfl_debug
+c
+ endif ! ioflag.eq.1
+c
+c ----------------------------------------------------
+c --- flag floats that have run aground or left domain
+c ----------------------------------------------------
+c
+c --- jump ahead if the float has not reached its termination time
+ if (ntermn.gt.-10) go to 20
+c
+c --- the following code block is entered when the previous code has
+c --- detected that the float needs to be terminated
+ 30 flt(nfl,1)=-999.
+ flt(nfl,2)=-999.
+ if (ntermn.gt.0) then
+ write(lp,112) nfl,nstep,nstepfl,ier,ntermn,ngood
+ 112 format('float',i6,' aground, time step',i9,
+ & ' float time step',i9/' ier ',i3,' exit point',
+ & i3,' ngood 1-4',4i3)
+ elseif (ntermn.eq.-5) then
+ write(lp,113) nfl
+ 113 format('float',i6,' exits domain')
+ elseif (ntermn.eq.-10) then
+ write(lp,114) nfl
+ 114 format('float',i6,' reaches termination time')
+ endif
+c
+ 20 continue
+c
+c ----------------------------------------------------
+c --- store velocity components for synthetic moorings
+c ----------------------------------------------------
+c
+ if (ifltyp(nfl).eq.4) then
+ fltloc(nfl,1)=uflt
+ fltloc(nfl,2)=vflt
+ fltloc(nfl,3)=wflt
+ else
+ fltloc(nfl,1)=0.0
+ fltloc(nfl,2)=0.0
+ fltloc(nfl,3)=0.0
+ endif
+c
+c--- store updated particle location
+c
+ do i=1,13
+ flt3( i+17*(nfl-1)) = flt( nfl,i)
+ enddo
+ do i=1,3
+ flt3(13+i+17*(nfl-1)) = fltloc(nfl,i)
+ enddo
+ flt3(17+17*(nfl-1)) = kfloat(nfl)
+c
+c --- else du premier if de la boucle
+ else !float is not on this tile, so disable flt3
+ do i=1,17
+ flt3(i+17*(nfl-1)) = huge
+ enddo
+ endif
+c
+ go to 222
+c
+ 22 continue
+c
+c --- float is unchanged
+ do i=1,17
+ flt3(i+17*(nfl-1)) = huge
+ enddo
+c
+ 222 continue
+c
+c ---------------------
+c --- end of float loop
+c ---------------------
+c
+ enddo !nfl
+c
+c --- copy floats back to 1st processor
+ call xcminr(flt3(1:17*nflt), 1)
+ if (mnproc.eq.1) then
+ do nfl=1,nflt
+ if (flt3(1+17*(nfl-1)).ne.huge) then
+ do i=1,13
+ flt( nfl,i) = flt3( i+17*(nfl-1))
+ enddo
+ do i=1,3
+ fltloc(nfl,i) = flt3(13+i+17*(nfl-1))
+ enddo
+ kfloat(nfl) = flt3(17+17*(nfl-1))
+ endif !updated float
+ enddo !nfl
+ endif !1st tile
+c
+c -----------------------------------
+c --- output float array for analysis
+c -----------------------------------
+c
+ if (ioflag.eq.1 .and. mnproc.eq.1) then
+c
+ write(lp,*) 'storing float parameters'
+ open(unit=uoff+801,file=flnmflto,status='unknown',
+ & form='formatted',position='append')
+ do nfl=1,nflt
+ if (flt(nfl,1).gt.-999. .and. timefl-flt(nfl,8).ge.-0.001)
+ & then
+c
+ if (samplfl) then
+ if (ifltyp(nfl).ne.4) then
+ write(uoff+801,901) iflnum(nfl),timefl,kfloat(nfl),
+ & (flt(nfl,j),j=1,7)
+ 901 format(i6,f12.4,i3,2f10.4,f14.4,f8.2,3f7.3)
+ else
+ write(uoff+801,902) iflnum(nfl),timefl,kfloat(nfl),
+ & fltloc(nfl,1),fltloc(nfl,2),
+ & fltloc(nfl,3),flt(nfl,10),
+ & (flt(nfl,j),j=4,7),
+ & (flt(nfl,j),j=11,13)
+ 902 format(i6,f12.4,i3,2f10.6,2f14.10,f8.2,3f7.3,1p,3e12.4)
+ endif
+ else
+ if (ifltyp(nfl).ne.4) then
+ write(uoff+801,901) iflnum(nfl),timefl,kfloat(nfl),
+ & (flt(nfl,j),j=1,3)
+ else
+ write(uoff+801,902) iflnum(nfl),timefl,kfloat(nfl),
+ & fltloc(nfl,1),fltloc(nfl,2),
+ & fltloc(nfl,3),flt(nfl,10)
+ endif
+ endif
+ endif
+ enddo
+ close(uoff+801)
+ endif
+c
+c ----------------------------------------------------
+c --- store old velocities for next time interpolation
+c ----------------------------------------------------
+c
+ 10 continue
+c
+ if (hadvfl) then
+c
+ margin = 6
+c
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ do k=1,kk
+ uold2(i,j,k+kold2)=u(i,j,k,n)+ubavg(i,j,n)
+ enddo
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ do k=1,kk
+ vold2(i,j,k+kold2)=v(i,j,k,n)+vbavg(i,j,n)
+ enddo
+ enddo
+ enddo
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ wold2u(i,j,k+kold2)=wvelup(i,j,k)
+ wold2d(i,j,k+kold2)=wveldn(i,j,k)
+ enddo
+ enddo
+ enddo
+c
+ enddo !j
+c
+ endif
+c
+ return
+ end subroutine floats
+
+ subroutine intrph(varb2d,ptlon,ptlat,fllon,fllat,maskpt,
+ & ngood,ngrid,intpfl,radian,vrbint,ier)
+c
+c ----------------------------------------------------
+c --- 2-d polynomial or nearest neighbor interpolation
+c ----------------------------------------------------
+c
+c --- polynomial interpolation code is adapted from the parameter matrix
+c --- objective analysis algorithm of mariano and brown (1994), specifically
+c --- the code used to calculate the large scale 2-d trend surface
+c
+c --- nptmin is presently set to 9
+c
+ implicit none
+ real varb2d(4,4),ptlon(4,4),ptlat(4,4)
+ real fllon,fllat,fllon2,fllat2,vfbint
+ real wghtx,wghty,vrbint,suma,wghts,xcen,ycen,xo,yo,xsd,ysd,var
+ real dx,dy,dxflt,dyflt,det,denom,radian
+ real at(16),xt(16),yt(16),parm(12),rtr(10,10),rtri(10,10),rta(10)
+ integer iarea(200)
+ integer ngood,ngrid,intpfl,ier,iflag,ict,nptmin
+ integer i,j,nd,nds,np,na
+ logical maskpt(4,4)
+c
+c --- nptmin is the minimum number of points required for 2-d interpolation
+c --- to be performed - otherwise, nearest neighbor interpolation is used
+c
+ data nptmin /9/
+c
+c --- na is the row dimension of rtr
+ data na /10/
+c
+c --- set the 1-d arrays of field values and horizontal position
+c --- find and remove central latitude and longitude of the good points
+c --- correct horizontal position for earth's curvature to lowest order
+c
+ ict=0
+ xcen=0.0
+ ycen=0.0
+ do i=1,4
+ do j=1,4
+ if (.not.maskpt(i,j) .or. ngood.eq.16) then
+ ict=ict+1
+ at(ict)=varb2d(i,j)
+ xt(ict)=ptlon(i,j)
+ xcen=xcen+xt(ict)
+ yt(ict)=ptlat(i,j)
+ ycen=ycen+yt(ict)
+ endif
+ enddo
+ enddo
+c
+ np=ict
+c
+ if(np.le.0) then
+ vrbint=0.0
+ ier=999
+ return
+ endif
+c
+c --- set interpolated value to zero if all input values are zero
+ iflag=0
+ do ict=1,np
+ if(at(ict).ne.0.) iflag=1
+ enddo
+ if(iflag.eq.0) then
+ vrbint=0.0
+ return
+ endif
+c
+ xcen=xcen/np
+ ycen=ycen/np
+ denom=cos(ycen*radian)
+c
+ do ict=1,np
+ xt(ict)=(xt(ict)-xcen)*cos(yt(ict)*radian)/denom
+ yt(ict)=(yt(ict)-ycen)*cos(0.5*(yt(ict)+ycen)*radian)/denom
+c
+cdiag write(6,101) ngrid,ngood,ict,at(ict),xt(ict),yt(ict)
+ 101 format('poly. - ngrid,ngood,ict,at,xt,yt:'
+ & /10x,3i4,1p,3e13.5)
+c
+ enddo
+c
+ fllon2=(fllon-xcen)*cos(fllat*radian)/denom
+ fllat2=(fllat-ycen)*cos(0.5*(fllat+ycen)*radian)/denom
+c
+c --- perform the interpolation
+c
+ ier=0
+c
+ if (intpfl.eq.0 .and. ngood.ge.nptmin) then
+c
+c --- 2-d, second order polynomial interpolation
+c
+c --- set parameters for quadratic polynomial and zero the parm array
+ nds=2
+ nd=6
+ do i=1,12
+ parm(i)=0.0
+ enddo
+c
+c --- calculate xo, the mean of xt, and yo, the mean of yt and their
+c --- standard deviations from np observations
+c
+ call f_stat(xt,np,xo,var,xsd)
+ call f_stat(yt,np,yo,var,ysd)
+c
+ do i=1,nd
+ rta(i)=0.0
+ do j=1,nd
+ rtr(i,j)=0.0
+ enddo
+ enddo
+c
+c --- the next part of the code is a little messy, but we save alot of
+c --- disk space by doing it this way
+c
+ do 20 ict=1,np
+ dx=xt(ict)-xo
+ dy=yt(ict)-yo
+ rtr(1,2)=rtr(1,2) + dx
+ rtr(1,3)=rtr(1,3) + dy
+ rtr(2,2)=rtr(2,2) + dx**2
+ rtr(2,3)=rtr(2,3) + dx*dy
+ rtr(3,3)=rtr(3,3) + dy**2
+ rta(1)=rta(1) + at(ict)
+ rta(2)=rta(2) + dx*at(ict)
+ rta(3)=rta(3) + dy*at(ict)
+ if(nds.eq.1) go to 20
+ rtr(2,4)=rtr(2,4) + (dx**3)/2.
+ rtr(3,5)=rtr(3,5) + (dy**3)/2.
+ rtr(4,4)=rtr(4,4) + (dx**4)/4.
+ rtr(5,5)=rtr(5,5) + (dy**4)/4.
+ rtr(3,4)=rtr(3,4) + (dx**2)*dy/2.
+ rtr(2,5)=rtr(2,5) + (dy**2)*dx/2.
+ rtr(4,6)=rtr(4,6) + (dx**3)*dy/2.
+ rtr(5,6)=rtr(5,6) + (dy**3)*dx/2.
+ rtr(6,6)=rtr(6,6) + (dx**2)*(dy**2)
+ rta(4)=rta(4) + (dx**2)*at(ict)/2.
+ rta(5)=rta(5) + (dy**2)*at(ict)/2.
+ rta(6)=rta(6) + dx*dy*at(ict)
+ if(nds.ne.3) go to 20
+ rtr(4,7)=rtr(4,7) + (dx**5)/12.
+ rtr(4,8)=rtr(4,8) + (dx**2)*(dy**3)/12.
+ rtr(4,9)=rtr(4,9) + (dx**4)*dy/4.
+ rtr(4,10)=rtr(4,10) + (dx**3)*(dy**2)/4.
+ rtr(5,8)=rtr(5,8) + (dy**5)/12.
+ rtr(5,10)=rtr(5,10) + dx*(dy**4)/4.
+ rtr(6,7)=rtr(6,7) + dy*(dx**4)/6.
+ rtr(7,7)=rtr(7,7) + (dx**6)/36.
+ rtr(7,8)=rtr(7,8) + (dx**3)*(dy**3)/36.
+ rtr(7,9)=rtr(7,9) + (dx**5)*dy/12.
+ rtr(7,10)=rtr(7,10) + (dx**4)*(dy**2)/12.
+ rtr(8,8)=rtr(8,8) + (dy**6)/36.
+ rtr(8,9)=rtr(8,9) + (dx**2)*(dy**4)/12.
+ rtr(8,10)=rtr(8,10) + dx*(dy**5)/12.
+ rta(7)=rta(7) + (dx**3)*at(ict)/6.
+ rta(8)=rta(8) + (dy**3)*at(ict)/6.
+ rta(9)=rta(9) + (dx**2)*dy*at(ict)/2.
+ rta(10)=rta(10) + (dy**2)*dx*at(ict)/2.
+ 20 continue
+ rtr(1,1)=float(np)
+ rtr(2,1)=rtr(1,2)
+ rtr(3,2)=rtr(2,3)
+ rtr(3,1)=rtr(1,3)
+ if(nds.eq.1) go to 21
+ rtr(1,4)=rtr(2,2)/2.
+ rtr(1,5)=rtr(3,3)/2.
+ rtr(1,6)=rtr(2,3)
+ rtr(2,6)=rtr(3,4)*2.
+ rtr(3,6)=rtr(2,5)*2.
+ rtr(4,5)=rtr(6,6)/4.
+ rtr(4,1)=rtr(1,4)
+ rtr(4,2)=rtr(2,4)
+ rtr(4,3)=rtr(3,4)
+ rtr(5,1)=rtr(1,5)
+ rtr(5,2)=rtr(2,5)
+ rtr(5,3)=rtr(3,5)
+ rtr(5,4)=rtr(4,5)
+ rtr(6,1)=rtr(1,6)
+ rtr(6,2)=rtr(2,6)
+ rtr(6,3)=rtr(3,6)
+ rtr(6,4)=rtr(4,6)
+ rtr(6,5)=rtr(5,6)
+ if(nds.ne.3) go to 21
+ rtr(1,7)=rtr(2,4)/3.
+ rtr(1,8)=rtr(3,5)/3.
+ rtr(1,9)=rtr(2,6)/2.
+ rtr(1,10)=rtr(2,5)
+ rtr(2,7)=2.*rtr(4,4)/3.
+ rtr(2,8)=rtr(5,6)/3.
+ rtr(2,9)=rtr(4,6)
+ rtr(2,10)=2.*rtr(4,5)
+ rtr(3,7)=rtr(4,6)/3.
+ rtr(3,8)=2.*rtr(5,5)/3.
+ rtr(3,9)=2.*rtr(4,5)
+ rtr(3,10)=3.*rtr(2,8)
+ rtr(5,7)=rtr(4,10)/3.
+ rtr(5,9)=rtr(4,8)/3.
+ rtr(6,8)=2.*rtr(5,10)/3.
+ rtr(6,9)=2.*rtr(4,10)
+ rtr(6,10)=2.*rtr(5,9)
+ rtr(7,1)=rtr(1,7)
+ rtr(7,2)=rtr(2,7)
+ rtr(7,3)=rtr(3,7)
+ rtr(7,4)=rtr(4,7)
+ rtr(7,5)=rtr(5,7)
+ rtr(7,6)=rtr(6,7)
+ rtr(8,1)=rtr(1,8)
+ rtr(8,2)=rtr(2,8)
+ rtr(8,3)=rtr(3,8)
+ rtr(8,4)=rtr(4,8)
+ rtr(8,5)=rtr(5,8)
+ rtr(8,6)=rtr(6,8)
+ rtr(8,7)=rtr(7,8)
+ rtr(9,1)=rtr(1,9)
+ rtr(9,2)=rtr(2,9)
+ rtr(9,3)=rtr(3,9)
+ rtr(9,4)=rtr(4,9)
+ rtr(9,5)=rtr(5,9)
+ rtr(9,6)=rtr(6,9)
+ rtr(9,7)=rtr(7,9)
+ rtr(9,8)=rtr(8,9)
+ rtr(9,9)=3.*rtr(7,10)
+ rtr(9,10)=9.*rtr(7,8)
+ rtr(10,1)=rtr(1,10)
+ rtr(10,2)=rtr(2,10)
+ rtr(10,3)=rtr(3,10)
+ rtr(10,4)=rtr(4,10)
+ rtr(10,5)=rtr(5,10)
+ rtr(10,6)=rtr(6,10)
+ rtr(10,7)=rtr(7,10)
+ rtr(10,8)=rtr(8,10)
+ rtr(10,9)=rtr(9,10)
+ rtr(10,10)=3.*rtr(8,9)
+ 21 continue
+c
+c --- invert rtr and store in rtri, na is the row dimension of rtr
+c --- and rtri, det is the determinant, nd is the number of coeff.
+c --- to be estimated, i.e. the number of independent variables in
+c --- rtr, iarea is a work area and ier is an error code. if ier
+c --- is greater than 0, there is an inversion error
+c
+ call f_invmtx(rtr,na,rtri,na,nd,det,iarea,ier)
+ if(ier.gt.0) print *, 'WARNING: INVERSION ERROR, ier= ',ier
+c
+c --- calculate the regression coeff. - parm
+c
+ do i=1,nd
+ do j=1,nd
+ parm(i)=parm(i) + rtri(i,j)*rta(j)
+ enddo
+ enddo
+c
+ parm(11)=xo
+ parm(12)=yo
+ 85 continue
+c
+c --- interpolate the field to the float location
+ dxflt=fllon2-parm(11)
+ dyflt=fllat2-parm(12)
+ vrbint=parm(1)+parm(2)*dxflt+parm(3)*dyflt
+ & +parm(4)*(dxflt**2)/2.+parm(5)*(dyflt**2)/2.+
+ & parm(6)*dxflt*dyflt
+ return
+c
+ else
+c
+c --- 2-d nearest neighbor interpolation if the number of available water
+c --- points is smaller than nptmin. variable xt is inverse distance
+c
+ wghts=0.
+ do ict=1,np
+ xt(ict)=1.0/sqrt(max(1.0e-20,(xt(ict)-fllon2)**2+
+ & (yt(ict)-fllat2)**2))
+ wghts=wghts+xt(ict)
+cdiag write(6,102) ngrid,ngood,i,j,ict,at(ict),xt(ict)
+ 102 format('nearest neighbor - ngrid,ngood,i,j,ict,at,xt:'
+ & /10x,5i4,1p,2e13.5)
+ enddo
+c
+ suma=0.
+ do ict=1,np
+ suma=suma+at(ict)*xt(ict)
+ enddo
+ vrbint=suma/wghts
+ return
+ endif
+c
+ end subroutine intrph
+
+ end module mod_floats
+c
+c
+ SUBROUTINE F_INVMTX (A,NA,V,NV,N,D,IP,IER)
+c
+c --- this matrix inversion code is used in the parameter matrix
+c --- objective analysis algorithm of mariano and brown (1994), specifically
+c --- in the code used to calculate the large scale 2-d trend surface
+c
+ INTEGER NA,NV,N,IP(2*N),IER
+ DIMENSION A(NA,N),V(NV,N)
+ DATA IEXMAX/75/
+ 115 FORMAT(28H0*MATRIX SINGULAR IN INVMTX*)
+ 116 FORMAT(34H0*DETERMINANT TOO LARGE IN INVMTX*)
+ IER = IERINV_F(N,NA,NV)
+ IF (IER .NE. 0) RETURN
+ DO 102 J=1,N
+ IP(J) = 0
+ DO 101 I=1,N
+ V(I,J) = A(I,J)
+ 101 CONTINUE
+ 102 CONTINUE
+ D = 1.
+ IEX = 0
+ DO 110 M=1,N
+ VMAX = 0.
+ DO 104 J=1,N
+ IF (IP(J) .NE. 0) GO TO 104
+ DO 103 I=1,N
+ IF (IP(I) .NE. 0) GO TO 103
+ VH =ABS(V(I,J))
+ IF (VMAX .GT. VH) GO TO 103
+ VMAX = VH
+ K = I
+ L = J
+ 103 CONTINUE
+ 104 CONTINUE
+ IP(L) = K
+ NPM = N+M
+ IP(NPM) = L
+ D = D*V(K,L)
+ 105 IF (ABS(D) .LE. 1.0) GO TO 106
+ D = D*0.1
+ IEX = IEX+1
+ GO TO 105
+ 106 CONTINUE
+ PVT = V(K,L)
+ IF (M .EQ. 1) PVTMX = ABS(PVT)
+ IF (ABS(PVT/FLOAT(M))+PVTMX .EQ. PVTMX) GO TO 113
+ V(K,L) = 1.
+ DO 107 J=1,N
+ HOLD = V(K,J)
+ V(K,J) = V(L,J)
+ V(L,J) = HOLD/PVT
+ 107 CONTINUE
+ DO 109 I=1,N
+ IF (I .EQ. L) GO TO 109
+ HOLD = V(I,L)
+ V(I,L) = 0.
+ DO 108 J=1,N
+ V(I,J) = V(I,J)-V(L,J)*HOLD
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 CONTINUE
+ M = N+N+1
+ DO 112 J=1,N
+ M = M-1
+ L = IP(M)
+ K = IP(L)
+ IF (K .EQ. L) GO TO 112
+ D = -D
+ DO 111 I=1,N
+ HOLD = V(I,L)
+ V(I,L) = V(I,K)
+ V(I,K) = HOLD
+ 111 CONTINUE
+ 112 CONTINUE
+ IF (IEX .GT. IEXMAX) GO TO 114
+ D = D*10.**IEX
+ RETURN
+ 113 IER = 33
+c PRINT 115
+ RETURN
+ 114 IER = 1
+ D = FLOAT(IEX)
+ PRINT 116
+ RETURN
+ END SUBROUTINE F_INVMTX
+c
+ INTEGER FUNCTION IERINV_F (N,NA,NV)
+ 103 FORMAT(23H0* N .LT. 1 IN INVMTX *)
+ 104 FORMAT(24H0* NA .LT. N IN INVMTX *)
+ 105 FORMAT(24H0* NV .LT. N IN INVMTX *)
+ IERINV_F = 0
+ IF (N .GE. 1) GO TO 101
+ IERINV_F = 34
+ PRINT 103
+ RETURN
+ 101 IF (NA .GE. N) GO TO 102
+ IERINV_F = 35
+ PRINT 104
+ RETURN
+ 102 IF (NV .GE. N) RETURN
+ IERINV_F = 36
+ PRINT 105
+ RETURN
+ END FUNCTION IERINV_F
+
+ subroutine f_stat(ser,ls,amean,var,std)
+c
+c --- computes mean, variance, standard deviation of data sequence
+ dimension ser(*)
+ sum=0.0
+ do j=1,ls
+ sum=sum+ser(j)
+ enddo
+ amean=sum/ls
+ sum=0.0
+ do j=1,ls
+ value=ser(j)-amean
+ sum=sum+value*value
+ enddo
+ var=sum/ls
+ std=sqrt(var)
+c
+ return
+ end subroutine f_stat
+c
+c
+c --- following are subprograms provided by Geoff Samuels, and inserted
+c --- by Nasseer Idrisi (10/5/01)
+
+ subroutine rantab_ini(rtab,iseed1,iseed2,iflag)
+c
+ real*4 rtab(200,2)
+ integer*4 iseed1,iseed2
+ integer*4 iflag
+c
+c --- get the two seeds
+c --- iseed1 is for the 'usual' random number generator (udev_rt)
+c --- iseed2 is for the 'gaussian' random number generator (grand_rt)
+c
+ integer*4 seed
+ integer*4 isd2(2)
+ equivalence (isd2,seed)
+c
+ call system_clock(inisee)
+cdiag write(*,*)'calc itime',time()
+ itime = inisee
+ seed = 123456789
+ iseed1 = isd2(1)
+ if (iseed1 .lt. 0) then
+ iseed1 = iabs (iseed1)
+ endif
+ iseed1 = iseed1 + itime*iflag
+cdiag write(*,*)'iseed1',iseed1
+ seed = 987654321
+ iseed2 = isd2(2)
+ if (iseed2 .lt. 0) then
+ iseed2 = iabs (iseed1)
+ endif
+ iseed2 = iseed2 + itime*iflag
+cdiag write(*,*)'iseed2',iseed2
+c
+c --- set seeds to negative values if iflag=1
+c
+ if (iflag .eq. 1) then
+ iseed1 = -iseed1
+ iseed2 = -iseed2
+ endif
+c
+c --- load the table with a sequence of 200 random numbers.
+ do ic = 1,200
+ rtab(ic,1) = udev_rt(iseed1)
+ rtab(ic,2) = grand_rt(iseed2)
+ enddo
+cdiag write(*,*)'rtabs',rtab(100,1),rtab(100,2)
+c
+ return
+ end subroutine rantab_ini
+
+ subroutine rantab (rtab,iseed1,iseed2,numran)
+c
+c --- each time this routine is called one of the 200 records in "rtab"
+c --- is randomly selected and new random numbers are inserted
+c
+ real*4 rtab(200,2)
+c
+c --- pick a number between 1 and 200
+ numran = nint(1+199*udev_rt(iseed1))
+ if (numran .gt. 200) then
+ numran = 200
+ endif
+c
+c --- get new random numbers
+ rtab(numran,1) = udev_rt(iseed1)
+ rtab(numran,2) = grand_rt(iseed2)
+c
+ return
+ end subroutine rantab
+c
+ real function grand_rt(idum)
+c
+c provides random number from gaussian distribution, mean 0, varaince 1,
+c for finding random component of turbulent u
+c
+c from arthur mariano using routines from numerical recipes
+c
+ data iset/0/
+ save iset,gset
+c
+ if (iset.eq.0) then
+ 1 v1=2.*udev_rt(idum)-1.0
+ v2=2.*udev_rt(idum)-1.0
+ r=v1**2+v2**2
+ if (r.ge.1.0)go to 1
+ fac=sqrt(-2.*log(r)/r)
+ gset=v1*fac
+ grand_rt=v2*fac
+ iset=1
+ else
+ grand_rt=gset
+ iset=0
+ endif
+c
+ return
+ end function grand_rt
+c
+ real function udev_rt(iseed)
+
+ parameter (m=714025,ia=1366,ic=150889,rm=1./m)
+
+ dimension ir(97)
+
+ data iff / 0 /
+c
+ if (iseed .lt. 0 .or. iff .eq. 0) then
+ iff = 1
+ iseed = mod(ic-iseed,m)
+ do j=1,97
+ iseed = mod(ia*iseed+ic,m)
+ ir(j) = iseed
+ enddo
+ iseed = mod(ia*iseed+ic,m)
+ else
+ iseed = mod(iseed,m)
+ endif
+ iy=iseed
+ j = min(97,1+(97*iy)/m)
+ iy = ir(j)
+ udev_rt = iy*rm
+ iseed = mod(ia*iseed+ic,m)
+ ir(j) = iseed
+ return
+ end function udev_rt
+c
+c
+c> Revision history:
+c>
+c> Nov 2006 - 1st module version
diff --git a/src_2.2.18_3_one/mod_hycom.F b/src_2.2.18_3_one/mod_hycom.F
new file mode 100755
index 0000000..3127429
--- /dev/null
+++ b/src_2.2.18_3_one/mod_hycom.F
@@ -0,0 +1,3365 @@
+ module mod_hycom
+#if defined(USE_ESMF)
+ use ESMF_Mod ! ESMF Framework
+#endif
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ use mod_pipe ! HYCOM debugging interface
+ use mod_incupd ! HYCOM incremental update (for data assimilation)
+ use mod_floats ! HYCOM synthetic floats, drifters and moorings
+ use mod_tides ! HYCOM tides
+ use mod_mean ! HYCOM mean archives
+#if defined(USE_CCSM3)
+ use ccsm3, only : ccsm3_setup_coupling_env ! ccsm3 ocean
+ use ccsm3_exit ! ccsm3 ocean exit
+ use ccsm3_io ! ccsm3 ocean io
+ use ccsm3_forcing ! ccsm3 ocean/cpl6 comms
+ use ccsm3_time_management ! ccsm3 ocean time
+ use ccsm3_global_reductions ! ccsm3 ocean mpi comms
+ use shr_timer_mod ! ccsm3 shared timing routine
+#endif
+c
+c --- -----------------------------------------
+c --- MICOM-based HYbrid Coordinate Ocean Model
+c --- H Y C O M
+c --- v e r s i o n 2.2
+c --- -----------------------------------------
+c
+ implicit none
+c
+#if ! defined(USE_CCSM3)
+ include 'common_blocks.h'
+#endif
+c
+#if defined(USE_ESMF)
+ public HYCOM_SetServices
+#else
+ public HYCOM_Init, HYCOM_Run, HYCOM_Final
+#endif
+c
+ logical, save, public :: put_export !set in main program
+ logical, save, public :: get_import !set in main program
+ logical, save, public :: end_of_run !set in HYCOM_Run
+ integer, save, public :: nts_day !set in HYCOM_init, timesteps/day
+ integer, save, public :: nts_ice !set in HYCOM_init, timesteps/ice
+c
+ integer, save, private ::
+ & m,n
+#if defined(USE_CCSM3)
+ logical, save, private ::
+ & end_month
+ integer, save, private ::
+ & k1m, !k1n in ccsm3_forcing
+ & mm,nn,
+ & termination, !if 1, stop now!
+ & ix0,ix1,ix2
+ character, save, private ::
+ & ccsm3_string*80
+#endif
+ real*8, save, private ::
+ & d1,d2,d3,d4,d2a,d3a,d4a,
+ & ddsurf,ddiagf,dtilef,drstrf,dmeanf,
+ & dske,dskea,dsmr,dsmra,dsms,dsmsa,dsmt,dsmta,dsum,dsuma,
+ & dsumtr(mxtrcr),
+ & dtime,dtime0,dbimon,dmonth,dyear,dyear0,
+ & dsmall,dsmall2
+ real, save, private ::
+ & smr,sms,smt,sum,smin,smax, tsur,
+ & coord,day1,day2,x,x1,time0,timav,cold,utotp,vtotp
+ real, save, private, allocatable ::
+ & sminy(:),smaxy(:)
+ integer, save, private ::
+ & nstep0,nod,
+ & lt,ma0,ma1,ma2,ma3,mc0,mc1,mc2,mc3,
+ & mk0,mk1,mk2,mk3,mr0,mr1,mr2,mr3,mnth,iofl,
+#if defined(USE_CCSM3)
+ & jday
+#else
+ & jday,ihour,iyear
+#endif
+ logical, save, private ::
+ & linit,diagsv,hisurf,histry,hitile,histmn,
+ & restrt,diag_tide
+ character, save, private ::
+ & intvl*3,c_ydh*14
+c
+ real*8 hours1,days1,days6
+ private hours1,days1,days6
+ parameter (hours1=1.d0/24.d0,days1=1.d0,days6=6.d0)
+c
+c --- tfrz_n = nominal ice melting point (degC) for ice mask
+ real tfrz_n
+ private tfrz_n
+ parameter (tfrz_n=-1.79) !slightly above -1.8
+
+c
+#if defined(USE_ESMF)
+c
+c --- Data types for Import/Export array pointers
+ type ArrayPtrReal2D
+ real(ESMF_KIND_R4), dimension(:,:), pointer :: p
+ end type ArrayPtrReal2D
+c
+c --- Attribute names for fields
+ character(ESMF_MAXSTR), save ::
+ & attNameLongName = "long_name",
+ & attNameStdName = "standard_name",
+ & attNameUnits = "units",
+ & attNameSclFac = "scale_factor",
+ & attNameAddOff = "add_offset"
+c
+c --- Import Fields
+ integer, parameter :: numImpFields=11
+ character(ESMF_MAXSTR), save :: impFieldName( numImpFields),
+ & impFieldLongName(numImpFields),
+ & impFieldStdName( numImpFields),
+ & impFieldUnits( numImpFields)
+ real(ESMF_KIND_R4), save :: impFieldSclFac( numImpFields),
+ & impFieldAddOff( numImpFields)
+c
+c --- Export Fields
+ integer, parameter :: numExpFields=7
+ character(ESMF_MAXSTR), save :: expFieldName( numExpFields),
+ & expFieldLongName(numExpFields),
+ & expFieldStdName( numExpFields),
+ & expFieldUnits( numExpFields)
+ real(ESMF_KIND_R4), save :: expFieldSclFac( numExpFields),
+ & expFieldAddOff( numExpFields)
+c
+c --- ESMF related variables
+ type(ESMF_Bundle), save :: expBundle,
+ & impBundle
+ type(ESMF_Field), save :: expField(numExpFields),
+ & impField(numImpFields)
+ type(ArrayPtrReal2D), save :: expData( numExpFields),
+ & impData( numImpFields)
+c
+ type(ESMF_Clock), save :: intClock
+ type(ESMF_VM), save :: vm
+ type(ESMF_DELayout), save :: deLayout
+ integer, save :: petCount, localPet, mpiCommunicator
+ type(ESMF_Grid), save :: grid2D
+ type(ESMF_ArraySpec), save :: arraySpec2Dr
+
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & sic_import !Sea Ice Concentration
+ &, sitx_import !Sea Ice X-Stress
+ &, sity_import !Sea Ice Y-Stress
+ &, siqs_import !Solar Heat Flux thru Ice to Ocean
+ &, sifh_import !Ice Freezing/Melting Heat Flux
+ &, sifs_import !Ice Freezing/Melting Salt Flux
+ &, sifw_import !Ice Net Water Flux
+ &, sit_import !Sea Ice Temperature
+ &, sih_import !Sea Ice Thickness
+ &, siu_import !Sea Ice X-Velocity
+ &, siv_import !Sea Ice Y-Velocity
+ &, ocn_mask !Ocean Currents Mask
+
+ logical, save ::
+ & ocn_mask_init
+
+#endif
+
+ contains
+
+#if defined(USE_ESMF)
+ subroutine HYCOM_SetServices(gridComp, rc)
+c
+ type(ESMF_GridComp) :: gridComp
+ integer :: rc
+c
+ call ESMF_GridCompSetEntryPoint(
+ & gridComp,
+ & ESMF_SETINIT,
+ & HYCOM_Init,
+ & ESMF_SINGLEPHASE,
+ & rc)
+ call ESMF_GridCompSetEntryPoint(
+ & gridComp,
+ & ESMF_SETRUN,
+ & HYCOM_Run,
+ & ESMF_SINGLEPHASE,
+ & rc)
+ call ESMF_GridCompSetEntryPoint(
+ & gridComp,
+ & ESMF_SETFINAL,
+ & HYCOM_Final,
+ & ESMF_SINGLEPHASE,
+ & rc)
+c
+ end subroutine HYCOM_SetServices
+
+ subroutine Setup_ESMF(gridComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_GridComp) :: gridComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- set up ESMF data structures for HYCOM.
+c
+ integer :: i,j
+ real(ESMF_KIND_R8) :: coord1(itdm),coord2(jtdm) !cell centers
+ real :: plonrl(itdm),platrl(jtdm)
+ integer :: cnts(2)
+ real(ESMF_KIND_R8) :: mgcpd(2), dpd(2)
+ character(10) :: dimNames(2),dimUnits(2)
+ type(ESMF_Logical) :: periodic(2)
+ integer(ESMF_KIND_I4) :: year,month,day,hour,minute
+ integer(ESMF_KIND_I4) :: sec,msec,usec,nsec
+ real(8) :: dsec,dmsec,dusec,dnsec
+ type(ESMF_TimeInterval) :: timeStep, runDuration
+ type(ESMF_Time) :: startTime
+ character(ESMF_MAXSTR) :: msg, gridName
+c
+c --- Report
+ call ESMF_LogWrite("HYCOM Setup routine called",
+ & ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c Attributes for import fields, identical to CICE export fields
+ impFieldAddOff(:) = 0.0 !default is no offset
+ impFieldSclFac(:) = 1.0 !default is no scale factor
+
+ impFieldName( 1) = "sic"
+ impFieldLongName( 1) = "Sea Ice Concentration"
+ impFieldStdName( 1) = "sea_ice_area_fraction"
+ impFieldUnits( 1) = "1"
+ impFieldName( 2) = "sitx"
+ impFieldLongName( 2) = "Sea Ice X-Stress"
+ impFieldStdName( 2) = "downward_x_stress_at_sea_ice_base"
+ impFieldSclFac( 2) = -1.0 !field is upward
+ impFieldUnits( 2) = "Pa"
+ impFieldName( 3) = "sity"
+ impFieldLongName( 3) = "Sea Ice Y-Stress"
+ impFieldStdName( 3) = "downward_y_stress_at_sea_ice_base"
+ impFieldSclFac( 3) = -1.0 !field is upward
+ impFieldUnits( 3) = "Pa"
+ impFieldName( 4) = "siqs"
+ impFieldLongName( 4) = "Solar Heat Flux thru Ice to Ocean"
+ impFieldStdName( 4) = "downward_sea_ice_basal_solar_heat_flux"
+ impFieldUnits( 4) = "W m-2"
+ impFieldName( 5) = "sifh"
+ impFieldLongName( 5) = "Ice Freezing/Melting Heat Flux"
+ impFieldStdName( 5) = "upward_sea_ice_basal_heat_flux"
+ impFieldSclFac( 5) = -1.0 !field is downward
+ impFieldUnits( 5) = "W m-2"
+ impFieldName( 6) = "sifs"
+ impFieldLongName( 6) = "Ice Freezing/Melting Salt Flux"
+ impFieldStdName( 6) = "downward_sea_ice_basal_salt_flux"
+ impFieldUnits( 6) = "kg m-2 s-1"
+ impFieldName( 7) = "sifw"
+ impFieldLongName( 7) = "Ice Net Water Flux"
+ impFieldStdName( 7) = "downward_sea_ice_basal_water_flux"
+ impFieldUnits( 7) = "kg m-2 s-1"
+ impFieldName( 8) = "sit" !diagnostic
+ impFieldLongName( 8) = "Sea Ice Temperature"
+ impFieldStdName( 8) = "sea_ice_temperature"
+ impFieldAddOff( 8) = +273.15 !field is in degC
+ impFieldUnits( 8) = "K"
+ impFieldName( 9) = "sih" !diagnostic
+ impFieldLongName( 9) = "Sea Ice Thickness"
+ impFieldStdName( 9) = "sea_ice_thickness"
+ impFieldUnits( 9) = "m"
+ impFieldName( 10) = "siu" !diagnostic
+ impFieldLongName(10) = "Sea Ice X-Velocity"
+ impFieldStdName( 10) = "sea_ice_x_velocity"
+ impFieldUnits( 10) = "m s-1"
+ impFieldName( 11) = "siv" !diagnostic
+ impFieldLongName(11) = "Sea Ice Y-Velocity"
+ impFieldStdName( 11) = "sea_ice_y_velocity"
+ impFieldUnits( 11) = "m s-1"
+*
+* impFieldName( 12) = "patm"
+* impFieldLongName(12) = "Surface Air Pressure"
+* impFieldStdName( 12) = "surface_air_pressure"
+* impFieldUnits( 12) = "Pa"
+* impFieldName( 13) = "xwnd"
+* impFieldLongName(13) = "X-Wind"
+* impFieldStdName( 13) = "x_wind"
+* impFieldUnits( 13) = "m s-1"
+* impFieldName( 14) = "ywnd"
+* impFieldLongName(14) = "Y-Wind"
+* impFieldStdName( 14) = "y_wind"
+* impFieldUnits( 14) = "m s-1"
+c
+c Attributes for export fields, identical to CICE import fields
+ expFieldAddOff(:) = 0.0 !default is no offset
+ expFieldSclFac(:) = 1.0 !default is no scale factor
+
+ expFieldName( 1) = "sst"
+ expFieldLongName( 1) = "Sea Surface Temperature"
+ expFieldStdName( 1) = "sea_surface_temperature"
+ expFieldAddOff( 1) = +273.15 !field is in degC
+ expFieldUnits( 1) = "K"
+ expFieldName( 2) = "sss"
+ expFieldLongName( 2) = "Sea Surface Salinity"
+ expFieldStdName( 2) = "sea_surface_salinity"
+ expFieldUnits( 2) = "1e-3"
+ expFieldName( 3) = "ssu"
+ expFieldLongName( 3) = "Sea Surface X-Current"
+ expFieldStdName( 3) = "sea_water_x_velocity"
+ expFieldUnits( 3) = "m s-1"
+ expFieldName( 4) = "ssv"
+ expFieldLongName( 4) = "Sea Surface Y-Current"
+ expFieldStdName( 4) = "sea_water_y_velocity"
+ expFieldUnits( 4) = "m s-1"
+ expFieldName( 5) = "ssh"
+ expFieldLongName( 5) = "Sea Surface Height"
+ expFieldStdName( 5) = "sea_surface_height_above_sea_level"
+ expFieldUnits( 5) = "m"
+ expFieldName( 6) = "ssfi"
+ expFieldLongName( 6) = "Oceanic Heat Flux Available to Sea Ice"
+ expFieldStdName( 6) = "upward_sea_ice_basal_available_heat_flux"
+ expFieldSclFac( 6) = -1.0 !field is downward
+ expFieldUnits( 6) = "W m-2"
+ expFieldName( 7) = "mlt" !diagnostic
+ expFieldLongName( 7) = "Ocean Mixed Layer Thickness"
+ expFieldStdName( 7) = "ocean_mixed_layer_thickness"
+ expFieldUnits( 7) = "m"
+c
+c Create a DE layout to match HYCOM layout
+ deLayout = ESMF_DELayoutCreate(vm,
+ & deCountList=(/ipr, jpr/),
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: DELayoutCreate failed", rc))
+ & call ESMF_Finalize(rc=rc)
+c
+c Create array specifications
+ call ESMF_ArraySpecSet(arraySpec2Dr,
+ & rank=2,
+ & type=ESMF_DATA_REAL,
+ & kind=ESMF_R4,
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: ArraySpecSet failed", rc))
+ & call ESMF_Finalize(rc=rc)
+c
+c Create an ESMF grid that matches the HYCOM 2D grid
+#if defined(ESMF_CURVILINEAR)
+c Use indices as cartesian coordinates
+c
+ cnts( 1)=itdm; cnts( 2)=jtdm;
+ mgcpd( 1)=1.d0; mgcpd( 2)=1.d0;
+ dpd( 1)=1.d0; dpd( 2)=1.d0;
+ dimNames(1)="index_i"; dimNames(2)="index_j";
+ dimUnits(1)="1"; dimUnits(2)="1";
+ periodic(1)=ESMF_FALSE; periodic(2)=ESMF_FALSE;
+ gridName="HYCOM X-Y Cell-Center Grid"
+ grid2D = ESMF_GridCreateHorzXYUni(
+ & counts =cnts,
+ & minGlobalCoordPerDim=mgcpd,
+ & deltaPerDim=dpd,
+ & horzStagger=ESMF_GRID_HORZ_STAGGER_A, !CELL_CENTER only
+ & dimNames =dimNames,
+ & dimUnits =dimUnits,
+ & coordOrder =ESMF_COORD_ORDER_XYZ,
+ & periodic =periodic,
+ & name =trim(gridName),
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: GridCreateHorzXYUni", rc))
+ & call ESMF_Finalize(rc=rc)
+#else
+c Rectilinear, lat-lon, coordinates
+ call xclget(plonrl,itdm, plon,1,1,1,0, 0)
+ call xclget(platrl,jtdm, plat,1,1,0,1, 0)
+ coord1(1:itdm) = plonrl(1:itdm)
+ coord2(1:jtdm) = platrl(1:jtdm)
+ dimNames(1)="longitude"; dimNames(2)="latitude";
+ dimUnits(1)="degrees_east"; dimUnits(2)="degrees_north";
+ if (plonrl(itdm)-plonrl(1) .gt. 350.0) then !probably global
+ periodic(1)=ESMF_TRUE
+ periodic(2)=ESMF_FALSE
+ else
+ periodic(1)=ESMF_FALSE
+ periodic(2)=ESMF_FALSE
+ endif
+ gridName="HYCOM Lat-Lon Cell-Center Grid"
+ grid2D = ESMF_GridCreateHorzLatLon(
+ & coord1 =coord1(1:itdm),
+ & coord2 =coord2(1:jtdm),
+ & horzStagger=ESMF_GRID_HORZ_STAGGER_A, !CELL_CENTER only
+ & dimNames =dimNames,
+ & dimUnits =dimUnits,
+ & coordOrder =ESMF_COORD_ORDER_XYZ,
+ & periodic =periodic,
+ & name =trim(gridName),
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: GridCreateHorzLatLon", rc))
+ & call ESMF_Finalize(rc=rc)
+#endif
+c
+c Distribute the grid on the DE layout using HYCOM distribution
+c Only Separable 2-D block distributions with no land skipping are allowed
+ call ESMF_GridDistribute(grid2D,
+ & deLayout =deLayout,
+ & countsPerDEDim1=countde1(1:ipr),
+ & countsPerDEDim2=countde2(1:jpr),
+ & rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: GridDistribute", rc))
+ & call ESMF_Finalize(rc=rc)
+c
+c Associate grid with ESMF gridded component
+ call ESMF_GridCompSet(gridComp, grid=grid2D, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "Setup_ESMF: GridCompSet", rc))
+ & call ESMF_Finalize(rc=rc)
+c Setup export fields, bundles & state
+ do i = 1,numExpFields
+ expField(i) = ESMF_FieldCreate(grid2D, arraySpec2Dr,
+ & allocFlag =ESMF_ALLOC,
+ & horzRelloc=ESMF_CELL_CENTER,
+ & haloWidth =0,
+ & name =trim(expFieldName(i)),
+ & rc=rc)
+ call ESMF_FieldSetAttribute(expField(i),
+ & trim(attNameLongName), trim(expFieldLongName(i)), rc=rc)
+ call ESMF_FieldSetAttribute(expField(i),
+ & trim(attNameStdName), trim(expFieldStdName(i)), rc=rc)
+ call ESMF_FieldSetAttribute(expField(i),
+ & trim(attNameUnits), trim(expFieldUnits(i)), rc=rc)
+ call ESMF_FieldSetAttribute(expField(i),
+ & trim(attNameAddOff), expFieldAddOff(i), rc=rc)
+ call ESMF_FieldSetAttribute(expField(i),
+ & trim(attNameSclFac), expFieldSclFac(i), rc=rc)
+ call ESMF_FieldGetDataPointer(expField(i),
+ & expData(i)%p, copyFlag=ESMF_DATA_REF, rc=rc)
+ expData(i)%p(:,:) = 0.0
+ enddo
+c
+c Create bundle from list of fields
+ expBundle = ESMF_BundleCreate(numExpFields,
+ & expField(:), name="HYCOM",
+ & rc=rc)
+c
+c Add bundle to the export state
+ call ESMF_StateAddBundle(expState, expBundle, rc=rc)
+c
+c Setup import fields, bundles & state
+ do i = 1,numImpFields
+ impField(i) = ESMF_FieldCreate(grid2D, arraySpec2Dr,
+ & allocFlag =ESMF_ALLOC,
+ & horzRelloc=ESMF_CELL_CENTER,
+ & haloWidth =0,
+ & name =trim(impFieldName(i)),
+ & rc=rc)
+ call ESMF_FieldSetAttribute(impField(i),
+ & trim(attNameLongName), trim(impFieldLongName(i)), rc=rc)
+ call ESMF_FieldSetAttribute(impField(i),
+ & trim(attNameStdName), trim(impFieldStdName(i)), rc=rc)
+ call ESMF_FieldSetAttribute(impField(i),
+ & trim(attNameUnits), trim(impFieldUnits(i)), rc=rc)
+ call ESMF_FieldSetAttribute(impField(i),
+ & trim(attNameAddOff), impFieldAddOff(i), rc=rc)
+ call ESMF_FieldSetAttribute(impField(i),
+ & trim(attNameSclFac), impFieldSclFac(i), rc=rc)
+ call ESMF_FieldGetDataPointer(impField(i),
+ & impData(i)%p, copyFlag=ESMF_DATA_REF, rc=rc)
+ impData(i)%p(:,:) = 0.0
+ enddo
+ sic_import(:,:) = 0.0 !Sea Ice Concentration
+ sitx_import(:,:) = 0.0 !Sea Ice X-Stress
+ sity_import(:,:) = 0.0 !Sea Ice Y-Stress
+ siqs_import(:,:) = 0.0 !Solar Heat Flux thru Ice to Ocean
+ sifh_import(:,:) = 0.0 !Ice Freezing/Melting Heat Flux
+ sifs_import(:,:) = 0.0 !Ice Freezing/Melting Salt Flux
+ sifw_import(:,:) = 0.0 !Ice Net Water Flux
+ sit_import(:,:) = 0.0 !Sea Ice Temperature
+ sih_import(:,:) = 0.0 !Sea Ice Thickness
+ siu_import(:,:) = 0.0 !Sea Ice X-Velocity
+ siv_import(:,:) = 0.0 !Sea Ice Y-Velocity
+c
+c Create bundle from list of fields
+ impBundle = ESMF_BundleCreate(numImpFields,
+ & impField(:), name="HYCOM",
+ & rc=rc)
+c
+c Add bundle to the import state
+ call ESMF_StateAddBundle(impState, impBundle, rc=rc)
+c
+ ocn_mask_init = .true. !still need to initialize ocn_mask
+c
+ end subroutine Setup_ESMF
+
+ subroutine Export_ESMF
+c
+c --- Fill export state.
+c --- Calculate ssfi "in place"
+c
+ integer i,j,k
+ real ssh2m
+ real tmxl,smxl,umxl,vmxl,hfrz,tfrz,t2f,ssfi
+ real dp1,usur1,vsur1,psur1,dp2,usur2,vsur2,psur2
+c
+c --- Report
+ call ESMF_LogWrite("HYCOM Export routine called",
+ & ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+ margin = 0
+c
+ if (ocn_mask_init) then !very 1st call to this routine
+ ocn_mask_init = .false.
+c
+ if (iceflg.eq.4) then
+ ocn_mask(:,:) = 0.0 !export ocean currents nowhere
+ elseif (nestfq.ne.0.0) then
+c export ocean currents away from open boundaries
+ do j= 1,jj
+ do i= 1,ii
+ if (rmunv(i,j).ne.0.0) then
+ ocn_mask(i,j) = 0.0
+ else
+ ocn_mask(i,j) = 1.0
+ endif
+ enddo !i
+ enddo !j
+ do i= 1,10
+ call psmooth(ocn_mask,0) !not efficient, but only done once
+ enddo !i
+ else
+ ocn_mask(:,:) = 1.0 !export ocean currents everywhere
+ endif
+ endif !ocn_mask_init
+c
+c --- Assume Export State is as defined in Setup_ESMF
+c --- Average two time levels since (the coupling frequency) icefrq >> 2
+c
+ ssh2m = 1.0/g
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+c --- quantities for available freeze/melt heat flux
+c --- relax to tfrz with e-folding time of icefrq time steps
+c --- assuming the effective surface layer thickness is hfrz
+c --- multiply by dpbl(i,j)/hfrz to get the actual e-folding time
+ hfrz = min( thkfrz*onem, dpbl(i,j) )
+ t2f = (spcifh*hfrz)/(baclin*icefrq*g)
+ smxl = 0.5*(saln(i,j,1,n)+saln(i,j,1,m))
+ tmxl = 0.5*(temp(i,j,1,n)+temp(i,j,1,m))
+ tfrz = tfrz_0 + smxl*tfrz_s !salinity dependent freezing point
+ ssfi = (tfrz-tmxl)*t2f !W/m^2 into ocean
+c --- average currents over top 10m
+ usur1 = 0.0
+ vsur1 = 0.0
+ psur1 = 0.0
+ usur2 = 0.0
+ vsur2 = 0.0
+ psur2 = 0.0
+ do k= 1,kk
+ dp1 = min( dp(i,j,k,1), max( 0.0, tenm - psur1 ) )
+ usur1 = usur1 + dp1*(u(i,j,k,1)+u(i+1,j,k,1))
+ vsur1 = vsur1 + dp1*(v(i,j,k,1)+v(i,j+1,k,1))
+ psur1 = psur1 + dp1
+ dp2 = min( dp(i,j,k,2), max( 0.0, tenm - psur2 ) )
+ usur2 = usur2 + dp2*(u(i,j,k,2)+u(i+1,j,k,2))
+ vsur2 = vsur2 + dp2*(v(i,j,k,2)+v(i,j+1,k,2))
+ psur2 = psur2 + dp2
+ if (max(dp1,dp2).eq.0.0) then
+ exit
+ endif
+ enddo
+ umxl = 0.25*( usur1/psur1 + ubavg(i, j,1) +
+ + ubavg(i+1,j,1) +
+ & usur2/psur2 + ubavg(i, j,2) +
+ & ubavg(i+1,j,2) )
+ vmxl = 0.25*( vsur1/psur1 + vbavg(i,j, 1) +
+ & vbavg(i,j+1,1) +
+ & vsur2/psur2 + vbavg(i,j, 2) +
+ & vbavg(i,j+1,2) )
+ expData(1)%p(i,j) = tmxl
+ expData(2)%p(i,j) = smxl
+ expData(3)%p(i,j) = umxl*ocn_mask(i,j)
+ expData(4)%p(i,j) = vmxl*ocn_mask(i,j)
+ expData(5)%p(i,j) = ssh2m*srfhgt(i,j) !ssh in m
+ expData(6)%p(i,j) = max(-1000.0,min(1000.0,ssfi)) !as in CICE
+ expData(7)%p(i,j) = dpbl(i,j)*qonem
+ endif !ip
+ enddo !i
+ enddo !j
+c
+ end subroutine Export_ESMF
+
+ subroutine Import_ESMF
+c
+c --- Extract import state.
+c
+ integer i,j
+c
+c --- Report
+ call ESMF_LogWrite("HYCOM Import routine called",
+ & ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c --- Assume Import State is as defined in Setup_ESMF
+c
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+ sic_import(i,j) = impData( 1)%p(i,j) !Sea Ice Concentration
+ sitx_import(i,j) = impData( 2)%p(i,j) !Sea Ice X-Stress
+ sity_import(i,j) = impData( 3)%p(i,j) !Sea Ice Y-Stress
+ siqs_import(i,j) = impData( 4)%p(i,j) !Solar Heat Flux thru Ice to Ocean
+ sifh_import(i,j) = impData( 5)%p(i,j) !Ice Freezing/Melting Heat Flux
+ sifs_import(i,j) = impData( 6)%p(i,j) !Ice Freezing/Melting Salt Flux
+ sifw_import(i,j) = impData( 7)%p(i,j) !Ice Net Water Flux
+ sit_import(i,j) = impData( 8)%p(i,j) !Sea Ice Temperature
+ sih_import(i,j) = impData( 9)%p(i,j) !Sea Ice Thickness
+ siu_import(i,j) = impData(10)%p(i,j) !Sea Ice X-Velocity
+ siv_import(i,j) = impData(11)%p(i,j) !Sea Ice Y-Velocity
+ if (iceflg.ge.2 .and. icmflg.ne.3) then
+ covice(i,j) = impData(1)%p(i,j) !Sea Ice Concentration
+ si_c(i,j) = impData(1)%p(i,j) !Sea Ice Concentration
+ if (covice(i,j).gt.0.0) then
+ si_tx(i,j) = -impData( 2)%p(i,j) !Sea Ice X-Stress into ocean
+ si_ty(i,j) = -impData( 3)%p(i,j) !Sea Ice Y-Stress into ocean
+ fswice(i,j) = impData( 4)%p(i,j) !Solar Heat Flux thru Ice to Ocean
+ flxice(i,j) = fswice(i,j) +
+ & impData( 5)%p(i,j) !Ice Freezing/Melting Heat Flux
+ sflice(i,j) = impData( 6)%p(i,j)*1.e3 -
+ & impData( 7)%p(i,j)*saln(i,j,1,n)
+ !Ice Virtual Salt Flux
+ temice(i,j) = impData( 8)%p(i,j) !Sea Ice Temperature
+ thkice(i,j) = impData( 9)%p(i,j) !Sea Ice Thickness
+ si_u(i,j) = impData(10)%p(i,j) !Sea Ice X-Velocity
+ si_v(i,j) = impData(11)%p(i,j) !Sea Ice Y-Velocity
+ else
+ si_tx(i,j) = 0.0
+ si_ty(i,j) = 0.0
+ fswice(i,j) = 0.0
+ flxice(i,j) = 0.0
+ sflice(i,j) = 0.0
+ temice(i,j) = 0.0
+ thkice(i,j) = 0.0
+ si_u(i,j) = 0.0
+ si_v(i,j) = 0.0
+ endif !covice
+ elseif (iceflg.ge.2 .and. icmflg.eq.3) then
+ si_c(i,j) = impData( 1)%p(i,j) !Sea Ice Concentration
+ if (si_c(i,j).gt.0.0) then
+ si_tx(i,j) = -impData( 2)%p(i,j) !Sea Ice X-Stress into ocean
+ si_ty(i,j) = -impData( 3)%p(i,j) !Sea Ice Y-Stress into ocean
+ si_h(i,j) = impData( 9)%p(i,j) !Sea Ice Thickness
+ si_t(i,j) = impData( 8)%p(i,j) !Sea Ice Temperature
+ si_u(i,j) = impData(10)%p(i,j) !Sea Ice X-Velocity
+ si_v(i,j) = impData(11)%p(i,j) !Sea Ice Y-Velocity
+ else
+ si_tx(i,j) = 0.0
+ si_ty(i,j) = 0.0
+ si_h(i,j) = 0.0
+ si_t(i,j) = 0.0
+ si_u(i,j) = 0.0
+ si_v(i,j) = 0.0
+ endif !covice
+ endif !iceflg>=2 (icmflg)
+ endif !ip
+ enddo !i
+ enddo !j
+c
+ end subroutine Import_ESMF
+
+ subroutine Archive_ESMF(iyear,jday,ihour)
+ integer iyear,jday,ihour
+c
+c --- Create a HYCOM "archive-like" file from Import/Export state..
+c --- Import state may not be at the same time as Export.
+c
+ character*8 cname
+ character*80 cfile
+ integer i,j,k,nop,nopa
+ real coord,xmin,xmax
+c
+ write(cfile,'(a,i4.4,a1,i3.3,a1,i2.2)')
+ & 'arche.',iyear,'_',jday,'_',ihour
+ nopa=13
+ nop =13+uoff
+c
+ call zaiopf(trim(cfile)//'.a', 'new', nopa)
+ if (mnproc.eq.1) then
+ open (unit=nop,file=trim(cfile)//'.b',status='new') !uoff+13
+ write(nop,116) ctitle,iversn,iexpt,yrflag,itdm,jtdm
+ call flush(nop)
+ endif !1st tile
+ 116 format (a80/a80/a80/a80/
+ & i5,4x,'''iversn'' = hycom version number x10'/
+ & i5,4x,'''iexpt '' = experiment number x10'/
+ & i5,4x,'''yrflag'' = days in year flag'/
+ & i5,4x,'''idm '' = longitudinal array size'/
+ & i5,4x,'''jdm '' = latitudinal array size'/
+ & 'field time step model day',
+ & ' k dens min max')
+c
+c --- surface fields
+c
+ coord=0.0
+ do k= 1,numExpFields
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+ util1(i,j) = expData(k)%p(i,j)
+ endif !ip
+ enddo !i
+ enddo !j
+ cname = expFieldName(k)(1:8)
+ call zaiowr(util1,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !k
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+ util2(i,j) = impData(1)%p(i,j) !ice concentration
+ else
+ util2(i,j) = 0.0
+ endif !ip
+ enddo !i
+ enddo !j
+ cname = impFieldName(1)(1:8)
+ call zaiowr(util2,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ do k= 2,3 !si_tx,si_ty
+ do j= 1,jj
+ do i= 1,ii
+ if (util2(i,j).ne.0.0) then
+ util1(i,j) = -impData(k)%p(i,j) !into ocean
+ else
+ util1(i,j) = 0.0
+ endif !ice:no-ice
+ enddo !i
+ enddo !j
+ cname = impFieldName(k)(1:8)
+ call zaiowr(util1,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname(1:4)//'down',
+ & nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !k
+ do k= 4,7 !fluxes
+ do j= 1,jj
+ do i= 1,ii
+ if (util2(i,j).ne.0.0) then
+ util1(i,j) = util2(i,j)*impData(k)%p(i,j)
+ else
+ util1(i,j) = huge !mask where there is no ice
+ endif !ice:no-ice
+ enddo !i
+ enddo !j
+ cname = impFieldName(k)(1:8)
+ call zaiowr(util1,ip,.false., !mask on ice
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !k
+ do k= 8,numImpFields
+ do j= 1,jj
+ do i= 1,ii
+ if (util2(i,j).ne.0.0) then
+ util1(i,j) = impData(k)%p(i,j)
+ else
+ util1(i,j) = huge !mask where there is no ice
+ endif !ice:no-ice
+ enddo !i
+ enddo !j
+ cname = impFieldName(k)(1:8)
+ call zaiowr(util1,ip,.false., !mask on ice
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !k
+ do j= 1,jj
+ do i= 1,ii
+ if (util2(i,j).ne.0.0) then
+ util1(i,j) = impData( 6)%p(i,j)*1.e3 -
+ & impData( 7)%p(i,j)*saln(i,j,1,n) !virtual salt flux
+ else
+ util1(i,j) = huge !mask where there is no ice
+ endif !ice:no-ice
+ enddo !i
+ enddo !j
+ cname = 'surtx '
+ call zaiowr(surtx,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ cname = 'surty '
+ call zaiowr(surty,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ cname = 'sflice '
+ call zaiowr(util1,ip,.false., !mask on ice
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) cname,nstep,time,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ 117 format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
+c
+ close (unit=nop)
+ call zaiocl(nopa)
+c
+ end subroutine Archive_ESMF
+#endif /* USE_ESMF */
+
+ subroutine HYCOM_Init
+#if defined(USE_ESMF)
+ & (gridComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_GridComp) :: gridComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+#endif
+c
+c --- Initialize (before the 1st time step).
+c
+ integer i,j,k,l,nm
+ character*80 flnm,flnmra,flnmrb
+c
+ include 'stmt_fns.h'
+c
+#if defined(USE_ESMF)
+ character(ESMF_MAXSTR) :: msg
+c
+c --- Report
+ call ESMF_LogWrite("HYCOM initialize routine called",
+ & ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c --- Get VM from gridComp
+ call ESMF_GridCompGet(gridComp, vm=vm, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "HYCOM_Init: GridCompGet failed", rc))
+ & call ESMF_Finalize(rc=rc)
+c
+c --- Get VM info
+ call ESMF_VMGet(vm,
+ & petCount=petCount, localPET=localPet,
+ & mpiCommunicator=mpiCommunicator, rc=rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "HYCOM_Init: VMGet failed", rc))
+ & call ESMF_Finalize(rc=rc)
+ write(msg,'(a,i4)') "HYCOM_Init: petCount = ",petCount
+ call ESMF_LogWrite(msg, ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c --- initialize hycom message passing.
+ call xcspmd(mpiCommunicator)
+#elif defined(USE_CCSM3)
+!--------------------------------------------------------
+! intialize memory-statistics code
+!--------------------------------------------------------
+! call start()
+!--------------------------------------------------------
+! intialize message-passing with ccsm3 coupler cpl6
+!--------------------------------------------------------
+ call ccsm3_setup_coupling_env()
+!--------------------------------------------------------
+! intialize i/o for ccsm3 coupled system
+!--------------------------------------------------------
+ call ccsm3_io_init
+c
+c --- initialize SPMD processsing
+ call xcspmd
+#else
+c
+c --- initialize SPMD processsing
+ call xcspmd
+#endif /* USE_ESMF:USE_CCSM3:else */
+c
+c --- initialize timer names.
+c
+ call xctmrn(40,'cnuity')
+ call xctmrn(41,'tsadvc')
+ call xctmrn(42,'momtum')
+ call xctmrn(43,'barotp')
+ call xctmrn(44,'thermf')
+ call xctmrn(45,'ic****')
+ call xctmrn(46,'mx****')
+ call xctmrn(47,'conv**')
+ call xctmrn(48,'diapf*')
+ call xctmrn(49,'hybgen')
+ call xctmrn(50,'trcupd')
+ call xctmrn(51,'restrt')
+ call xctmrn(52,'overtn')
+ call xctmrn(53,'archiv')
+ call xctmrn(54,'incupd')
+c
+c --- machine-specific initialization
+ call machine
+c
+c --- initialize array i/o.
+ call zaiost
+c
+c --- initiate named-pipe comparison utility
+ call pipe_init
+c
+c --- initialize common variables
+c
+ call blkdat
+c
+ nts_ice = icefrq !no. time steps between ice coupling
+ nts_day = nint(86400.0d0/baclin) !no. time steps per day
+ dsmall = baclin/86400.0d0 * 0.25d0 !1/4 of a time step in days
+ dsmall2 = dsmall*2.0d0
+ if (dsurfq.ge.1.0) then
+ ddsurf = dsurfq
+ elseif (dsurfq.ne.0.0) then
+ ddsurf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*dsurfq)/baclin))
+ else !no surface archives
+ ddsurf = 999999.0d0*(baclin/86400.0d0)
+ endif
+ if (diagfq.ge.1.0) then
+ ddiagf = diagfq
+ elseif (diagfq.ne.0.0) then
+ ddiagf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*diagfq)/baclin))
+ else !no 3-d archives
+ ddiagf = huge*(baclin/86400.0d0)
+ endif
+ if (tilefq.ge.1.0) then
+ dtilef = tilefq
+ elseif (tilefq.ne.0.0) then
+ dtilef = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*tilefq)/baclin))
+ else !no 3-d archives
+ dtilef = huge*(baclin/86400.0d0)
+ endif
+#if defined(USE_CCSM3)
+ if (meanfq.eq.0.0) then
+ meanfq = 1.0 !always write out mean archives (value is ignored)
+ endif
+#endif
+ if (meanfq.ge.1.0) then
+ dmeanf = meanfq
+ elseif (meanfq.ne.0.0) then
+ dmeanf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*meanfq)/baclin))
+ else !no mean archives
+ dmeanf = huge*(baclin/86400.0d0)
+ endif
+ if (rstrfq.eq.0.0) then ! no restart
+ drstrf = rstrfq
+ elseif (rstrfq.lt.0.0) then ! no restart at end of run
+ drstrf = -rstrfq
+ elseif (rstrfq.ge.1.0) then
+ drstrf = rstrfq
+ else
+ drstrf = (baclin/86400.0d0)*
+ & max(1,nint((86400.0d0*rstrfq)/baclin))
+ endif
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'ddsurf = ',ddsurf,nint((86400.0d0*ddsurf)/baclin)
+ write(lp,*) 'ddiagf = ',ddiagf,nint((86400.0d0*ddiagf)/baclin)
+ write(lp,*) 'dtilef = ',dtilef,nint((86400.0d0*dtilef)/baclin)
+ write(lp,*) 'dmeanf = ',dmeanf,nint((86400.0d0*dmeanf)/baclin)
+ write(lp,*) 'drstrf = ',drstrf,nint((86400.0d0*drstrf)/baclin)
+ write(lp,*)
+ write (lp,101) thkdf2,temdf2,
+ & thkdf4,
+ & veldf2,visco2,
+ & veldf4,visco4,
+ & diapyc,vertmx
+ 101 format (
+ & ' turb. flux parameters:',1p/
+ & ' thkdf2,temdf2 =',2e9.2/
+ & ' thkdf4 =', e9.2/
+ & ' veldf2,visco2 =',2e9.2/
+ & ' veldf4,visco4 =',2e9.2/
+ & ' diapyc,vertmx =',2e9.2/)
+ endif !1st tile
+
+c
+c --- days in year.
+c
+ if (yrflag.eq.0) then
+c --- 360 days, starting Jan 16
+ dmonth = 30.0d0
+ dbimon = 60.0d0
+ dyear = 360.0d0
+ dyear0 = 0.0d0
+ elseif (yrflag.eq.1) then
+c --- 366 days, starting Jan 16
+ dmonth = 30.5d0
+ dbimon = 61.0d0
+ dyear = 366.0d0
+ dyear0 = 0.0d0
+ elseif (yrflag.eq.2) then
+c --- 366 days, starting Jan 1
+c --- also implies high frequency atmospheric forcing
+ dmonth = 30.5d0
+ dbimon = 61.0d0
+ dyear = 366.0d0
+ dyear0 = -15.0d0+dyear
+ elseif (yrflag.eq.3) then
+c --- model day is calendar days since 01/01/1901
+c --- also implies high frequency atmospheric forcing
+ dyear = 365.25d0
+ dmonth = dyear/12.d0
+ dbimon = dyear/ 6.d0
+ dyear0 = -15.0d0+dyear
+ else
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in hycom - unsupported yrflag value'
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(hycom)')
+ stop '(hycom)' !won't get here
+ endif
+c
+c --- 'lstep' = number of barotropic time steps per baroclinic time step.
+c --- lstep m u s t be even.
+c
+ lstep=nint(baclin/batrop)
+ lstep=2*((lstep+1)/2)
+ dlt=baclin/lstep
+ if (mnproc.eq.1) then
+ write (lp,'(i4,a/)')
+ & lstep,' barotropic steps per baroclinic time step'
+ endif !1st tile
+c
+c --- number of baroclinic time steps per day...
+ nsteps_per_day = nint(86400.0/baclin)
+c
+c --- set up parameters defining the geographic environment
+c
+ call geopar
+#if defined(USE_ESMF)
+c
+c --- set up ESMF data structures
+c
+ call Setup_ESMF(gridComp, impState, expState, extClock, rc)
+ if (ESMF_LogMsgFoundError(rc,
+ & "HYCOM_Init: Setup_ESMF failed", rc))
+ & call ESMF_Finalize(rc=rc)
+#endif
+c
+c --- set up forcing functions
+c
+#if defined(USE_CCSM3)
+!----------------------------------------------------------------------
+! calls to forfuna, forfunk, and forfunp have been removed, because
+! in the coupled version, forcing fields are received from the coupler
+! at the beginning of each coupled interval
+!----------------------------------------------------------------------
+#else
+ if (yrflag.lt.2) then
+ call forfuna ! monthly atmospheric forcing
+ endif
+ if (jerlv0.eq.0) then
+ call forfunk ! annual/monthly kpar
+ endif
+ call forfunp ! annual/monthly rivers
+#endif
+ call forfunr ! bimonthly/monthly climatology
+ watcum=0.
+ empcum=0.
+c
+c --- set minimum salinity for each isopycnic layer
+ do k=2,kk
+ cold=-3.0
+ salmin(k)=(sigma(k)-c1-cold*(c2+cold*(c4+c6*cold)))/
+ & (c3+cold*(c5+c7*cold))
+ enddo
+c
+c --- layer specific volume is defined as (1-theta)*thref
+c --- subtract constant 'thbase' from theta to reduce roundoff errors
+c
+ if (vsigma) then
+ call forfunv ! spacially varying isopycnal target densities
+ else
+ do k=1,kk
+ theta(:,:,k)=sigma(k)-thbase
+ enddo
+ endif
+c
+c --- minimum depth of isopycnmal layers (pressure units).
+c
+ if (isotop.lt.0.0) then
+ call forfunt !spacially varying minimum depths
+ else
+ topiso(:,:)=onem*isotop !constant minimum depth
+ endif
+c
+c --- tidal drag roughness (m/s)
+c
+ if (drgscl.ne.0.0) then
+ call forfund !tidal drag roughness
+ else
+ dragrh(:,:)=0.0
+ endif
+c
+c --- veldf2, veldf4 and thkdf4 may be spacially varying
+c
+ call forfundf
+#if defined(USE_CCSM3)
+!--------------------------------------------------------------
+! initialize time-related variables
+!--------------------------------------------------------------
+ call ccsm3_time_init (time0, time, dtime0, dtime)
+#else
+c
+c --- model is to be integrated from time step 'nstep1' to 'nstep2'
+ open( unit=uoff+99,file=trim(flnminp)//'limits')
+ read( uoff+99,*) day1,day2
+ close(unit=uoff+99)
+c --- non-positive day1 indicates a new initialization, or
+c --- the start of a yrflag==3 case.
+ linit =day1.le.0.0
+ day1 =abs(day1)
+c
+ dtime=day1
+ nstep1=nint(dtime*(86400.0d0/baclin))
+ dtime=nstep1/(86400.0d0/baclin)
+ day1 =dtime
+c
+ dtime=day2
+ nstep2=nint(dtime*(86400.0d0/baclin))
+ dtime=nstep2/(86400.0d0/baclin)
+ day2 =dtime
+#endif /* USE_CCSM3:else */
+c
+ if (mxlkpp) then
+c --- initialize kpp mixing
+ call inikpp
+ elseif (mxlmy) then
+c --- initialize m-y 2.5 mixing
+ call inimy
+ elseif (mxlgiss) then
+c --- initialize nasa giss mixing
+ call inigiss
+ endif
+c
+#if defined(USE_CCSM3)
+ if (linit) then
+ delt1 = baclin
+ dhdx = c0p
+ dhdy = c0p
+ QICE = c0p
+ AQICE = c0p
+ QFLUX = c0p
+c
+c --- set up initial conditions
+c
+ mnth = imonth
+ call inicon(mnth)
+ trcrin = .false.
+ call initrc(mnth)
+c
+c --- setup parameters defining tidal body forces
+c
+ if (tidflg.gt.0) then
+ time_8=dtime0 !'baroclinic' time for body force tides
+ call tides_set(0)
+ endif
+ else
+c
+c --- start from restart file
+c
+ delt1=baclin+baclin
+ if (mnproc == 1) then
+ open(1,file=trim(pointer_filename),form='formatted',status='old')
+ read(1,'(a)') flnmra
+ read(1,'(a)') flnmrb
+ read(1,*)time ! real, in days
+ read(1,*)dtime ! real8, in days
+ read(1,*)nstep,iyear,imonth,iday ! integer
+ &, elapsed_days
+ read(1,*)eom, eoy ! logical
+ close(1)
+ write(lp,*) ' flnm = ', flnmra
+ write(lp,*) ' flnmh = ', flnmrb
+ write(lp,*) ' pointer_filename = ', pointer_filename
+ call flush (lp)
+ write(lp,'(2a)')'(hycom) the restart info from: ',trim(pointer_filename)
+ write(lp,'(2a)')' restart file= ',trim(flnmra)
+ write(lp,*) ' time= ',time
+ write(lp,*) ' nstep= ',nstep
+ write(lp,*) ' iyear= ',iyear
+ write(lp,*) ' imonth= ',imonth
+ write(lp,*) ' iday= ',iday
+ write(lp,*) ' elapsed_days= ',elapsed_days
+ write(lp,*) ' eom= ', eom
+ write(lp,*) ' eoy= ', eoy
+ call flush(lp)
+ endif !mnproc==1
+ !broadcast the above info to all processors:
+ call broadcast_scalar(flnmra, master_task)
+ call broadcast_scalar(flnmrb, master_task)
+ call broadcast_scalar(time, master_task)
+ call broadcast_scalar(dtime, master_task)
+ call broadcast_scalar(nstep, master_task)
+ call broadcast_scalar(iyear, master_task)
+ call broadcast_scalar(imonth, master_task)
+ call broadcast_scalar(iday, master_task)
+ call broadcast_scalar(elapsed_days, master_task)
+ call broadcast_scalar(eom, master_task)
+ call broadcast_scalar(eoy, master_task)
+
+!-----------------------------------------------------------------------
+! make any other needed adjustments after header file has been read
+! and report restart time in format recognized by ccsm3
+!-----------------------------------------------------------------------
+ call ccsm3_time_init1
+
+ call restart_in(nstep,dtime, flnmra, flnmrb)
+
+ if (mnproc == 1 ) then
+ write(lp,*)'(hycom) restartfile reading successful!'
+ endif
+ !
+ time0 = (iyear0-1)*days_in_year+days_in_prior_months(imonth0)
+ & +iday0+0.0001
+ !the above makes time0 be the end of last integration (in days)!
+
+ mnth = imonth
+ call initrc(mnth)
+c
+c --- setup parameters defining tidal body forces
+c
+ if (tidflg.gt.0) then
+ time_8=dtime0 !'baroclinic' time for body force tides
+ call tides_set(0)
+ endif
+ endif !initial conditions
+#else
+ if (linit .and. yrflag.lt.3) then
+c
+c --- set up initial conditions
+c
+ nstep0=nstep1
+ dtime0=nstep0/(86400.0d0/baclin)
+ time0=dtime0
+ delt1=baclin
+ if (clmflg.eq.12) then
+ mnth= 1.+nint(mod(dtime0+dyear0,dyear)/dmonth)
+ elseif (clmflg.eq.6) then
+ mnth=2*(1.+nint(mod(dtime0+dyear0,dyear)/dbimon))-1
+ endif
+ call inicon(mnth)
+ trcrin = .false.
+ call initrc(mnth)
+c
+c --- setup parameters defining tidal body forces
+c
+ if (tidflg.gt.0) then
+ time_8=dtime0 !'baroclinic' time for body force tides
+ call tides_set(0)
+ endif
+c
+c --- output to archive file
+c
+ m=mod(nstep0 ,2)+1
+ n=mod(nstep0+1,2)+1
+ nstep=nstep0
+ time=dtime0
+ call forday(dtime0,yrflag, iyear,jday,ihour)
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ tmix(i,j)=temp(i,j,1,n)
+ smix(i,j)=saln(i,j,1,n)
+ thmix(i,j)=th3d(i,j,1,n)
+ enddo !i
+ enddo !l
+ if (isopyc .or. mxlkrt) then
+ do l=1,isu(j)
+ do i=max(1,ifu(j,l)),min(ii,ilu(j,l))
+ umix(i,j)=u(i,j,1,n)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1,ifv(j,l)),min(ii,ilv(j,l))
+ vmix(i,j)=v(i,j,1,n)
+ enddo !i
+ enddo !l
+ endif !isopyc.or.mxlkrt
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (mnproc.eq.1) then
+ write (intvl,'(i3.3)') 0
+ endif !1st tile
+ if (rstrfq.ne.0.0) then !don't write if benchmarking (no restart)
+ call archiv(n, kk, iyear,jday,ihour, intvl)
+ endif
+c
+ else
+c
+c --- start from restart file
+c
+ flnmra = trim(flnmrsi)//'.a'
+ flnmrb = trim(flnmrsi)//'.b'
+ call restart_in(nstep0,dtime0, flnmra,flnmrb)
+c
+ if (linit) then
+c
+c --- start a new calendar-day (yrflag==3) case.
+ if (mnproc.eq.1) then
+ time0=dtime0
+ write (lp,'(9x,a,f8.1,a,f8.1,a,i9)')
+ & 'restart file for day',time0,
+ & ', is treated as day', day1,' step',nstep1
+ endif !1st tile
+ nstep0=nstep1
+ dtime0=nstep0/(86400.0d0/baclin)
+ time0=dtime0
+ delt1=baclin+baclin
+ else
+ nstep0=nint(dtime0*(86400.0d0/baclin))
+ dtime0=nstep0/(86400.0d0/baclin)
+ time0=dtime0
+ delt1=baclin+baclin
+ if (mnproc.eq.1) then
+ write (lp,'(a,f8.1,a,i9,a, a,f8.1,a,i9,a)')
+ & 'restart on day',time0,' (step',nstep0,')',
+ & ', wanted day', day1,' (step',nstep1,')'
+ endif !1st tile
+ if (nstep0.ne.nstep1) then
+ if (mnproc.eq.1) then
+ write(lp,'(/a/a,f8.1/a,f8.1/)')
+ & 'error in hycom - wrong restart (or limits) file',
+ & 'restart file day is ',time0,
+ & 'limits start day is ',day1
+ endif !1st tile
+ call xcstop('(hycom)')
+ stop '(hycom)' !won't get here
+ endif !nstep0.ne.nstep1
+ endif !linit:else
+c
+ if (clmflg.eq.12) then
+ mnth= 1.+nint(mod(dtime0+dyear0,dyear)/dmonth)
+ elseif (clmflg.eq.6) then
+ mnth=2*(1.+nint(mod(dtime0+dyear0,dyear)/dbimon))-1
+ endif
+ call initrc(mnth)
+c
+c --- setup parameters defining tidal body forces
+c
+ if (tidflg.gt.0) then
+ time_8=dtime0 !'baroclinic' time for body force tides
+ call tides_set(0)
+ endif
+c
+ if (trcout .and. .not.trcrin) then
+c
+c --- new tracers, so output to archive file
+c
+ m=mod(nstep0 ,2)+1
+ n=mod(nstep0+1,2)+1
+ call momtum_hs(n,m) !calculate srfhgt
+ nstep=nstep0
+ time=dtime0
+ call forday(dtime0,yrflag, iyear,jday,ihour)
+ if (mnproc.eq.1) then
+ write (intvl,'(i3.3)') 0
+ endif !1st tile
+ call archiv(n, kk, iyear,jday,ihour, intvl)
+ endif !archive output
+ endif !initial conditions
+#endif /* USE_CCSM3:else */
+c
+c --- set barotp.pot.vort. and layer thickness (incl.bottom pressure) at
+c --- u,v points
+c
+ call dpthuv
+c
+ call xctilr(dp( 1-nbdy,1-nbdy,1,1),1,2*kk, nbdy,nbdy, halo_ps)
+ call xctilr(dpmixl(1-nbdy,1-nbdy, 1),1, 2, nbdy,nbdy, halo_ps)
+ call xctilr(thkk( 1-nbdy,1-nbdy,1 ),1, 2, nbdy,nbdy, halo_ps)
+ call xctilr(psikk( 1-nbdy,1-nbdy,1 ),1, 2, nbdy,nbdy, halo_ps)
+c
+ margin = nbdy
+c
+ do nm=1,2
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (nm.eq.mod(nstep+1,2)+1) then
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpbl(i,j)=dpmixl(i,j,nm)
+ enddo
+ endif
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,1)=0.0
+ do k=1,kk
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,nm)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,nm),
+ & dpv(1-nbdy,1-nbdy,1,nm),
+ & p,depthu,depthv, max(0,margin-1))
+c
+ if (.false.) then
+c
+c --- ISOPYC TO HYBRID RESTART ONLY
+ nstep=nstep1
+ n=nm
+ m=mod(n,2)+1
+ call hybgen(m,n)
+ call xctilr(dp(1-nbdy,1-nbdy,1,n),1,kk, nbdy,nbdy, halo_ps)
+ margin = nbdy
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+!DIR$ PREFERVECTOR
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,1)=0.0
+ do k=1,kk
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, max(0,margin-1))
+ call pipe_comparall(m,n, 'hybgen, step')
+ endif !isopyc to hybrid restart only
+c
+ enddo !nm=1,2
+c
+c --- mean archive initialization.
+c
+ if (meanfq.ne.0.0) then
+ call mean_allocate
+ m=mod(nstep0 ,2)+1
+ n=mod(nstep0+1,2)+1
+ nstep=nstep0
+ time =dtime0
+ call mean_zero(time)
+ call momtum_hs(n,m) !calculate srfhgt
+ if (tidflg.gt.0 .and. abs(meanfq-1.0).lt.0.02) then
+ call mean_add(n, 1.0) !25-hour average daily
+ else
+ call mean_add(n, 0.5)
+ endif
+ endif
+c
+#if ! defined(USE_CCSM3)
+ nod=14
+ nstep=nstep1
+ if (mnproc.eq.1) then
+ write (lp,'(/2(a,f8.1),2(a,i9),a/)') 'model starts at day',
+ & time0,', goes to day',time0+day2-day1,' (steps',nstep1,
+ & ' --',nstep2,')'
+ open (unit=nod,file='summary_out',status='unknown')
+ write(nod,'(/2(a,f8.1),2(a,i9),a/)') 'model starts at day',
+ & time0,', goes to day',time0+day2-day1,' (steps',nstep1,
+ & ' --',nstep2,')'
+ endif !1st tile
+#endif
+c
+ timav=time0
+ m=mod(nstep ,2)+1
+ n=mod(nstep+1,2)+1
+c
+ call pipe_comparall(m,n, 'restrt, step')
+c
+ if (synflt) then
+c --- initialize synthetic floats/moorings
+ call floats_init(m,n,time0)
+ margin = nbdy
+ endif
+#if defined(USE_CCSM3)
+!----------------------------------------------------------
+! in the coupled model, forcing is received from the
+! coupler; therefore code for reading stand-alone version
+! forcing fields has been removed
+!----------------------------------------------------------
+
+ nstep0=nstep
+ m=mod(nstep ,2)+1
+ n=mod(nstep+1,2)+1
+
+ k1m=m !NOT k1m=1+mm
+ k1n=n !NOT k1n=1+nn
+
+
+ !-------------------------------------------------------------
+ ! initialize namelists, grid information, and initial message-
+ ! passing for cpl6
+ !-------------------------------------------------------------
+ call ccsm3_init_coupled(flnmgrdd)
+
+ if (mnproc == 1) then
+ write(lp,*)'(hycom) ccsm3_init_coupled completed'
+ call flush(lp)
+ endif
+
+
+ if (mnproc == 1) then
+ write (*,*) '(hycom) model starts from day, nstep=', iday,nstep
+ endif
+
+ l0=1
+ l1=2
+ l2=3
+ l3=4
+ w0=0.0
+ w1=1.0
+ w2=0.0
+ w3=0.0
+c
+ if (jerlv0.eq.0) then
+c --- read in kpar field for 4 consecutive months
+ mk1=imonth
+ mk0=mod(mk1+10,12)+1
+ mk2=mod(mk1, 12)+1
+ mk3=mod(mk2, 12)+1
+ lk0=1
+ lk1=2
+ lk2=3
+ lk3=4
+ call rdkpar(mk0,lk0)
+ call rdkpar(mk1,lk1)
+ call rdkpar(mk2,lk2)
+ call rdkpar(mk3,lk3)
+ endif
+c
+ if (clmflg.eq.12) then
+c --- read in relaxation climatology fields for 4 consecutive months
+ mc1=imonth
+ mc0=mod(mc1+10,12)+1
+ mc2=mod(mc1, 12)+1
+ mc3=mod(mc2, 12)+1
+ lc0=1
+ lc1=2
+ lc2=3
+ lc3=4
+ call rdrlax(mc0,lc0)
+ call rdrlax(mc1,lc1)
+ call rdrlax(mc2,lc2)
+ call rdrlax(mc3,lc3)
+ elseif (clmflg.eq.6) then
+c --- read in relaxation fields for 4 consecutive bi-months
+ mc1=imonth
+ mc0=mod(mc1+4,6)+1
+ mc2=mod(mc1, 6)+1
+ mc3=mod(mc2, 6)+1
+ lc0=1
+ lc1=2
+ lc2=3
+ lc3=4
+ call rdrlax(2*mc0-1,lc0)
+ call rdrlax(2*mc1-1,lc1)
+ call rdrlax(2*mc2-1,lc2)
+ call rdrlax(2*mc3-1,lc3)
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)') 'error in hycom - unsupported clmflg value'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(hycom)')
+ stop '(hycom)' !won't get here
+ endif
+
+ nod = 14
+ write(cyear,'(i4.4)') iyear
+Cpg - Write out summary files for each month
+ write(flnm,'(a,a,i4.4,a,i2.2)')
+ & trim(flnmsumd),'summary_out.',iyear,'-',imonth
+ if (mnproc==1) then
+ open(unit=nod,file=flnm,status='unknown')
+ write(nod,'(3a,i2.2)')
+ & 'Summary of diagnostic outputs for year ',cyear
+ & , ' month ', imonth
+Cpg
+ write(nod,*)
+ call flush(nod)
+ endif
+#else
+c
+ if (yrflag.lt.2) then
+c
+c --- read in forcing fields for 4 consecutive months
+ ma1=1.+mod(dtime0+dyear0,dyear)/dmonth
+ ma0=mod(ma1+10,12)+1
+ ma2=mod(ma1, 12)+1
+ ma3=mod(ma2, 12)+1
+ l0=1
+ l1=2
+ l2=3
+ l3=4
+ call rdforf(ma0,l0)
+ call rdforf(ma1,l1)
+ call rdforf(ma2,l2)
+ call rdforf(ma3,l3)
+ else
+c
+c --- initial day of high frequency atmospheric forcing.
+c --- only two fields are used (linear interpolation in time).
+ l0=1
+ l1=2
+ l2=3
+ l3=4
+ if (windf) then
+ w0=-99.9
+ w1=-99.0
+ w2=0.0
+ w3=0.0
+ call forfunh(dtime0)
+ else
+ w0=0.0
+ w1=0.0
+ w2=0.0
+ w3=0.0
+ endif
+ endif
+c
+ if (jerlv0.eq.0) then
+c --- read in kpar field for 4 consecutive months
+ mk1=1.+mod(dtime0+dyear0,dyear)/dmonth
+ mk0=mod(mk1+10,12)+1
+ mk2=mod(mk1, 12)+1
+ mk3=mod(mk2, 12)+1
+ lk0=1
+ lk1=2
+ lk2=3
+ lk3=4
+ call rdkpar(mk0,lk0)
+ call rdkpar(mk1,lk1)
+ call rdkpar(mk2,lk2)
+ call rdkpar(mk3,lk3)
+ endif
+c
+ if (priver) then
+c --- read in rivers field for 4 consecutive months
+ mr1=1.+mod(dtime0+dyear0,dyear)/dmonth
+ mr0=mod(mr1+10,12)+1
+ mr2=mod(mr1, 12)+1
+ mr3=mod(mr2, 12)+1
+ lr0=1
+ lr1=2
+ lr2=3
+ lr3=4
+ call rdrivr(mr0,lr0)
+ call rdrivr(mr1,lr1)
+ call rdrivr(mr2,lr2)
+ call rdrivr(mr3,lr3)
+ endif
+c
+ if (clmflg.eq.12) then
+c --- read in relaxation climatology fields for 4 consecutive months
+ mc1=1.+mod(dtime0+dyear0,dyear)/dmonth
+ mc0=mod(mc1+10,12)+1
+ mc2=mod(mc1, 12)+1
+ mc3=mod(mc2, 12)+1
+ lc0=1
+ lc1=2
+ lc2=3
+ lc3=4
+ call rdrlax(mc0,lc0)
+ call rdrlax(mc1,lc1)
+ call rdrlax(mc2,lc2)
+ call rdrlax(mc3,lc3)
+ elseif (clmflg.eq.6) then
+c --- read in relaxation fields for 4 consecutive bi-months
+ mc1=1.+mod(dtime0+dyear0,dyear)/dbimon
+ mc0=mod(mc1+4,6)+1
+ mc2=mod(mc1, 6)+1
+ mc3=mod(mc2, 6)+1
+ lc0=1
+ lc1=2
+ lc2=3
+ lc3=4
+ call rdrlax(2*mc0-1,lc0)
+ call rdrlax(2*mc1-1,lc1)
+ call rdrlax(2*mc2-1,lc2)
+ call rdrlax(2*mc3-1,lc3)
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)') 'error in hycom - unsupported clmflg value'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(hycom)')
+ stop '(hycom)' !won't get here
+ endif
+c
+ if (bnstfq.ne.0.0) then ! initialize barotropic boundary input
+ wb0=-99.0
+ wb1=-99.0
+ call rdbaro(dtime0)
+ endif
+c
+ if (nestfq.ne.0.0) then ! initialise 3-d nesting input
+ wn0=-99.0
+ wn1=-99.0
+ call rdnest(dtime0)
+ endif
+#endif /* USE_CCSM3:else */
+c
+c --- initialize incremental update.
+c
+ if (incflg.ne.0) then
+ call incupd_init(dtime0)
+c
+ if (incstp.eq.1) then
+ call xctmr0(54)
+ call incupd(1)
+ call incupd(2)
+ call xctmr1(54)
+ endif ! full insertion of update
+ endif
+#if defined(USE_ESMF)
+c
+c --- Fill the Export State with the initial fields.
+c
+ m=mod(nstep0 ,2)+1
+ n=mod(nstep0+1,2)+1
+ call momtum_hs(n,m)
+ call Export_ESMF
+#else
+c
+c --- Only here for compatibility with coupled runs.
+c
+ m=mod(nstep0 ,2)+1
+ n=mod(nstep0+1,2)+1
+ call momtum_hs(n,m)
+#endif
+c
+c --- report initialization time.
+c
+ call xctmrp
+c
+ end subroutine HYCOM_Init
+
+ subroutine HYCOM_Run
+#if defined(USE_ESMF)
+ & (gridComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_GridComp) :: gridComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+#endif
+c
+c --- -------------------------
+c --- execute a single timestep
+c --- -------------------------
+c
+ logical lfatal
+ integer i,j,jja,k,ktr,l,nm
+ character*80 flnmra,flnmrb
+c
+ logical hycom_isnaninf !function to detect NaN and Inf
+c
+ include 'stmt_fns.h'
+c
+c --- letter 'm' refers to mid-time level (example: dp(i,j,k,m) )
+c --- letter 'n' refers to old and new time level
+c
+ m=mod(nstep ,2)+1
+ n=mod(nstep+1,2)+1
+c
+#if defined(USE_CCSM3)
+ k1m=m !NOT k1m=1+mm (DBI)
+ k1n=n !NOT k1n=1+nn (DBI)
+
+!-------------------------------------------------------------------------
+! exchange fields and fluxes with the ccsm3 flux coupler
+!-------------------------------------------------------------------------
+ call ccsm3_set_coupled_forcing
+
+!--------------------------------------------------------
+! stop if cpl has sent the stop signal
+!--------------------------------------------------------
+ end_of_run = stop_now == 1
+ if (end_of_run) then
+c --- output float restart file
+ if (synflt) then
+ call floats_restart
+ endif !synflt
+ return
+ endif
+
+!-------------------------------------------------------------------------
+! ccsm3-related time-keeping
+!-------------------------------------------------------------------------
+ call ccsm3_time_advance (time, dtime)
+c
+ hisurf=.false.
+ histry=.false.
+ hitile=.false.
+ histmn=dohist
+ restrt=dorestart .or. (cpl_write_restart .and. eod)
+ diagno=mod(dtime+dsmall,ddiagf).lt.dsmall2 .or. restrt
+c
+c --- set weights for quasi-hermite time interpolation for kpar.
+ if (jerlv0.eq.0) then
+c --- monthly fields.
+ if (imonth.ne.mk1) then
+ mk1=imonth
+ mk0=mod(mk1+10,12)+1
+ mk2=mod(mk1, 12)+1
+ mk3=mod(mk2, 12)+1
+ lt =lk0
+ lk0=lk1
+ lk1=lk2
+ lk2=lk3
+ lk3=lt
+ call rdkpar(mk3,lk3)
+ endif
+ wk1=1.0 !constant for the month
+ wk2=0.0
+ wk0=0.0
+ wk3=0.0
+ endif
+c
+c --- set weights for quasi-hermite time interpolation for temperature,
+c --- salinity and pressure relaxation fields.
+ if (clmflg.eq.12) then
+c --- monthly fields.
+ if (imonth.ne.mc1) then
+ mc1=imonth
+ mc0=mod(mc1+10,12)+1
+ mc2=mod(mc1, 12)+1
+ mc3=mod(mc2, 12)+1
+ lt =lc0
+ lc0=lc1
+ lc1=lc2
+ lc2=lc3
+ lc3=lt
+ call rdrlax(mc3,lc3)
+ endif
+ wc1=1.0 !constant for the month
+ wc2=0.0
+ wc0=0.0
+ wc3=0.0
+ endif
+cdiag if (mnproc.eq.1) then
+cdiag write (lp,'(i9,'' relax time interpolation: months'',4i3,
+cdiag. '', weights '',4f6.3)') nstep,lc0,lc1,lc2,lc3,wc0,wc1,wc2,wc3
+cdiag endif !1st tile
+#else
+ nstep=nstep+1
+ dtime=dtime0+(nstep-nstep0)/(86400.0d0/baclin)
+c
+ time =dtime
+ time_8=dtime !'baroclinic' time for body force tides
+ if (tidflg.gt.0 .and.
+ & mod(dtime+dsmall,hours1).lt.dsmall2) then
+ call tides_detide(n, .true.) !update 25-hour average
+ endif
+ hisurf=mod(dtime+dsmall,ddsurf).lt.dsmall2
+ histry=mod(dtime+dsmall,ddiagf).lt.dsmall2 .or.
+ & (nstep.ge.nstep2 .and. arcend)
+ hitile=mod(dtime+dsmall,dtilef).lt.dsmall2
+ histmn=mod(dtime+dsmall,dmeanf).lt.dsmall2 .or.
+ & nstep.ge.nstep2
+ if (rstrfq.eq.0.0) then ! no restart
+ restrt=.false. ! for benchmark cases only
+ elseif (drstrf.gt.dtime0) then !at most one restart within the run
+ if (rstrfq.lt.0.0) then ! no restart at end of run
+ restrt=mod(dtime+dsmall,drstrf).lt.dsmall2
+ else
+ restrt=mod(dtime+dsmall,drstrf).lt.dsmall2 .or.
+ & nstep.ge.nstep2
+ endif
+ else
+ if (rstrfq.lt.0.0) then ! no restart at end of run
+ restrt=mod(dtime-dtime0+dsmall,drstrf).lt.dsmall2
+ else
+ restrt=mod(dtime-dtime0+dsmall,drstrf).lt.dsmall2 .or.
+ & nstep.ge.nstep2
+ endif
+ endif
+ diagno=mod(dtime+dsmall,ddiagf).lt.dsmall2 .or.
+ & restrt .or. nstep.ge.nstep2
+ if (yrflag.lt.2) then
+c
+c --- set weights for quasi-hermite time interpolation for
+c --- monthly atmospheric forcing fields
+ x=1.+mod(dtime+dyear0,dyear)/dmonth
+c --- keep quadruplet of forcing functions centered on model time
+ if (int(x).ne.ma1) then
+ ma1=x
+ ma0=mod(ma1+10,12)+1
+ ma2=mod(ma1, 12)+1
+ ma3=mod(ma2, 12)+1
+ lt=l0
+ l0=l1
+ l1=l2
+ l2=l3
+ l3=lt
+c --- newest set of forcing functions overwrites set no longer needed
+ call rdforf(ma3,l3)
+ endif
+ x=mod(x,1.)
+ x1=1.-x
+ w1=x1*(1.+x *(1.-1.5*x ))
+ w2=x *(1.+x1*(1.-1.5*x1))
+ w0=-.5*x *x1*x1
+ w3=-.5*x1*x *x
+cdiag if (mnproc.eq.1) then
+cdiag write (lp,'(i9,'' atmos time interpolation: months'',4i3,
+cdiag. '', weights '',4f6.3)') nstep,l0,l1,l2,l3,w0,w1,w2,w3
+cdiag endif !1st tile
+ elseif (windf) then
+c
+c --- set weights and fields for high frequency atmospheric forcing.
+c --- only two fields are used (linear interpolation in time).
+ call forfunh(dtime)
+ endif
+c
+c --- set weights for quasi-hermite time interpolation for kpar.
+ if (jerlv0.eq.0) then
+c --- monthly fields.
+ x=1.+mod(dtime+dyear0,dyear)/dmonth
+ if (int(x).ne.mk1) then
+ mk1=x
+ mk0=mod(mk1+10,12)+1
+ mk2=mod(mk1, 12)+1
+ mk3=mod(mk2, 12)+1
+ lt =lk0
+ lk0=lk1
+ lk1=lk2
+ lk2=lk3
+ lk3=lt
+ call rdkpar(mk3,lk3)
+ endif
+ x=mod(x,1.)
+ x1=1.-x
+ wk1=x1*(1.+x *(1.-1.5*x ))
+ wk2=x *(1.+x1*(1.-1.5*x1))
+ wk0=-.5*x *x1*x1
+ wk3=-.5*x1*x *x
+ endif
+c
+c --- set weights for quasi-hermite time interpolation for rivers.
+ if (priver) then
+c --- monthly fields.
+ x=1.+mod(dtime+dyear0,dyear)/dmonth
+ if (int(x).ne.mr1) then
+ mr1=x
+ mr0=mod(mr1+10,12)+1
+ mr2=mod(mr1, 12)+1
+ mr3=mod(mr2, 12)+1
+ lt =lr0
+ lr0=lr1
+ lr1=lr2
+ lr2=lr3
+ lr3=lt
+ call rdrivr(mr3,lr3)
+ endif
+ x=mod(x,1.)
+ x1=1.-x
+ wr1=x1*(1.+x *(1.-1.5*x ))
+ wr2=x *(1.+x1*(1.-1.5*x1))
+ wr0=-.5*x *x1*x1
+ wr3=-.5*x1*x *x
+ endif
+c
+c --- set weights for quasi-hermite time interpolation for temperature,
+c --- salinity and pressure relaxation fields.
+ if (clmflg.eq.12) then
+c --- monthly fields.
+ x=1.+mod(dtime+dyear0,dyear)/dmonth
+ if (int(x).ne.mc1) then
+ mc1=x
+ mc0=mod(mc1+10,12)+1
+ mc2=mod(mc1, 12)+1
+ mc3=mod(mc2, 12)+1
+ lt =lc0
+ lc0=lc1
+ lc1=lc2
+ lc2=lc3
+ lc3=lt
+ call rdrlax(mc3,lc3)
+ endif
+ x=mod(x,1.)
+ x1=1.-x
+ wc1=x1*(1.+x *(1.-1.5*x ))
+ wc2=x *(1.+x1*(1.-1.5*x1))
+ wc0=-.5*x *x1*x1
+ wc3=-.5*x1*x *x
+ elseif (clmflg.eq.6) then
+c --- bi-monthly fields.
+ x=1.+mod(dtime+dyear0,dyear)/dbimon
+ if (int(x).ne.mc1) then
+ mc1=x
+ mc0=mod(mc1+4,6)+1
+ mc2=mod(mc1, 6)+1
+ mc3=mod(mc2, 6)+1
+ lt =lc0
+ lc0=lc1
+ lc1=lc2
+ lc2=lc3
+ lc3=lt
+ call rdrlax(2*mc3-1,lc3)
+ endif
+ x=mod(x,1.)
+ x1=1.-x
+ wc1=x1*(1.+x *(1.-1.5*x ))
+ wc2=x *(1.+x1*(1.-1.5*x1))
+ wc0=-.5*x *x1*x1
+ wc3=-.5*x1*x *x
+ endif
+cdiag if (mnproc.eq.1) then
+cdiag write (lp,'(i9,'' relax time interpolation: months'',4i3,
+cdiag. '', weights '',4f6.3)') nstep,lc0,lc1,lc2,lc3,wc0,wc1,wc2,wc3
+cdiag endif !1st tile
+#endif /* USE_CCSM3:else */
+c
+#if defined(USE_ESMF)
+ if (get_import) then ! new ESMF Import fields
+ call Import_ESMF
+ if (nstep.eq.nstep0+1) then
+ time=dtime0
+ call forday(dtime0,yrflag, iyear,jday,ihour)
+ call Archive_ESMF(iyear,jday,ihour)
+ time=dtime
+ endif !initial ESMF Archive
+ endif !get_import
+#endif
+c
+ if (bnstfq.ne.0.0) then ! new fields for baro nesting
+ call rdbaro(dtime)
+ endif
+c
+ if (nestfq.ne.0.0) then ! new fields for 3-d nesting
+ call rdnest(dtime)
+ endif
+c
+ call pipe_comparall(m,n, 'ENTER , step')
+ call xctmr0(40)
+ call cnuity(m,n)
+ call xctmr1(40)
+ call pipe_comparall(m,n, 'cnuity, step')
+ call xctmr0(41)
+ call tsadvc(m,n)
+ call xctmr1(41)
+ call pipe_comparall(m,n, 'tsadvc, step')
+ call xctmr0(42)
+ if (momtyp.eq.2) then
+ call momtum(m,n)
+ else !momtyp.eq.4
+ call momtum4(m,n)
+ endif
+ call xctmr1(42)
+ call pipe_comparall(m,n, 'momtum, step')
+ call xctmr0(43)
+ call barotp(m,n)
+ call xctmr1(43)
+ call pipe_comparall(m,n, 'barotp, step')
+ call xctmr0(44)
+#if defined(USE_CCSM3)
+ call thermf_c(m,n) !,mm,nn,k1m,k1n)
+ call xctmr1(44)
+ call pipe_comparall(m,n, 'thermf, step')
+ !get potential freezing/melting heat flux needed for ice model.
+ !mixed layer T and S are adjusted only TWICE in each coupling interval.
+ !
+ call ice_formation(k1n, ice_ts)
+ !===================================================================
+ !if (.false. .and. ice_ts) then !DBI: switched this call off!
+ ! call ice_flx_to_coupler ! work done in ice_formation now!
+ !endif
+#else
+ call thermf(m,n, dtime)
+ call xctmr1(44)
+ call pipe_comparall(m,n, 'thermf, step')
+ if (icegln) then
+ call xctmr0(45)
+ call icloan(m,n)
+ call thermf_oi(m,n)
+ call xctmr1(45)
+ call pipe_comparall(m,n, 'icloan, step')
+ elseif (iceflg.ge.2) then
+ call xctmr0(45)
+ call thermf_oi(m,n)
+ call xctmr1(45)
+ call pipe_comparall(m,n, 'icecpl, step')
+ else
+ call xctmr0(45)
+ call thermf_oi(m,n)
+ call xctmr1(45)
+ call pipe_comparall(m,n, 'thermf, step') !thermf_oi
+ endif !icegln:icecpl:else
+#endif /* USE_CCSM3:else */
+ if (trcout) then
+ call xctmr0(50)
+ call trcupd(m,n)
+ call xctmr1(50)
+ call pipe_comparall(m,n, 'trcupd, step')
+ endif !trcout
+ if (hybrid) then
+ diagsv = diagno
+ diagno = diagno .or. nstep.eq.nstep0+1 .or.
+ & histry .or. hisurf .or. hitile .or.
+ & mod(dtime+dsmall,days6).lt.dsmall2
+ if (mxlkpp .or. mxlmy .or. mxlgiss) then
+ call xctmr0(46)
+ call mxkprf(m,n)
+ call xctmr1(46)
+ call pipe_comparall(m,n, 'mxkprf, step')
+ elseif (mxlpwp) then
+ call xctmr0(46)
+ call mxpwp(m,n)
+ call xctmr1(46)
+ call pipe_comparall(m,n, 'mxpwp, step')
+ elseif (mxlkta) then
+ call xctmr0(46)
+ call mxkrta(m,n)
+ call xctmr1(46)
+ call pipe_comparall(m,n, 'mxkrta, step')
+ elseif (mxlktb) then
+ call xctmr0(46)
+ call mxkrtb(m,n)
+ call xctmr1(46)
+ call pipe_comparall(m,n, 'mxkrtb, step')
+ else
+ call xctmr0(46)
+ call xctmr1(46)
+ endif !mixed layer
+ diagno = diagsv
+ if (mxlkpp .or. mxlmy .or. mxlgiss) then !tsoff in mxkprf
+ call xctmr0(47)
+ call xctmr1(47)
+ call xctmr0(48)
+ call xctmr1(48)
+ else ! mxlpwp has dypflg=2
+ call xctmr0(47)
+ call convch(m,n)
+ call xctmr1(47)
+ call pipe_comparall(m,n, 'convch, step')
+ if (dypflg.eq.1) then ! KPP-like, tsoff in diapf1
+ call xctmr0(48)
+ call diapf1(m,n)
+ call xctmr1(48)
+ call pipe_comparall(m,n, 'diapf1, step')
+ elseif (dypflg.eq.2) then ! explicit, tsoff in diapf2
+ call xctmr0(48)
+ call diapf2(m,n)
+ call xctmr1(48)
+ call pipe_comparall(m,n, 'diapf2, step')
+ else
+ call xctmr0(48)
+ call xctmr1(48)
+ endif
+ endif !diapycnal mixing
+ if (incflg.ne.0 .and. incstp.gt.1) then
+ call xctmr0(54)
+ call incupd(n)
+ call xctmr1(54)
+ call pipe_comparall(m,n, 'incupd, step')
+ else
+ call xctmr0(54)
+ call xctmr1(54)
+ endif ! incremental update
+ call xctmr0(49)
+ call hybgen(m,n)
+ call xctmr1(49)
+ call pipe_comparall(m,n, 'hybgen, step')
+ else ! isopyc
+ call xctmr0(46)
+ call mxkrtm(m,n)
+ call xctmr1(46)
+ call pipe_comparall(m,n, 'mxkrtm, step')
+ call xctmr0(47)
+ call convcm(m,n)
+ call xctmr1(47)
+ call pipe_comparall(m,n, 'convcm, step')
+ call xctmr0(48)
+ call diapf3(m,n)
+ call xctmr1(48)
+ call pipe_comparall(m,n, 'diapf3, step')
+ call xctmr0(54)
+ call xctmr1(54)
+ call xctmr0(49)
+ call xctmr1(49)
+ endif !hybrid:isopyc
+c
+c --- update floats/moorings
+ if (synflt) then
+ nstepfl=nstepfl+1
+ if (nstepfl.eq.1) then
+ iofl=1
+ call floats(m,n,0.0,iofl)
+ endif
+ if (mod(nstepfl,nfldta).eq.0) then
+ iofl=0
+ if (mod(nstepfl,nflsam).eq.0) then
+ iofl=1
+ endif
+ call floats(m,n,nstepfl*baclin/86400.0,iofl)
+ endif
+ endif !synflt
+c
+c ---------------------------------------------------------------------------
+c
+c --- output and diagnostic calculations
+c
+c ---------------------------------------------------------------------------
+c
+ lfatal = .false.
+ diag_tide = tidflg.gt.0 .and.
+ & mod(dtime+dsmall,hours1).lt.dsmall2 !at least hourly
+ if (diagno .or. histry .or. hitile .or. hisurf .or. histmn .or.
+ & nstep.eq.nstep0+1 .or.
+ & diag_tide .or.
+ & mod(dtime+dsmall,ddsurf).lt.dsmall2 .or.
+ & mod(dtime+dsmall, days1).lt.dsmall2 ) then ! at least daily
+c
+#if defined(ARCTIC)
+c --- Arctic (tripole) domain, top row is replicated (ignore it)
+ jja = min( jj, jtdm-1-j0 )
+ if (jja.ne.jj) then
+ do i=1,ii
+ util1(i,jj)=0.0
+ util2(i,jj)=0.0
+ util3(i,jj)=0.0
+ util4(i,jj)=0.0
+ util5(i,jj)=0.0
+ enddo
+ endif
+#else
+ jja = jj
+#endif
+c
+#if defined(USE_CCSM3)
+ jday = days_in_prior_months(imonth)+iday
+#else
+ call forday(dtime,yrflag, iyear,jday,ihour)
+#endif
+ write(c_ydh,'('' ('',i4.4,''/'',i3.3,1x,i2.2,'')'')')
+ & iyear,jday,ihour
+c
+c --- diagnose mean sea surface height
+
+ if (.not.allocated(sminy)) then
+ allocate( sminy(1:jj), smaxy(1:jj) )
+ endif
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ sminy(j)= huge
+ smaxy(j)=-huge
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ if (tidflg.gt.0) then
+ util2(i,j)=(srfhgt(i,j)/g)**2*scp2(i,j)
+ endif
+ util3(i,j)=srfhgt(i,j)*scp2(i,j)
+ util4(i,j)=montg1(i,j)*scp2(i,j)
+ sminy(j)=min(sminy(j),srfhgt(i,j))
+ smaxy(j)=max(smaxy(j),srfhgt(i,j))
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ smin=minval(sminy(1:jja))
+ smax=maxval(smaxy(1:jja))
+ call xcminr(smin)
+ call xcmaxr(smax)
+ call xcsum( dsum, util3,ip)
+ call xcsum( dsmt, util4,ip)
+ sum=dsum
+ smt=dsmt
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean SSH (mm):'',f8.2,
+ & '' ('',1pe8.1,'' to '',e8.1,'')'')')
+ & nstep,c_ydh,
+ & sum/(area*thref*onemm),smin/(thref*onemm),smax/(thref*onemm)
+* write (lp,'(i9,a,
+* . '' mean MontgPot (mm):'',f8.2)')
+* . nstep,c_ydh,
+* . smt/(area*thref*onemm)
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean SSH (mm):'',f8.2,
+ & '' ('',1pe8.1,'' to '',e8.1,'')'')')
+ & nstep,c_ydh,
+ & sum/(area*thref*onemm),smin/(thref*onemm),smax/(thref*onemm)
+* write(nod,'(i9,a,
+* . '' mean MontgPot (mm):'',f8.2)')
+* . nstep,c_ydh,
+* . smt/(area*thref*onemm)
+ call flush(nod)
+ endif !1st tile
+c --- NaN detection.
+ if (hycom_isnaninf(smin) .or.
+ & hycom_isnaninf(sum) .or.
+ & hycom_isnaninf(smax) .or.
+ & hycom_isnaninf(smt) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error - NaN or Inf detected'
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ lfatal = .true. !delay exit to allow archive output
+ endif !NaN
+c
+ if (tidflg.gt.0) then
+ call xcsum( dsms, util2,ip)
+ sms=dsms/area
+c
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(ubavg(1-nbdy,1-nbdy, n),1, 1, 1,1, halo_uv)
+ call xctilr(vbavg(1-nbdy,1-nbdy, n),1, 1, 1,1, halo_vv)
+c
+ dskea=0.0d0
+ do k=1,kk
+!$OMP PARALLEL DO PRIVATE(j,l,i,utotp,vtotp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ utotp=0.5*( u(i, j,k,n)+ubavg(i, j,n) +
+ & u(i+1,j,k,n)+ubavg(i+1,j,n) )
+ vtotp=0.5*( v(i,j, k,n)+vbavg(i,j, n) +
+ & v(i,j+1,k,n)+vbavg(i,j+1,n) )
+ util4(i,j)=dp(i,j,k,n)*scp2(i,j)*
+ & 0.5*(1000.0+th3d(i,j,k,n)+thbase)*
+ & (utotp**2+vtotp**2)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dske, util4,ip)
+ dskea=dskea+dske
+ enddo !k
+ sum=dskea/(area*onem)
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' region-wide mean KE: '',f20.10)')
+ & nstep,c_ydh,
+ & sum
+ write (lp,'(i9,a,
+ & '' region-wide mean APE:'',f20.10)')
+ & nstep,c_ydh,
+ & sms*0.5*g*(1000.0+thbase)
+ endif
+ endif !tidflg
+* else
+* if (mnproc.eq.1) then
+* write (lp,'('' time step ='',i9)') nstep
+* call flush(lp)
+* endif !1st tile
+ endif !daily or hourly
+c
+c --- diagnose heat/salt flux, ice, layer thickness and temperature,
+c --- mean temperature and mean kinetic energy
+c --- note that mixed-layer fields must be switched on in mxkprf
+ if (diagno .or.
+ & nstep.eq.nstep0+1 .or.
+ & mod(dtime+dsmall,days6).lt.dsmall2) then ! at least every 6 days
+c
+#if defined(ARCTIC)
+c --- Arctic (tripole) domain, top row is replicated (ignore it)
+ jja = min( jj, jtdm-1-j0 )
+ if (jja.ne.jj) then
+ do i=1,ii
+ util1(i,jj)=0.0
+ util2(i,jj)=0.0
+ util3(i,jj)=0.0
+ util4(i,jj)=0.0
+ util5(i,jj)=0.0
+ enddo
+ endif
+#else
+ jja = jj
+#endif
+c
+#if defined(USE_CCSM3)
+ jday = days_in_prior_months(imonth)+iday
+#else
+ call forday(dtime,yrflag, iyear,jday,ihour)
+#endif
+ write(c_ydh,'('' ('',i4.4,''/'',i3.3,1x,i2.2,'')'')')
+ & iyear,jday,ihour
+c
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=buoflx(i,j)*scp2(i,j)
+ util2(i,j)=bhtflx(i,j)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsum, util1,ip)
+ call xcsum(dsmt, util2,ip)
+ sum= (dsum*1.00D9)/area ! 1.e9*m**2/sec**3
+ smt= (dsmt*1.00D9)/area ! 1.e9*m**2/sec**3
+ if (mnproc.eq.1) then
+ write (lp, '(i9,a,
+ & '' mean BFL (m^2/s^3):'',f8.2,
+ & '' hfl:'',f8.2)')
+ & nstep,c_ydh,
+ & sum,smt
+ call flush(lp)
+ write (nod,'(i9,a,
+ & '' mean BFL (m^2/s^3):'',f8.2,
+ & '' hfl:'',f8.2)')
+ & nstep,c_ydh,
+ & sum,smt
+ call flush(nod)
+ endif !1st tile
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=surflx(i,j)*scp2(i,j)
+ util2(i,j)=mixflx(i,j)*scp2(i,j)
+ util3(i,j)=sstflx(i,j)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsum, util1,ip)
+ call xcsum(dsmt, util2,ip)
+ call xcsum(d3, util3,ip)
+ sum= dsum/area
+ smt= dsmt/area
+ smr= d3 /area
+ if (mnproc.eq.1) then
+ write (lp, '(i9,a,
+ & '' mean HFLUX (w/m^2):'',f8.2,
+ & '' sst:'',f8.2,
+ & '' ml:'',f8.2)')
+ & nstep,c_ydh,
+ & sum,smr,smt
+ call flush(lp)
+ write (nod,'(i9,a,
+ & '' mean HFLUX (w/m^2):'',f8.2,
+ & '' sst:'',f8.2,
+ & '' ml:'',f8.2)')
+ & nstep,c_ydh,
+ & sum,smr,smt
+ call flush(nod)
+ endif !1st tile
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=salflx(i,j)*scp2(i,j)/saln(i,j,1,n)
+ util2(i,j)=sssflx(i,j)*scp2(i,j)/saln(i,j,1,n)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsms, util1,ip)
+ call xcsum(dsum, util2,ip)
+ sms=-(dsms*thref*7.0D0*8.64D7)/area ! P-E in mm/week
+ smr=-(dsum*thref*7.0D0*8.64D7)/area ! P-E in mm/week
+ if (mnproc.eq.1) then
+ write (lp, '(i9,a,
+ & '' mean WFLUX (mm/wk):'',f8.2,
+ & '' sss:'',f8.2)')
+ & nstep,c_ydh,
+ & sms,smr
+ call flush(lp)
+ write (nod,'(i9,a,
+ & '' mean WFLUX (mm/wk):'',f8.2,
+ & '' sss:'',f8.2)')
+ & nstep,c_ydh,
+ & sms,smr
+ call flush(nod)
+ endif !1st tile
+ endif
+c
+ if (icegln) then ! basin-wide ice
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ if (covice(i,j).ne.0.0) then
+ util2(i,j)=covice(i,j)* scp2(i,j)
+ util3(i,j)= thkice(i,j)*scp2(i,j)
+ util4(i,j)=covice(i,j)*temice(i,j)*scp2(i,j)
+ else
+ util2(i,j)=0.0
+ util3(i,j)=0.0
+ util4(i,j)=0.0
+ endif
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d2, util2,ip)
+ call xcsum(d3, util3,ip)
+ call xcsum(d4, util4,ip)
+ if (d2.gt.0.0d0) then
+ sum=d3/d2 !average ice thickness, where there is ice
+ smt=d4/d2 !average ice temperature, where there is ice
+ sms=d2/area * 100.0 !ice coverage, percent of total area
+ else
+ sum=0.0
+ smt=0.0
+ sms=0.0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean ice thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean ice thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(nod)
+ endif !1st tile
+ endif ! icegln
+c
+ if (nreg.ne.0 .and. icegln) then ! southern hemisphere ice
+ d2a = d2
+ d3a = d3
+ d4a = d4
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ if (covice(i,j).ne.0.0 .and.
+ & plat(i,j).lt.0.0 ) then
+ util2(i,j)=covice(i,j)* scp2(i,j)
+ util3(i,j)= thkice(i,j)*scp2(i,j)
+ util4(i,j)=covice(i,j)*temice(i,j)*scp2(i,j)
+ else
+ util2(i,j)=0.0
+ util3(i,j)=0.0
+ util4(i,j)=0.0
+ endif
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d2, util2,ip)
+ call xcsum(d3, util3,ip)
+ call xcsum(d4, util4,ip)
+ if (d2.gt.0.0d0) then
+ sum=d3/d2 !average ice thickness, where there is ice in S.H.
+ smt=d4/d2 !average ice temperature, where there is ice in S.H.
+ sms=d2/area * 100.0 !S.H. ice coverage, percent of total area
+ else
+ sum=0.0
+ smt=0.0
+ sms=0.0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean SH I thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean SH I thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(nod)
+ endif !1st tile
+c
+ d2 = d2a - d2
+ d3 = d3a - d3
+ d4 = d4a - d4
+ if (d2.gt.0.0d0) then
+ sum=d3/d2 !average ice thickness, where there is ice in N.H.
+ smt=d4/d2 !average ice temperature, where there is ice in N.H.
+ sms=d2/area * 100.0 !N.H. ice coverage, percent of total area
+ else
+ sum=0.0
+ smt=0.0
+ sms=0.0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean NH I thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean NH I thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' pcen:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(nod)
+ endif !1st tile
+ endif ! icegln .and. nreg.ne.0
+c
+ if (icegln .and.
+ & (icmflg.eq.2 .or. ticegr.eq.0.0 .or.
+ & lwflag.eq.2 .or. sstflg.eq.2 )) then
+c
+c --- ice mask
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,tsur)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+c
+c --- don't allow a new tsur maximum, to preserve sea ice
+c
+ if (yrflag.lt.2) then
+ tsur = min( max( surtmp(i,j,l0), surtmp(i,j,l1),
+ & surtmp(i,j,l2), surtmp(i,j,l3) ),
+ & surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1+
+ & surtmp(i,j,l2)*w2+surtmp(i,j,l3)*w3 )
+ else
+ tsur = min( max( surtmp(i,j,l0), surtmp(i,j,l1) ),
+ & surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1 )
+ endif
+ if (tsur.le.tfrz_n) then
+ util1(i,j) = scp2(i,j)
+ if (plat(i,j).lt.0.0) then
+ util2(i,j) = scp2(i,j)
+ else
+ util2(i,j) = 0.0
+ endif
+ else
+ util1(i,j) = 0.0
+ util2(i,j) = 0.0
+ endif
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsmt, util1,ip)
+ call xcsum(dsms, util2,ip)
+ smt=dsmt/area * 100.0
+ sms=dsms/area * 100.0
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean ice mask pcen:'',f9.3,
+ & '' S.H:'',f7.3,
+ & '' N.H:'',f7.3)')
+ & nstep,c_ydh,
+ & smt,sms,smt-sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean ice mask pcen:'',f9.3,
+ & '' S.H:'',f7.3,
+ & '' N.H:'',f7.3)')
+ & nstep,c_ydh,
+ & smt,sms,smt-sms
+ call flush(nod)
+ endif !1st tile
+ endif !ice mask statistics
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=dpmixl(i,j,n)*scp2(i,j)
+ util2(i,j)=dpmixl(i,j,n)*scp2(i,j)*tmix(i,j)
+ util3(i,j)=dpmixl(i,j,n)*scp2(i,j)*smix(i,j)
+ util4(i,j)=temp(i,j,1,n)*scp2(i,j)
+ util5(i,j)=saln(i,j,1,n)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsum, util1,ip)
+ call xcsum(dsmt, util2,ip)
+ call xcsum(dsms, util3,ip)
+ if (dsum.ne.0.0d0) then
+ sum=dsum/(area*onem)
+ smt=dsmt/dsum
+ sms=dsms/dsum
+ else
+ sum=0.0
+ smt=0.0
+ sms=0.0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean mixl thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' saln:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean mixl thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' saln:'',f7.3)')
+ & nstep,c_ydh,
+ & sum,smt,sms
+ call flush(nod)
+ endif !1st tile
+c
+ call xcsum(dsmt, util4,ip)
+ call xcsum(dsms, util5,ip)
+ smt=dsmt/area
+ sms=dsms/area
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean surf thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' sss:'',f7.3)')
+ & nstep,c_ydh,
+ & dp00*qonem,smt,sms !dp00 is max, not mean, surf thk.
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean surf thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' sss:'',f7.3)')
+ & nstep,c_ydh,
+ & dp00*qonem,smt,sms !dp00 is max, not mean, surf thk.
+ call flush(nod)
+ endif !1st tile
+c
+ if (relaxf .or. sstflg.ne.0) then
+c
+c --- mean surface climatology.
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ if (relaxf .and. sstflg.le.1) then
+ util1(i,j)=scp2(i,j)*
+ & (twall(i,j,1,lc0)*wc0+twall(i,j,1,lc1)*wc1
+ & +twall(i,j,1,lc2)*wc2+twall(i,j,1,lc3)*wc3)
+ else !synoptic observed sst
+ util1(i,j)=scp2(i,j)*
+ & (seatmp(i,j,l0)*w0+seatmp(i,j,l1)*w1
+ & +seatmp(i,j,l2)*w2+seatmp(i,j,l3)*w3)
+ endif
+ if (relaxf) then !sss
+ util2(i,j)=scp2(i,j)*
+ & (swall(i,j,1,lc0)*wc0+swall(i,j,1,lc1)*wc1
+ & +swall(i,j,1,lc2)*wc2+swall(i,j,1,lc3)*wc3)
+ else !synoptic observed surface temperature
+ util1(i,j)=scp2(i,j)*
+ & (surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1
+ & +surtmp(i,j,l2)*w2+surtmp(i,j,l3)*w3)
+ endif
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsmt, util1,ip)
+ call xcsum(dsms, util2,ip)
+ smt=dsmt/area
+ sms=dsms/area
+ if (mnproc.eq.1) then
+ if (relaxf) then
+ write (lp,'(i9,a,
+ & '' mean clim thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' sss:'',f7.3)')
+ & nstep,c_ydh,
+ & thkmin,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean clim thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' sss:'',f7.3)')
+ & nstep,c_ydh,
+ & thkmin,smt,sms
+ call flush(nod)
+ else !.not.relaxf
+ write (lp,'(i9,a,
+ & '' mean clim thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' surt:'',f7.3)')
+ & nstep,c_ydh,
+ & thkmin,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean clim thk. (m):'',f8.2,
+ & '' sst:'',f7.3,
+ & '' surt:'',f7.3)')
+ & nstep,c_ydh,
+ & thkmin,smt,sms
+ call flush(nod)
+ endif !relaxf:else
+ endif !1st tile
+ endif
+c
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(ubavg(1-nbdy,1-nbdy, n),1, 1, 1,1, halo_uv)
+ call xctilr(vbavg(1-nbdy,1-nbdy, n),1, 1, 1,1, halo_vv)
+c
+ dsuma=0.0d0
+ dsmta=0.0d0
+ dsmsa=0.0d0
+ dsmra=0.0d0
+ dskea=0.0d0
+ do k=1,kk
+!$OMP PARALLEL DO PRIVATE(j,l,i,utotp,vtotp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ utotp=0.5*( u(i, j,k,n)+ubavg(i, j,n) +
+ & u(i+1,j,k,n)+ubavg(i+1,j,n) )
+ vtotp=0.5*( v(i,j, k,n)+vbavg(i,j, n) +
+ & v(i,j+1,k,n)+vbavg(i,j+1,n) )
+ util1(i,j)=dp(i,j,k,n)*scp2(i,j)
+ util2(i,j)=dp(i,j,k,n)*scp2(i,j)*temp(i,j,k,n)
+ util3(i,j)=dp(i,j,k,n)*scp2(i,j)*saln(i,j,k,n)
+ util5(i,j)=dp(i,j,k,n)*scp2(i,j)*th3d(i,j,k,n)
+ util4(i,j)=dp(i,j,k,n)*scp2(i,j)*
+ & 0.5*(1000.0+th3d(i,j,k,n)+thbase)*
+ & (utotp**2+vtotp**2)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(dsum, util1,ip)
+ call xcsum(dsmt, util2,ip)
+ call xcsum(dsms, util3,ip)
+ call xcsum(dsmr, util5,ip)
+ call xcsum(dske, util4,ip)
+ dsuma=dsuma+dsum
+ dsmta=dsmta+dsmt
+ dsmsa=dsmsa+dsms
+ dsmra=dsmra+dsmr
+ dskea=dskea+dske
+ if (dsum.ne.0.0d0) then
+ sum=dsum/(area*onem)
+ smt=dsmt/dsum
+ sms=dsms/dsum
+ else
+ sum=0.0
+ smt=0.0
+ sms=0.0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' mean L '',i2,'' thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' saln:'',f7.3)')
+ & nstep,c_ydh,
+ & k,sum,smt,sms
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' mean L '',i2,'' thk. (m):'',f8.2,
+ & '' temp:'',f7.3,
+ & '' saln:'',f7.3)')
+ & nstep,c_ydh,
+ & k,sum,smt,sms
+ call flush(nod)
+ endif !1st tile
+ enddo !k
+ sum=dskea/(area*onem)
+ smt=dsmta/dsuma
+ sms=dsmsa/dsuma
+ smr=dsmra/dsuma
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' region-wide mean Kin. Energy:'',f20.10)')
+ & nstep,c_ydh,
+ & sum
+ write (lp,'(i9,a,
+ & '' region-wide mean Temperature:'',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ write (lp,'(i9,a,
+ & '' region-wide mean Salinity: '',f20.10)')
+ & nstep,c_ydh,
+ & sms
+ write (lp,'(i9,a,
+ & '' region-wide mean Density Dev:'',f20.10)')
+ & nstep,c_ydh,
+ & smr
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' region-wide mean Kin. Energy:'',f20.10)')
+ & nstep,c_ydh,
+ & sum
+ write(nod,'(i9,a,
+ & '' region-wide mean Temperature:'',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ write(nod,'(i9,a,
+ & '' region-wide mean Salinity: '',f20.10)')
+ & nstep,c_ydh,
+ & sms
+ write(nod,'(i9,a,
+ & '' region-wide mean Density Dev:'',f20.10)')
+ & nstep,c_ydh,
+ & smr
+ call flush(nod)
+ endif !1st tile
+c
+ do ktr= 1,ntracr
+ dsumtr(ktr)=0.0d0
+ do k=1,kk
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util2(i,j)=dp(i,j,k,n)*scp2(i,j)*tracer(i,j,k,n,ktr)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ call xcsum(dsmt, util2,ip)
+ dsumtr(ktr)=dsumtr(ktr)+dsmt
+ enddo !k
+ smt=dsumtr(ktr)/dsuma !dsuma still good from K.E. loops
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' region-wide mean tracer'',i3.2,
+ & '': '',f20.10)')
+ & nstep,c_ydh,
+ & ktr,smt
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' region-wide mean tracer'',i3.2,
+ & '': '',f20.10)')
+ & nstep,c_ydh,
+ & ktr,smt
+ call flush(nod)
+ endif !1st tile
+c --- NaN detection, for each tracer.
+ if (hycom_isnaninf(smt)) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error - NaN or Inf detected'
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ lfatal = .true. !delay exit to allow archive output
+ endif !NaN
+ if (ktr.ge.3 .and. trcflg(ktr-2).eq.903) then !NPZ
+ smt=(dsumtr(ktr)+dsumtr(ktr-1)+dsumtr(ktr-2))/dsuma
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' region-wide mean N+P+Z: '',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' region-wide mean N+P+Z: '',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ call flush(nod)
+ endif !1st tile
+ elseif (ktr.ge.4 .and. trcflg(ktr-3).eq.904) then !NPZD
+ smt=(dsumtr(ktr) +dsumtr(ktr-1)+
+ & dsumtr(ktr-2)+dsumtr(ktr-3))/dsuma
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,
+ & '' region-wide mean N+P+Z+D: '',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ call flush(lp)
+ write(nod,'(i9,a,
+ & '' region-wide mean N+P+Z+D: '',f20.10)')
+ & nstep,c_ydh,
+ & smt
+ call flush(nod)
+ endif !1st tile
+ endif !NPZ:NPZD
+ enddo !ktr
+ endif !diagno ...
+c
+c --- diagnose meridional overturning and heat flux
+ if (mod(dtime+dsmall,dmonth).lt.dsmall2) then
+ call xctmr0(52)
+ call overtn(dtime,dyear)
+ call xctmr1(52)
+ elseif (nstep.ge.nstep2) then
+ call xctmr0(52)
+ call overtn(dtime,dyear)
+ call xctmr1(52)
+ endif
+c
+ if (meanfq.ne.0.0) then
+ if (.not. histmn) then
+ if (tidflg.gt.0 .and. abs(meanfq-1.0).lt.0.02) then
+ if (mod(dtime+dsmall,hours1).lt.dsmall2) then
+ call mean_add(n, 1.0) !25-hour average daily
+ endif
+ else
+ call mean_add(n, 1.0)
+ endif
+ else ! histmn
+ if (tidflg.gt.0 .and. abs(meanfq-1.0).lt.0.02) then
+ call mean_add(n, 1.0) !25-hour average daily
+ else
+ call mean_add(n, 0.5)
+ endif
+c
+ call xctmr0(53)
+c
+c --- output to mean archive file
+c
+ call mean_end(dtime)
+#if defined(USE_CCSM3)
+ jday = days_in_prior_months(imonth)+iday
+#else
+ call forday(time_ave,yrflag, iyear,jday,ihour)
+#endif
+ call mean_archiv(n, iyear,jday,ihour)
+c
+ call mean_zero(dtime)
+ call mean_add(n, 0.5)
+c
+ call xctmr1(53)
+ endif ! histmn
+ endif !meanfq
+c
+ if (histry .or. hitile .or. hisurf .or. lfatal) then
+ call xctmr0(53)
+c
+c --- output to archive file
+c
+#if defined(USE_CCSM3)
+ jday = days_in_prior_months(imonth)+iday
+#else
+ call forday(dtime,yrflag, iyear,jday,ihour)
+#endif
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ if (isopyc .or. mxlkrt) then
+ do l=1,isu(j)
+ do i=max(1,ifu(j,l)),min(ii,ilu(j,l))
+ umix(i,j)=u(i,j,1,n)
+ enddo
+ enddo
+ do l=1,isv(j)
+ do i=max(1,ifv(j,l)),min(ii,ilv(j,l))
+ vmix(i,j)=v(i,j,1,n)
+ enddo
+ enddo
+ endif
+ if (histry) then
+ do k= 1,kk
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+c --- convert diapycnal thickness changes into
+c --- actual interface fluxes
+ if (k.gt.1) then
+ diaflx(i,j,k)=diaflx(i,j,k)/(2.*onem) +
+ & diaflx(i,j,k-1)
+ else
+ diaflx(i,j,k)=diaflx(i,j,k)/(2.*onem)
+ endif
+ enddo
+ enddo
+ enddo !k
+ endif
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lfatal) then !write archive and exit
+ if (mnproc.eq.1) then
+ write (intvl,'(i3.3)') 0
+ endif !1st tile
+ call archiv(n, kk, iyear,jday,ihour, intvl)
+ call xcstop('(hycom)')
+ stop '(hycom)' !won't get here
+ else
+ if (mnproc.eq.1) then
+ write (intvl,'(i3.3)') int(dtime-timav+dsmall)
+ endif !1st tile
+ if (hisurf .and. .not. histry) then
+ call archiv(n, 1, iyear,jday,ihour, intvl)
+ elseif (histry) then
+ call archiv(n, kk, iyear,jday,ihour, intvl)
+ endif !hisurf:histry
+ if (hitile) then
+ call archiv_tile(n, kk, iyear,jday,ihour, intvl)
+ endif
+ endif !lfatal:else
+c
+ if (histry) then
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do k= 1,kk
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ diaflx(i,j,k)=0.0
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ timav=time
+ endif
+ call xctmr1(53)
+ endif ! histry.or.hitile.or.hisurf.or.lfatal
+c
+#if defined(USE_ESMF)
+ if (put_export) then
+c
+c --- fill the ESMF Export State.
+c
+ call Export_ESMF
+ call forday(dtime,yrflag, iyear,jday,ihour)
+ call Archive_ESMF(iyear,jday,ihour)
+ endif
+#endif
+c
+ if (restrt) then
+ call xctmr0(51)
+c
+c --- output to restart and flux statitics files
+c
+ if (mxlkpp) then
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ dpmixl(i,j,m) = dpmixl(i,j,n)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ endif
+c
+#if defined(USE_CCSM3)
+ call ccsm3_time_date_stamp (ccsm3_string, 'ymds')
+
+ flnmra = trim(flnmrsod)// '.'//trim(ccsm3_string)
+ flnmrb = trim(flnmrsod)//'h.'//trim(ccsm3_string)
+
+ if (mnproc == 1) then
+ open(1,file=trim(pointer_filename),form='formatted',
+ & status='unknown')
+ write(1,'(a)')trim(flnmra)
+ write(1,'(a)')trim(flnmrb)
+ write(1,*)time ! real, in days
+ write(1,*)dtime ! real8, in days
+ write(1,*)nstep,iyear,imonth,iday ! integer
+ &, elapsed_days
+ write(1,*)eom, eoy ! logical
+ close(1)
+c
+ write(lp,'(2a)')'RESTART: (mainloop) to file: ',trim(flnmra)
+ write(lp,*) ' time = ',time
+ write(lp,*) ' nstep,iyear,imonth,iday : ',
+ & nstep,iyear,imonth,iday
+ call flush(lp)
+ endif !mnproc == 1
+#else
+ call forday(dtime,yrflag, iyear,jday,ihour)
+ if (mnproc.eq.1) then
+ write (lp,'(a,i9, 9x,a,i6.4, 9x,a,i5.3, 9x,a,i4.2)')
+ & ' time step',nstep,
+ & 'y e a r', iyear,
+ & 'd a y', jday,
+ & 'h o u r', ihour
+ call flush(lp)
+ endif !1st tile
+c
+ flnmra = flnmrso !.a extension added by restart_out
+ flnmrb = flnmrso !.b extension added by restart_out
+#endif
+c
+ call restart_out(nstep,dtime, flnmra,flnmrb, nstep.ge.nstep2)
+c
+c --- set layer thickness (incl.bottom pressure) at u,v points
+c --- needed because restart_out may have modified dp
+c
+ call xctilr(dp(1-nbdy,1-nbdy,1,1),1,2*kk, nbdy,nbdy, halo_ps)
+ call xctilr(dpmixl(1-nbdy,1-nbdy,1),1,2, nbdy,nbdy, halo_ps)
+c
+ margin = nbdy
+c
+ do nm=1,2
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (nm.eq.mod(nstep+1,2)+1) then
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpbl(i,j)=dpmixl(i,j,nm)
+ enddo
+ endif
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,1)=0.0
+ do k=1,kk
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,nm)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,nm),
+ & dpv(1-nbdy,1-nbdy,1,nm),
+ & p,depthu,depthv, max(0,margin-1))
+c
+ enddo !nm=1,2
+c
+ call xctmr1(51)
+ endif ! restrt
+c
+ if (histry .or. hitile .or. hisurf .or. restrt) then
+ if (mnproc.eq.1) then
+ write (lp,'(a,i9,a,f9.2,a)')
+ & ' step',nstep,' day',dtime,' -- archiving completed --'
+ call flush(lp)
+ endif !1st tile
+ endif
+c
+c --- read next incremental update.
+c
+ if (incflg.ne.0) then
+ call incupd_rd(dtime)
+ endif
+c
+ delt1=baclin+baclin
+c
+#if ! defined(USE_CCSM3)
+ end_of_run = nstep.ge.nstep2
+#endif
+c
+c --- at end: output float restart file
+c
+ if (synflt .and. end_of_run) then
+ call floats_restart
+ endif !synflt+end_of_run
+
+ end subroutine HYCOM_Run
+
+#if defined(USE_ESMF)
+ subroutine HYCOM_Final
+ & (gridComp, impState, expState, extClock, rc)
+c
+c --- Calling parameters
+ type(ESMF_GridComp) :: gridComp
+ type(ESMF_State) :: impState
+ type(ESMF_State) :: expState
+ type(ESMF_Clock) :: extClock
+ integer :: rc
+c
+c --- Report
+ call ESMF_LogWrite("HYCOM finalize routine called", ESMF_LOG_INFO)
+!-----call ESMF_LogFlush
+c
+c --- Destroy internal ocean clock
+* call ESMF_ClockDestroy(intClock, rc=rc)
+c
+c --- print active timers.
+ call xctmrp
+c
+ if (mnproc .eq. 1) then
+ write(nod,'(a)') 'normal stop'
+ call flush(nod)
+ endif
+c
+ end subroutine HYCOM_Final
+#else
+ subroutine HYCOM_Final
+c
+c --- end of the run.
+ if (mnproc.eq.1) then
+ write(nod,'(a)') 'normal stop'
+ call flush(nod)
+ endif !1st tile
+#if defined(USE_CCSM3)
+c
+c --- print active timers.
+ call xctmrp
+c
+ call shr_timer_print ( timer_send_to_cpl )
+ call shr_timer_print ( timer_recv_from_cpl)
+ call shr_timer_print ( timer_recv_to_send )
+ call shr_timer_print ( timer_send_to_recv )
+c
+ call ccsm3_exit_HYCOM('hycom normal stop',normal_exit=.true.)
+ stop '(hycom normal stop)' !won't get here
+#else
+ call xcstop('(normal)') !calls xctmrp
+ stop '(normal)' !won't get here
+#endif
+
+ end subroutine HYCOM_Final
+#endif /* USE_ESMF:else */
+
+ end module mod_hycom
+c
+c
+c> Revision history:
+c>
+c> May 1997 - removed statement "theta(1)=-thbase" after loop 14
+c> June 1997 - added loop 60 to fix bug in vertical summation of -diaflx-
+c> Oct. 1999 - option for krt or kpp mixed layer model - convec and diapfl
+c> not called for kpp mixing model
+c> Oct. 1999 - dpbl (boundary layer thickness) is output in addition to
+c> dpmixl when the kpp mixing model is selected
+c> May 2000 - conversion to SI units
+c> Aug. 2000 - added isopycnic (MICOM) vertical coordinate option
+c> Oct. 2000 - added option for high frequency atmospheric forcing
+c> Nov. 2000 - archive time stamp is either time step or YYYY_DDD_HH
+c> Aug. 2002 - added support for multiple tracers
+c> Nov. 2002 - more basin-wide surface flux statistics
+c> Dec. 2003 - more basin-wide mean statistics
+c> Mar. 2005 - more accurate ice statistics
+c> Jan. 2006 - mod_hycom with HYCOM_Init, HYCOM_Run, HYCOM_Final
+c> Nov. 2006 - version 2.2
+c> Nov. 2006 - added incremental update (for data assimilation)
+c> Mar. 2007 - added srfhgt
diff --git a/src_2.2.18_3_one/mod_incupd.F b/src_2.2.18_3_one/mod_incupd.F
new file mode 100755
index 0000000..3851027
--- /dev/null
+++ b/src_2.2.18_3_one/mod_incupd.F
@@ -0,0 +1,732 @@
+ module mod_incupd
+ use mod_xc ! HYCOM communication interface
+c
+ implicit none
+c
+c --- HYCOM incremental updating (for data assimilation)
+c
+ integer, save, public ::
+ & incflg, ! incremental update flag (0=no, 1=yes, 2=full-velocity)
+ & incstp, ! no. timesteps for full update (1=full insertion)
+ & incupf ! number of days of incremental updating input
+c
+ integer, save, private ::
+ & ncount, ! increment time step counter
+ & ncountd ! increment day counter
+c
+ real*8, save, private ::
+ & dtimeu ! next days increment field
+c
+ real, allocatable, dimension(:,:),
+ & save, private ::
+ & ubinc, ! ubaro increment
+ & vbinc ! vbaro increment
+
+c
+ real, allocatable, dimension(:,:,:),
+ & save, private ::
+ & tinc, ! t increment
+ & thinc, ! th increment
+ & dpinc, ! dp increment
+ & uinc, ! u increment
+ & vinc ! v increment
+
+ contains
+
+ subroutine incupd_init(dtime0)
+c
+ real*8 dtime0
+c
+c --- subroutine used to calculate increment field for the incremental updating
+c --- version: dec 2005
+c
+ integer i,j,l,k
+ logical lopen
+c
+c --- allocate arrays
+c
+ allocate( tinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & thinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & dpinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & uinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & vinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm),
+ & ubinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & vbinc(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+c
+c --- set counter to zero
+c
+ ncount=0
+ ncountd=0
+ dtimeu=1.d-6
+c
+c --- read the target fields, and initialize the "inc" arrays.
+c
+ call incupd_read(dtime0)
+c
+ return
+ end subroutine incupd_init
+
+ subroutine incupd_rd(dtime0)
+c
+ real*8 dtime0
+c
+c --- subroutine used to calculate increment field for the incremental updating
+c --- version: dec 2005
+c
+ integer i,j,l,k
+ logical lopen
+c
+ if (ncountd.gt.incupf) then
+ if (mnproc.eq.1) then
+ write(lp,*) '... ended updating fields with increments ...'
+ write(lp,*) 'ncountd= ',ncountd
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ endif
+c
+c --- read the target fields, and initialize the "inc" arrays.
+c
+ call incupd_read(dtime0)
+c
+ return
+ end subroutine incupd_rd
+
+ subroutine incupd(n)
+c
+ include 'common_blocks.h'
+C
+ integer n
+c
+c**********
+c*
+c 1) update hycom variables with increments.
+c
+c 2) parameters:
+c
+c output:
+c incremental updated model variables
+c
+c 4) Ole Martin Smedstad (PSI), December 2005
+c
+c**********
+c
+ real zero,one
+ parameter (zero=0.0, one=1.0)
+c
+ integer i,j,k,l
+ real utotij,vtotij
+c
+ include 'stmt_fns.h'
+c
+c --- update counter
+c
+ if (incstp.ne.1) then
+ ncount=ncount+1
+ endif
+c
+ margin=0
+c
+ if (ncount.gt.incstp) then
+ if (ncount.eq.incstp+1) then
+ if (mnproc.eq.1) then
+ write(lp,*) '... ended updating fields with increments ...'
+ write(lp,*) 'ncount= ',ncount
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+ endif !ncount==incstp+1
+ return
+ endif !ncount>incstp
+
+ if (ncountd.gt.incupf) then
+ if (mnproc.eq.1) then
+ write(lp,*) '... ended updating fields with increments ...'
+ write(lp,*) 'ncountd= ',ncountd
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ endif
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ if (incflg.eq.1) then
+ write(lp,'(2a)') 'update fields with increments, ',
+ & 'but not ubavg and vbavg'
+ else !incflg.eq.2
+ write(lp,'(2a)') 'update fields with increments, ',
+ & 'including ubavg and vbavg'
+ endif !incflg
+ write(lp,*) 'ncount= ',ncount
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+c --- incremental update of dp (dpu, dpv).
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk-1
+ dp(i,j,k,n) = dp(i,j,k,n) + dpinc(i,j,k)
+ p(i,j,k+1) = min( p(i,j,k) + dp(i,j,k,n),
+ & p(i,j,kk+1) ) !min may be unnecessary
+ enddo !k
+c --- dp must be non-negative.
+ do k=1,kk-1
+ p(i,j,k+1) = max( p(i,j,k+1), p(i,j,k) )
+ dp(i,j,k,n) = p(i,j,k+1) - p(i,j,k)
+ enddo ! k
+c --- layer kk always touches the bottom
+ dp(i,j,kk,n) = p(i,j,kk+1) - p(i,j,kk)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, 0)
+c
+c --- incremental update of the other fields.
+c --- salinity from updated th&S.
+c --- rebalance u and v via utotij and vtotij.
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,utotij,vtotij)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ if ( tinc(i,j,k).ne.0.0 .or.
+ & thinc(i,j,k).ne.0.0 ) then
+ temp(i,j,k,n) = temp(i,j,k,n) + tinc(i,j,k)
+ th3d(i,j,k,n) = th3d(i,j,k,n) + thinc(i,j,k)
+ saln(i,j,k,n) = sofsig(th3d(i,j,k,n)+thbase,
+ & temp(i,j,k,n) )
+ endif !non-zero increment
+ enddo ! k
+ enddo !i
+ enddo !l
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ utotij = 0.0
+ do k=1,kk
+ u(i,j,k,n) = u(i,j,k,n) + uinc(i,j,k)
+ utotij = utotij + u(i,j,k,n)*dpu(i,j,k,n)
+ enddo ! k
+ utotij=utotij/depthu(i,j)
+ do k=1,kk
+ u(i,j,k,n) = u(i,j,k,n) - utotij
+ enddo ! k
+ if (incflg.eq.2) then !update ubavg
+ ubavg(i,j,n) = ubavg(i,j,n) + ubinc(i,j)
+* ubavg(i,j,n) = ubavg(i,j,n) + ubinc(i,j) + utotij
+ endif !incflg==2
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vtotij = 0.0
+ do k=1,kk
+ v(i,j,k,n) = v(i,j,k,n) + vinc(i,j,k)
+ vtotij = vtotij + v(i,j,k,n)*dpv(i,j,k,n)
+ enddo ! k
+ vtotij=vtotij/depthv(i,j)
+ do k=1,kk
+ v(i,j,k,n) = v(i,j,k,n) - vtotij
+ enddo ! k
+ if (incflg.eq.2) then !update vbavg
+ vbavg(i,j,n) = vbavg(i,j,n) + vbinc(i,j)
+* vbavg(i,j,n) = vbavg(i,j,n) + vbinc(i,j) + vtotij
+ endif !incflg==2
+ enddo !i
+ enddo !l
+ enddo ! j
+!$OMP END PARALLEL DO
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'finished incupdate',ncount
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ return
+ end subroutine incupd
+
+ subroutine incupd_read(dtime)
+ use mod_za ! HYCOM I/O interface
+c
+ real*8 dtime
+c
+ include 'common_blocks.h'
+c
+c --- input 3-d HYCOM fields (from an archive file) on model day dtime.
+c --- directly insert the input covice and thkice (if they exist).
+c --- calculate the increment between the input and the initial state.
+c
+c --- filenames incup/incupd.iyear_iday_ihour.[ab].
+c --- I/O and array I/O unit 925 used here, but not reserved.
+c
+ logical ldebug_incupd_read
+ parameter (ldebug_incupd_read=.false.)
+c
+ character flnm*24, cline*80, cvarin*6, cfield*8
+ integer i,idmtst,ios,j,jdmtst,k,l,layer,nskip
+ integer iyear,iday,ihour
+ logical nodens
+ real tincstp
+* real sumdp1,sumdp2,sumdpinc
+c
+ integer nstep0
+ real*8 dtime0
+c
+ include 'stmt_fns.h'
+c
+ call forday(dtime, yrflag, iyear,iday,ihour)
+c
+ write(flnm,'("incup/incupd.",i4.4,"_",i3.3,"_",i2.2)')
+ & iyear,iday,ihour
+c
+ if(dtime.ge.dtimeu) then
+c
+ ncountd=ncountd+1
+ ncount=0
+c
+ if (ncountd.gt.incupf) then
+ if (mnproc.eq.1) then
+ write(lp,*) '... ended updating fields with increments ...'
+ write(lp,*) 'ncountd= ',ncountd
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+ return
+ endif
+c
+ if (mnproc.eq.1) then
+ write(lp,*) 'read incremental updating ...'
+ write(lp,*) 'ncountd ...',ncountd
+ write (lp,*) 'incupd_read: ',flnm
+ write (lp,*) ' time: ',dtime
+ write (lp,*) 'iyear,iday,ihour: ',iyear,iday,ihour
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ call zaiopf(flnm//'.a','old', 925)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ open (unit=uoff+925,file=flnm//'.b',form='formatted',
+ & status='old',action='read')
+c
+ read(uoff+925,'(a)') cline
+ read(uoff+925,'(a)') cline
+ read(uoff+925,'(a)') cline
+ read(uoff+925,'(a)') cline
+c
+ read(uoff+925,'(a)') cline
+ read(uoff+925,'(a)') cline
+ read(uoff+925,'(a)') cline
+ endif !1st tile
+c
+ call zagetc(cline,ios, uoff+925)
+ read(cline,*) idmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',idmtst
+* endif !1st tile
+ if (cvarin.ne.'idm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in incupd_read - input ',cvarin,
+ & ' but should be idm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+ call zagetc(cline,ios, uoff+925)
+ read(cline,*) jdmtst,cvarin
+* if (mnproc.eq.1) then
+* write(lp,*) cvarin,' = ',jdmtst
+* endif !1st tile
+ if (cvarin.ne.'jdm ') then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in incupd_read - input ',cvarin,
+ & ' but should be jdm '
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+c
+ if (idmtst.ne.itdm .or. jdmtst.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in incupd_read - input idm,jdm',
+ & ' not consistent with parameters'
+ write(lp,*) 'idm,jdm = ',itdm, jtdm, ' (dimensions.h)'
+ write(lp,*) 'idm,jdm = ',idmtst,jdmtst,' (input)'
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+c
+c --- skip (most) surface fields.
+c
+ call zaiosk(925)
+ call zagetc(cline,ios, uoff+925)
+ i = index(cline,'=')
+ read(cline(i+1:),*) nstep0,dtime0,layer
+ if (mnproc.eq.1) then
+ write(lp,*) 'dtime0= ',dtime0
+ endif
+ if (dtime0.ne.dtime) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in incupd_read - input ',dtime0,
+ & ' but dtime should be ',dtime
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+ nodens = layer.ne.0 !new or original archive type
+ if (nodens .and. layer.ne.sigver) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error in incupd_read - input ',layer,
+ & ' sigver but should be ',sigver
+ write(lp,*)
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+c
+c assumes that there is a new incremental updating file once a day
+c for "incupf" days, see blkdat.input
+c
+ dtimeu=dtime0+1.d0
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'dtime, dtime0, dtimeu = ',dtime,
+ & dtime0, dtimeu
+ write(lp,*)
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ if (nodens) then
+ do i= 2,6
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+ call zaiosk(925)
+ enddo
+ else
+ do i= 2,11
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+ call zaiosk(925)
+ enddo
+ endif
+c
+ call rd_archive(ubinc, cfield,layer, 925) !u_btrop or covice or mix_dpth
+ if (cfield.eq.'mix_dpth') then
+c --- archive contains 'steric '
+ call rd_archive(ubinc, cfield,layer, 925) !u_btrop or covice
+ endif
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "surface: ",cfield
+ endif
+ call xcsync(flush_lp)
+ if (cfield.eq.'covice ') then
+c
+c --- directly insert covice and thkice.
+c
+ call rd_archive(util5, cfield,layer, 925) !thkice
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "surface: ",cfield
+ endif
+ call xcsync(flush_lp)
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ covice(i,j)=ubinc(i,j)
+ thkice(i,j)=util5(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ call zaiosk(925) !temice
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+ call rd_archive(ubinc, cfield,layer, 925)
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "surface: ",cfield
+ endif
+ call xcsync(flush_lp)
+ endif
+ call rd_archive(vbinc, cfield,layer, 925)
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "surface: ",cfield
+ endif
+ call xcsync(flush_lp)
+c
+ if (mnproc.eq.1) then
+ write (lp,*) 'start 3-D archive file read'
+ endif
+ call xcsync(flush_lp)
+c
+c --- 3-d fields.
+c
+ nskip = 0
+ do k=1,kk
+ call rd_archive(uinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'u-vel. ' .and. k.ne.2) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','u-vel. '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ elseif (cfield.ne.'u-vel. ') then !k==2
+c
+c --- count "tracer" fields (to be skipped)
+c
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "counting tracers: ",cfield
+ endif
+ do nskip= 2,99
+ call rd_archive(uinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (mnproc.eq.1) then
+ write(lp,'(2a)') "counting tracers: ",cfield
+ endif
+ if (cfield.eq.'u-vel. ') then
+ exit
+ endif
+ enddo !nskip
+ nskip = nskip - 1
+ write(lp,'(a,i3)') "nskip =",nskip
+ endif
+ call rd_archive(vinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'v-vel. ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','v-vel. '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+c if (mnproc.eq.1) then
+c write (lp,*) 'read v-vel archive file'
+c endif
+ call rd_archive(dpinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'thknss ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','thknss '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+c if (mnproc.eq.1) then
+c write (lp,*) 'read dpinc archive file'
+c endif
+ call rd_archive(tinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'temp ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','temp '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+ if (nodens) then
+c --- read salinity into thinc, later convert it to density
+ call rd_archive(thinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'salin ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','salin '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+ else
+c --- skip salinity, and read density
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+ call zaiosk(925)
+ call rd_archive(thinc(1-nbdy,1-nbdy,k), cfield,layer, 925)
+ if (cfield.ne.'density ') then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') cfield,
+ & 'error in incupd_read - expected ','density '
+ endif !1st tile
+ call xcstop('(incupd_read)')
+ stop '(incupd_read)'
+ endif
+ endif !nodens:else
+c
+c --- skip (nskip) tracers
+c
+ do l= 1,nskip
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ read (uoff+925,*)
+ endif
+ call zaiosk(925)
+ enddo !l
+ enddo !k
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close( unit=uoff+925)
+ endif
+ call zaiocl(925)
+c
+c --- calculate increments
+c --- the "inc" reads, above, are full HYCOM fields (not increments yet).
+c
+ if(incstp.eq.1) then
+ tincstp=1.0
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'tincstp=1.0 ',tincstp,incstp
+ endif
+ else
+ tincstp=2.0/real(incstp)
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'tincstp=2.0/incstp ',tincstp,incstp
+ endif
+ endif !incstp
+c
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'calculate t,s,u,v and dp increments'
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+* if (iutest.gt.0 .and. jutest.gt.0) then
+* write(lp,*) '*',' iutest= ',iutest+i0,' jutest= ',jutest+j0,' *'
+* write(lp,*) '*********** dpinc input ************'
+* sumdp1=0.0
+* sumdp2=0.0
+* sumdpinc=0.0
+* write(lp,'(a)')
+* & 'k,dp1,dp2,dpinc='
+* do k= 1,kk
+* sumdp1=sumdp1+dp(iutest,jutest,k,1)
+* sumdp2=sumdp2+dp(iutest,jutest,k,2)
+* sumdpinc=sumdpinc+dpinc(iutest,jutest,k)
+* write(lp,'(a,i3,3f20.5)')
+* & 'k= ',
+* & k,dp(iutest,jutest,k,1)*qonem,
+* & dp(iutest,jutest,k,2)*qonem,
+* & dpinc(iutest,jutest,k)*qonem
+* call flush(lp)
+* enddo !k
+* write(lp,*) 'sumdp1,sumdp2= ', sumdp1*qonem,sumdp2*qonem
+* write(lp,*) 'sumdpinc= ', sumdpinc*qonem
+* call flush(lp)
+* endif
+c
+ margin=0
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ ubinc(i,j)=(ubinc(i,j) - ubavg(i,j,1))*tincstp
+ do k=1,kk
+c use an approximate 2*dpu
+ if (dpinc(i,j,k)+dpinc(i-1,j,k).gt.2.0*onem) then
+ uinc(i,j,k)=(uinc(i,j,k) - u(i,j,k,1))*tincstp
+ else
+ uinc(i,j,k)=0.0 !thin target layer
+ endif
+ enddo !k
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vbinc(i,j)=(vbinc(i,j) - vbavg(i,j,1))*tincstp
+ do k=1,kk
+c use an approximate 2*dpv
+ if (dpinc(i,j,k)+dpinc(i,j-1,k).gt.2.0*onem) then
+ vinc(i,j,k)=(vinc(i,j,k) - v(i,j,k,1))*tincstp
+ else
+ vinc(i,j,k)=0.0 !thin target layer
+ endif
+ enddo !k
+ enddo !i
+ enddo !l
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ do k=1,kk
+ if (dpinc(i,j,k).gt.onem) then
+ if (nodens) then
+ thinc(i,j,k)=sig(tinc(i,j,k),thinc(i,j,k))-thbase
+ endif
+ thinc(i,j,k)=(thinc(i,j,k) - th3d(i,j,k,1))*tincstp
+ tinc(i,j,k)= (tinc(i,j,k) - temp(i,j,k,1))*tincstp
+ else
+ tinc(i,j,k)=0.0 !thin target layer
+ thinc(i,j,k)=0.0 !thin target layer
+ endif
+ dpinc(i,j,k)=(dpinc(i,j,k) - dp(i,j,k,1))*tincstp
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+* if (iutest.gt.0 .and. jutest.gt.0) then
+* write(lp,*) '*',' iutest= ',iutest+i0,' jutest= ',jutest+j0,' *'
+* write(lp,*) '*********** dpinc out ************'
+* write(lp,'(a)')
+* & 'k,dp1,dp2,dpinc='
+* sumdpinc=0.0
+* do k= 1,kk
+* sumdpinc=sumdpinc+dpinc(iutest,jutest,k)
+* write(lp,'(a,i3,3f20.5)')
+* & 'k= ',
+* & k,dp(iutest,jutest,k,1)*qonem,
+* & dp(iutest,jutest,k,2)*qonem,
+* & dpinc(iutest,jutest,k)*qonem
+* call flush(lp)
+* enddo !k
+* write(lp,*) 'inc sumdpinc= ', sumdpinc*qonem
+* call flush(lp)
+* endif
+c
+ if (mnproc.eq.1) then
+ write(lp,*) '... finnished reading incupd',dtime,dtime0
+ endif !1st tile
+ call xcsync(flush_lp)
+c
+ endif ! dtime
+c
+ return
+ end subroutine incupd_read
+c
+ end module mod_incupd
+c
+c
+c> Revision history:
+c>
+c> Feb 2006 - 1st module version
+c> May 2006 - changed to read multiple increment files
diff --git a/src_2.2.18_3_one/mod_mean.F b/src_2.2.18_3_one/mod_mean.F
new file mode 100755
index 0000000..f1d09f8
--- /dev/null
+++ b/src_2.2.18_3_one/mod_mean.F
@@ -0,0 +1,671 @@
+ module mod_mean
+ use mod_xc ! HYCOM communication interface
+c
+ implicit none
+c
+c --- HYCOM time means
+c
+ real, save, public ::
+ & time_min, !start of averaging interval, set by mean_zero
+ & time_ave, !middle of averaging interval, set by mean_end
+ & time_max !end of averaging interval, set by mean_end
+c
+ integer, save, private ::
+ & nmean ! mean sum counter
+ real, save, private ::
+ & snmean ! mean sum counter
+c
+ real, allocatable, dimension(:,:,:,:),
+ & save, private ::
+ & tracer_m
+c
+ real, allocatable, dimension(:,:,:),
+ & save, private ::
+ & u_m,v_m,ke_m,temp_m,saln_m,th3d_m,dp_m
+c
+ real, allocatable, dimension(:,:),
+ & save, private ::
+ & ubaro_m,vbaro_m,kebaro_m,
+ & montg_m,srfht_m,steric_m,dpbl_m,dpmixl_m,
+ & surflx_m,salflx_m, covice_m,thkice_m,temice_m
+
+ contains
+
+ subroutine mean_allocate
+c
+ include 'common_blocks.h'
+c
+c --- Allocate mean fields.
+c
+ if (ntracr.gt.0) then
+ allocate( tracer_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm,ntracr) )
+ endif
+c
+ allocate( u_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( v_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( ke_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( temp_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( saln_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( th3d_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+ allocate( dp_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,kdm) )
+c
+ allocate( ubaro_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( vbaro_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( kebaro_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( montg_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( steric_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ) !not always output
+ allocate( srfht_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( dpbl_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( dpmixl_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( surflx_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( salflx_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( covice_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( thkice_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ allocate( temice_m(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+c
+ return
+ end subroutine mean_allocate
+
+ subroutine mean_zero(time_now)
+c
+ real time_now
+c
+ include 'common_blocks.h'
+c
+c --- Zero all mean fields
+c
+ integer i,j,k,ktr,l
+c
+ snmean = 0.0
+ nmean = 0
+ time_min = time_now
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,ktr)
+ do j=1,jj
+ do i=1,ii
+ kebaro_m(i,j) = 0.0
+ montg_m(i,j) = 0.0
+ steric_m(i,j) = 0.0
+ srfht_m(i,j) = 0.0
+ dpbl_m(i,j) = 0.0
+ dpmixl_m(i,j) = 0.0
+ surflx_m(i,j) = 0.0
+ salflx_m(i,j) = 0.0
+ covice_m(i,j) = 0.0
+ thkice_m(i,j) = 0.0
+ temice_m(i,j) = 0.0
+ ubaro_m(i,j) = 0.0
+ vbaro_m(i,j) = 0.0
+ enddo !i
+ do k= 1,kk
+ do i=1,ii
+ dp_m(i,j,k) = 0.0
+ temp_m(i,j,k) = 0.0
+ saln_m(i,j,k) = 0.0
+ th3d_m(i,j,k) = 0.0
+ ke_m(i,j,k) = 0.0
+ u_m(i,j,k) = 0.0
+ v_m(i,j,k) = 0.0
+ do ktr= 1,ntracr
+ tracer_m(i,j,k,ktr) = 0.0
+ enddo !ktr
+ enddo !i
+ enddo !k
+ enddo !j
+c
+ return
+ end subroutine mean_zero
+
+ subroutine mean_add(n, s)
+c
+ include 'common_blocks.h'
+c
+ integer n
+ real s
+c
+c --- Add to mean fields
+c --- s is 1.0 or 0.5
+c
+ integer i,j,k,ktr,l
+ real q,ke
+c
+ snmean = snmean + s
+ nmean = nmean + 1
+c
+c --- assume dp,dpu,dpv are up to date
+c --- halos only needed for kinetic energy
+c
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(ubavg( 1-nbdy,1-nbdy, n),1, 1, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(vbavg( 1-nbdy,1-nbdy, n),1, 1, 1,1, halo_vv)
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,ktr,q,ke)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=ifp(j,l),ilp(j,l)
+ ke = 0.5*((0.5*(ubavg(i, j,n) +
+ & ubavg(i+1,j,n) ))**2 +
+ & (0.5*(vbavg(i,j, n) +
+ & vbavg(i,j+1,n) ))**2 )
+ kebaro_m(i,j) = kebaro_m(i,j) + s*ke
+ montg_m(i,j) = montg_m(i,j) + s*montg1(i,j)
+ steric_m(i,j) = steric_m(i,j) + s*steric(i,j)
+ srfht_m(i,j) = srfht_m(i,j) + s*srfhgt(i,j)
+ dpbl_m(i,j) = dpbl_m(i,j) + s* dpbl(i,j)
+ dpmixl_m(i,j) = dpmixl_m(i,j) + s*dpmixl(i,j,n)
+ surflx_m(i,j) = surflx_m(i,j) + s*surflx(i,j)
+ salflx_m(i,j) = salflx_m(i,j) + s*salflx(i,j)
+ covice_m(i,j) = covice_m(i,j) + s*covice(i,j)
+ thkice_m(i,j) = thkice_m(i,j) + s*thkice(i,j)
+ temice_m(i,j) = temice_m(i,j) + s*temice(i,j)
+ enddo !i
+ enddo !l
+ do l=1,isu(j)
+ do i=ifu(j,l),ilu(j,l)
+ ubaro_m(i,j) = ubaro_m(i,j) + s*ubavg(i,j,n)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=ifv(j,l),ilv(j,l)
+ vbaro_m(i,j) = vbaro_m(i,j) + s*vbavg(i,j,n)
+ enddo !i
+ enddo !l
+ do k= 1,kk
+ do l=1,isp(j)
+ do i=ifp(j,l),ilp(j,l)
+ ke = 0.5*((0.5*(u(i, j,k,n) + ubavg(i, j,n) +
+ & u(i+1,j,k,n) + ubavg(i+1,j,n) ))**2 +
+ & (0.5*(v(i,j ,k,n) + vbavg(i,j, n) +
+ & v(i,j+1,k,n) + vbavg(i,j+1,n) ))**2 )
+c
+ q = s*dp(i,j,k,n)
+ dp_m(i,j,k) = dp_m(i,j,k) + q
+ temp_m(i,j,k) = temp_m(i,j,k) + temp(i,j,k,n) * q
+ saln_m(i,j,k) = saln_m(i,j,k) + saln(i,j,k,n) * q
+ th3d_m(i,j,k) = th3d_m(i,j,k) + th3d(i,j,k,n) * q
+ ke_m(i,j,k) = ke_m(i,j,k) + ke * q
+ do ktr= 1,ntracr
+ tracer_m(i,j,k,ktr) = tracer_m(i,j,k, ktr) +
+ & tracer(i,j,k,n,ktr) * q
+ enddo !ktr
+ enddo !i
+ enddo !l
+ do l=1,isu(j)
+ do i=ifu(j,l),ilu(j,l)
+ q = s*dpu(i,j,k,n)
+ u_m(i,j,k) = u_m(i,j,k) + q*(u(i,j,k,n) + ubavg(i,j,n))
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=ifv(j,l),ilv(j,l)
+ q = s*dpv(i,j,k,n)
+ v_m(i,j,k) = v_m(i,j,k) + q*(v(i,j,k,n) + vbavg(i,j,n))
+ enddo !i
+ enddo !l
+ enddo !k
+ enddo !j
+c
+ return
+ end subroutine mean_add
+
+ subroutine mean_end(time_now)
+c
+ real time_now
+c
+ include 'common_blocks.h'
+c
+c --- Reduce sums to their mean.
+c
+ integer i,j,k,ktr,l
+ real dpthin,q,qdp,time_int
+c
+ q = 1.0/snmean
+ time_max = time_now
+ time_ave = 0.5*(time_min + time_max)
+ if (nint(snmean).ne.nmean) then
+c --- 1st and last sample scaled by 1/2.
+ nmean = nint(snmean)
+ time_int = (time_max - time_min)*q
+ time_min = time_min + 0.5*time_int
+ time_max = time_max - 0.5*time_int
+ endif
+c
+ dpthin = 0.001*onemm
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,qdp)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=ifp(j,l),ilp(j,l)
+ p(i,j,1) = 0.0
+ do k= 1,kk
+ p(i,j,k+1) = p(i,j,k) + q*dp_m(i,j,k)
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+c
+ call xctilr(p(1-nbdy,1-nbdy,2),1,kk, 1,1, halo_ps)
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,qdp)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=ifp(j,l),ilp(j,l)
+ kebaro_m(i,j) = kebaro_m(i,j) * q
+ montg_m(i,j) = montg_m(i,j) * q
+ steric_m(i,j) = steric_m(i,j) * q
+ srfht_m(i,j) = srfht_m(i,j) * q
+ dpbl_m(i,j) = dpbl_m(i,j) * q
+ dpmixl_m(i,j) = dpmixl_m(i,j) * q
+ surflx_m(i,j) = surflx_m(i,j) * q
+ salflx_m(i,j) = salflx_m(i,j) * q
+ covice_m(i,j) = covice_m(i,j) * q
+ thkice_m(i,j) = thkice_m(i,j) * q
+ temice_m(i,j) = temice_m(i,j) * q
+ enddo !i
+ enddo !l
+ do l=1,isu(j)
+ do i=ifu(j,l),ilu(j,l)
+ ubaro_m(i,j) = ubaro_m(i,j) * q
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=ifv(j,l),ilv(j,l)
+ vbaro_m(i,j) = vbaro_m(i,j) * q
+ enddo !i
+ enddo !l
+ do k= 1,kk
+ do l=1,isp(j)
+ do i=ifp(j,l),ilp(j,l)
+ dp_m(i,j,k) = dp_m(i,j,k) * q
+ if (dp_m(i,j,k).ge.dpthin) then
+ qdp = q/dp_m(i,j,k)
+ temp_m(i,j,k) = temp_m(i,j,k) * qdp
+ saln_m(i,j,k) = saln_m(i,j,k) * qdp
+ th3d_m(i,j,k) = th3d_m(i,j,k) * qdp
+ ke_m(i,j,k) = ke_m(i,j,k) * qdp
+ do ktr= 1,ntracr
+ tracer_m(i,j,k,ktr) = tracer_m(i,j,k, ktr) * qdp
+ enddo !ktr
+ else !project into zero thickness layers
+ temp_m(i,j,k) = temp_m(i,j,k-1)
+ saln_m(i,j,k) = saln_m(i,j,k-1)
+ th3d_m(i,j,k) = th3d_m(i,j,k-1)
+ ke_m(i,j,k) = ke_m(i,j,k-1)
+ do ktr= 1,ntracr
+ tracer_m(i,j,k,ktr) = tracer_m(i,j,k-1,ktr)
+ enddo !ktr
+ endif
+ enddo !i
+ enddo !l
+ do l=1,isu(j)
+ do i=ifu(j,l),ilu(j,l)
+ qdp = min(depthu(i,j), 0.5*(p(i,j,k+1)+p(i-1,j,k+1))) -
+ & min(depthu(i,j), 0.5*(p(i,j,k )+p(i-1,j,k )))
+ if (qdp.ge.dpthin) then
+ qdp = q/qdp
+ u_m(i,j,k) = u_m(i,j,k) * qdp
+ else
+ u_m(i,j,k) = u_m(i,j,k-1)
+ endif
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=ifv(j,l),ilv(j,l)
+ qdp = min(depthv(i,j), 0.5*(p(i,j,k+1)+p(i,j-1,k+1))) -
+ & min(depthv(i,j), 0.5*(p(i,j,k )+p(i,j-1,k )))
+ if (qdp.ge.dpthin) then
+ qdp = q/qdp
+ v_m(i,j,k) = v_m(i,j,k) * qdp
+ else
+ v_m(i,j,k) = v_m(i,j,k-1)
+ endif
+ enddo !i
+ enddo !l
+ enddo !k
+ enddo !j
+c
+ return
+ end subroutine mean_end
+
+ subroutine mean_archiv(n, iyear,iday,ihour)
+ use mod_za ! HYCOM I/O interface
+c
+ integer n, iyear,iday,ihour
+c
+ include 'common_blocks.h'
+c
+c --- write a mean archive file.
+c
+ character*80 cformat
+ integer i,j,k,ktr,l,ldot,nop,nopa
+ real coord,xmin,xmax,sstc,sssc
+c
+ ldot = index(flnmarcm,'.',back=.true.)
+ if (ldot.eq.0) then
+ if (mnproc.eq.1) then
+ write (lp,*) 'need decimal point in flnmarcm'
+ write (lp,*) 'flnmarcm = ',trim(flnmarcm)
+ endif
+ call xcstop('(flnmarcm)')
+ stop '(flnmarcm)'
+ endif
+ ldot = min(ldot,len(flnmarcm)-11) !need 11 characters for archive date
+c
+c --- indicate the archive date
+ write(flnmarcm(ldot+1:ldot+11),'(i4.4,a1,i3.3,a1,i2.2)')
+ & iyear,'_',iday,'_',ihour
+ ldot=ldot+11
+ nopa=13
+ nop =13+uoff
+c
+c --- no .[ab] files for 1-D cases (<=6x6).
+c
+ if (max(itdm,jtdm).gt.6) then !not 1-D output
+c
+ call zaiopf(flnmarcm(1:ldot)//'.a', 'new', nopa)
+ if (mnproc.eq.1) then
+ open (unit=nop,file=flnmarcm(1:ldot)//'.b',status='new') !uoff+13
+ write(nop,116) ctitle,iversn,iexpt,yrflag,itdm,jtdm
+ call flush(nop)
+ endif !1st tile
+ 116 format (a80/a80/a80/a80/
+ & i5,4x,'''iversn'' = hycom version number x10'/
+ & i5,4x,'''iexpt '' = experiment number x10'/
+ & i5,4x,'''yrflag'' = days in year flag'/
+ & i5,4x,'''idm '' = longitudinal array size'/
+ & i5,4x,'''jdm '' = latitudinal array size'/
+ & 'field time step mean day',
+ & ' k dens min max')
+c
+c --- surface fields
+c
+ coord=0.
+c
+ call zaiowr(montg_m,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'montg1 ',nmean,time_min,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(srfht_m,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'srfhgt ',nmean,time_max,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ if (sshflg.ne.0) then
+c --- write out steric SSH.
+ call zaiowr(steric_m,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'steric ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ endif !sshflg
+c
+ call zaiowr(surflx_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'surflx ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(salflx_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'salflx ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+c
+ call zaiowr(dpbl_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'bl_dpth ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(dpmixl_m,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'mix_dpth',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(temp_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'tmix ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(saln_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'smix ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(th3d_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'thmix ',nmean,time_ave,0,thbase,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(u_m,iu,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'umix ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(v_m,iv,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'vmix ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(ke_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'kemix ',nmean,time_ave,0,thbase,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ if (iceflg.ne.0) then
+ call zaiowr(covice_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'covice ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(thkice_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'thkice ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(temice_m,ip,.true., xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'temice ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ endif !write ice fields
+c
+c --- depth averaged fields
+c
+ call zaiowr(ubaro_m,iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'u_btrop ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(vbaro_m,iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'v_btrop ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(kebaro_m,ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'kebtrop ',nmean,time_ave,0,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+c
+c --- layer loop.
+c
+ do 75 k=1,kk
+ coord=sigma(k)
+ call zaiowr(u_m(1-nbdy,1-nbdy,k),iu,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'u-vel. ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(v_m(1-nbdy,1-nbdy,k),iv,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'v-vel. ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(ke_m(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'k.e. ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(dp_m(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'thknss ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(temp_m(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'temp ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(saln_m(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'salin ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ call zaiowr(th3d_m(1-nbdy,1-nbdy,k),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'density ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ do ktr= 1,ntracr
+ call zaiowr(tracer_m(1-nbdy,1-nbdy,k,ktr),ip,.true.,
+ & xmin,xmax, nopa, .false.)
+ if (mnproc.eq.1) then
+ write (nop,117) 'tracer ',nmean,time_ave,k,coord,xmin,xmax
+ call flush(nop)
+ endif !1st tile
+ enddo !ktr
+ 75 continue
+c
+ 117 format (a8,' =',i11,f11.3,i3,f7.3,1p2e16.7)
+c
+ close (unit=nop)
+ call zaiocl(nopa)
+c
+ call xcsync(no_flush)
+c
+ endif !not 1-D
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ if (relaxf .and. sstflg.le.1) then
+ sstc = twall(itest,jtest,1,lc0)*wc0+
+ & twall(itest,jtest,1,lc1)*wc1+
+ & twall(itest,jtest,1,lc2)*wc2+
+ & twall(itest,jtest,1,lc3)*wc3
+ else !synoptic observed sst
+ sstc = seatmp(itest,jtest,l0)*w0+
+ & seatmp(itest,jtest,l1)*w1+
+ & seatmp(itest,jtest,l2)*w2+
+ & seatmp(itest,jtest,l3)*w3
+ endif
+ sssc = swall(itest,jtest,1,lc0)*wc0+
+ & swall(itest,jtest,1,lc1)*wc1+
+ & swall(itest,jtest,1,lc2)*wc2+
+ & swall(itest,jtest,1,lc3)*wc3
+ open (unit=nop,file=flnmarcm(1:ldot)//'.txt',status='new') !uoff+13
+ write (nop,'(3a / a,6i7,2f8.1,i7,i7.4,i7.3,i7.2)')
+ & '## expt idm jdm kdm',
+ & ' itest jtest lontst lattst',
+ & ' yrflag year day hr',
+ & '##',iexpt, itdm, jtdm, kdm,
+ & ittest,jttest,
+ & mod(plon(itest,jtest),360.0),plat(itest,jtest),
+ & yrflag, iyear, iday, ihour
+ write (nop,'(7a / a,f10.3, f8.2,4f8.1, 2f9.2,2f8.4,
+ & f9.5,4f9.3, 2f8.3, 3f8.3, 4f8.2)')
+ & '## model-day',
+ & ' srfhgt sswflx mixflx surflx sstflx',
+ & ' E-P sssE-P bhtflx buoflx',
+ & ' ustar hekman dpbbl dpbl dpmixl',
+ & ' tclim sclim',
+ & ' tmix smix thmix umix vmix',
+ & ' ubavg vbavg',
+ & '#',time_ave, !model-day
+ & srfht_m(itest,jtest)*100.0/g, !cm
+ & 0.0, !sswflx_m(itest,jtest), !W/m**2
+ & 0.0, !mixflx_m(itest,jtest), !W/m**2
+ & surflx_m(itest,jtest), !W/m**2
+ & 0.0, !sstflx_m(itest,jtest), !W/m**2
+ & salflx_m(itest,jtest)*thref*8.64E7/saln(itest,jtest,1,n),!mm/day
+ & 0.0, !sssflx_m(itest,jtest)*thref*8.64E7/saln(itest,jtest,1,n),!mm/day
+ & 0.0, !bhtflx(itest,jtest)*1.e6, !1.e6*m**2/sec**3
+ & 0.0, !buoflx(itest,jtest)*1.e6, !1.e6*m**2/sec**3
+ & 0.0, ! ustar(itest,jtest), !m/s?
+ & 0.0, !min(hekman(itest,jtest), 9999.999), !m
+ & 0.0, !min( dpbbl(itest,jtest)*qonem, 9999.999), !m
+ & min( dpbl_m(itest,jtest)*qonem, 9999.999), !m
+ & min(dpmixl_m(itest,jtest)*qonem, 9999.999), !m
+ & sstc, !degC
+ & sssc, !psu
+ & temp_m(itest,jtest,1), !degC
+ & saln_m(itest,jtest,1), !psu
+ & th3d_m(itest,jtest,1)+thbase, !SigmaT
+ & max(-999.99,min(999.99, u_m(itest,jtest,1)*100.0)), !cm/s
+ & max(-999.99,min(999.99, v_m(itest,jtest,1)*100.0)), !cm/s
+ & max(-999.99,min(999.99,ubaro_m(itest,jtest)*100.0)), !cm/s
+ & max(-999.99,min(999.99,vbaro_m(itest,jtest)*100.0)) !cm/s
+ if (iceflg.ne.0) then
+ write (nop,'(2a / a,f10.3, 3f8.2,2f8.1,f9.2)')
+ & '## model-day',
+ & ' covice thkice temice flxice fswice iceE-P',
+ & '#',time, !model-day
+ & covice_m(itest,jtest)*100.0, !%
+ & thkice_m(itest,jtest), !m
+ & temice_m(itest,jtest), !degC
+ & 0.0, !flxice_m(itest,jtest), !W/m**2
+ & 0.0, !fswice_m(itest,jtest), !W/m**2
+ & 0.0 !sflice_m(itest,jtest)*thref*8.64E7/saln_m(itest,jtest,1) !mm/day
+ endif !iceflg
+ if (ntracr.eq.0) then
+ write(cformat,'(a)')
+ & '(3a / (i4,2f8.2,3f8.3,f9.3,f10.3,2f8.2))'
+ else
+ write(cformat,'(a,i2,a,i2,a)')
+ & '(3a,', ntracr,
+ & 'a / (i4,2f8.2,3f8.3,f9.3,f10.3,2f8.2,', ntracr,
+ & 'f8.3))'
+ endif
+ write (nop,cformat)
+ & '# k',
+ & ' utot vtot temp saln dens',
+ & ' thkns dpth viscty t-diff',
+ & (' tracer',ktr=1,ntracr),
+ & (k,
+ & max(-999.99,min(999.99,u_m(itest,jtest,k)*100.0)), !cm/s
+ & max(-999.99,min(999.99,v_m(itest,jtest,k)*100.0)), !cm/s
+ & temp_m(itest,jtest,k), !degC
+ & saln_m(itest,jtest,k), !psu
+ & th3d_m(itest,jtest,k)+thbase, !SigmaT
+ & dp_m(itest,jtest,k)*qonem, !m
+ & (p(itest,jtest,k+1)+p(itest,jtest,k))*0.5*qonem, !m
+ & 0.0, !vcty(itest,jtest,k+1)*1.e4, !m**2/s*2
+ & 0.0, !dift(itest,jtest,k+1)*1.e4, !m**2/s*2
+ & (tracer_m(itest,jtest,k,ktr),ktr=1,ntracr), !0-999?
+ & k=1,kk)
+ close (unit=nop)
+ endif !test point tile
+c
+ call xcsync(no_flush)
+ return
+ end subroutine mean_archiv
+
+ end module mod_mean
+c
+c
+c> Revision history:
+c>
+c> Apr 2007 - 1st version
diff --git a/src_2.2.18_3_one/mod_pipe.F b/src_2.2.18_3_one/mod_pipe.F
new file mode 100755
index 0000000..d09282f
--- /dev/null
+++ b/src_2.2.18_3_one/mod_pipe.F
@@ -0,0 +1,1079 @@
+ module mod_pipe
+ use mod_xc ! HYCOM communication interface
+c
+c --- HYCOM (named pipe based) debugging interface
+c
+ logical, save, public :: lpipe
+c
+ integer, save, private :: ipunit,lpunit,ishift,jshift,nsym
+ logical, save, private :: ldebug,ldebugssh,
+ & lmaster,lpipeio,lshift,lslave,
+ & lsym,ltracer
+c
+ real, allocatable, dimension(:,:),
+ & save, private :: field1,field2,tmask,vmask,amask
+
+ contains
+c
+c --- this set of routines facilitates output comparison from two HYCOM
+c --- versions running side by side. one model, the 'slave', writes its
+c --- output into a named pipe. the other model, the 'master', reads
+c --- from the pipe and compares.
+c --- differences are recorded in 'PIPE_base.out'.
+c
+c --- call 'pipe_init' at start of main program.
+c
+c --- if the file 'PIPE_MASTER' exists then this is the master,
+c --- if the file 'PIPE_SLAVE' exists then this is the slave,
+c --- if the file 'PIPE_SYM' exists then this is master and slave,
+c --- if the file 'PIPE_TRACER' exists then this is master and slave,
+c --- otherwise there is no comparison made.
+c
+c --- if the file 'PIPE_SHIFT' exists for the slave, then it
+c --- is a single-line plain text file containing two integers
+c --- specifiying how much to periodically shift the slave arrays
+c --- before sending them to the master. it is an error for
+c --- 'PIPE_SHIFT' to exist (a) on the master and (b) when not
+c --- making a comparison.
+c
+c --- if the file 'PIPE_SYM' exists, there is no slave and the
+c --- master compares its own fields for various symmetries.
+c --- it is a single-line plain text file containing an integer
+c --- specifiying what kind of symmetries to test for (0=constant,
+c --- 1=transpose, 2=constant-in-j, -2=arctic, 4=4-way, 8=8-way).
+c --- it is an error for 'PIPE_SYM' to exist when making a
+c --- master/slave comparison.
+c
+c --- if the file 'PIPE_TRACER' exists, there is no slave and the
+c --- master checks that all appropriate tracers are non-negative
+c --- and compares temperature to any "temperature" tracer.
+c
+c --- if the file 'PIPE_DEBUG' exists then debugging printout
+c --- is produced for point itest,jtest (>0, see blkdat.f).
+c --- if itest=-1 the min/max/iospycnal of th3d are printed.
+c --- if jtest=-1 the basin-wide means are printed.
+c --- this works with or without a pipe for comparison.
+c
+c --- if the file 'PIPE_DEBUG_SSH' exists then debugging printout
+c --- is produced for SSH at point itest,jtest.
+c --- this works with or without a pipe for comparison.
+c
+c --- the 'PIPE_MASTER' and 'PIPE_SLAVE' files contain the location
+c --- of an existing named-pipe. the 'PIPE_SHIFT' file contains the
+c --- periodic shift to apply on the slave. the 'PIPE_SYM' file
+c --- contains the kind of symmetries to test for. the contents of
+c --- the 'PIPE_DEBUG' and 'PIPE_DEBUG_SSH' files are ignored.
+c
+c --- call 'pipe_compare' (from master and slave) anywhere in the code
+c --- to check whether data stored in a single array are identical
+c
+c --- call 'pipe_compare_sym1' anywhere in the code to check whether
+c --- data stored in a single p-grid array are symmetrical.
+c --- note that this can be used in place of 'pipe_compare', since
+c --- it will call the latter in master/slave mode.
+c
+c --- call 'pipe_compare_sym2' anywhere in the code to check whether
+c --- data stored in vector u and v grid arrays are symmetrical.
+c --- note that this can be used in place of 'pipe_compare', since
+c --- it will call the latter twice (for u and v) in master/slave mode.
+c
+c --- call 'pipe_comparall' (from master and slave) after major routines
+c --- to check whether data stored in all major arrays are identical or
+c --- symmetric.
+c
+ subroutine pipe_init
+ implicit none
+c
+ character*256 cpipe
+c
+ character*12 cinfo
+ integer irecl
+c
+ inquire(file='PIPE_MASTER', exist=lmaster)
+ inquire(file='PIPE_SLAVE', exist=lslave)
+ inquire(file='PIPE_SHIFT', exist=lshift)
+ inquire(file='PIPE_SYM', exist=lsym)
+ inquire(file='PIPE_TRACER', exist=ltracer)
+ inquire(file='PIPE_DEBUG', exist=ldebug)
+ inquire(file='PIPE_DEBUG_SSH', exist=ldebugssh)
+c
+ if (lmaster .and. lslave) then
+ call xchalt('pipe_init: (master/slave ambiguity)')
+ stop 'pipe_init: (master/slave ambiguity)'
+ endif
+ if (lsym .and. (lmaster .or. lslave)) then
+ call xchalt('pipe_init: (sym/master/slave ambiguity)')
+ stop 'pipe_init: (sym/master/slave ambiguity)'
+ endif
+ lpipe = lmaster .or. lslave .or. lsym
+ lpipeio = lmaster .or. lslave
+ if (lshift .and. .not.lslave) then
+ call xchalt('pipe_init: (shift ambiguity)')
+ stop 'pipe_init: (shift ambiguity)'
+ endif
+c
+ if (lpipe .or. ltracer) then
+c
+c --- allocate arrays for comparison
+c
+ allocate( field1(itdm,jtdm) )
+ allocate( field2(itdm,jtdm) )
+ if (.not.lslave) then
+ allocate( tmask( itdm,jtdm) )
+ allocate( amask( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ endif
+ if (lsym) then
+ allocate( vmask( itdm,jtdm) )
+ endif
+ endif ! pipe
+c
+ if (lpipeio) then
+c
+c --- open the pipe and some output files
+c
+ ipunit=18
+ lpunit=19
+c
+ if (mnproc.eq.1) then
+ if (lmaster) then
+ open (unit=17,file='PIPE_MASTER',status='old',
+ & form='formatted')
+ read ( 17,'(a)') cpipe
+ close(unit=17)
+ write(lp,'(a,a)') 'master opening pipe for reading: ',
+ & cpipe(1:len_trim(cpipe))
+ call flush(lp)
+#if defined(ALPHA)
+c --- work-around a compiler bug by skipping irecl
+ open (unit=ipunit,file=cpipe,status='old',
+ & action='read',
+ & form='unformatted')
+#else
+ cinfo=' ' !removes spurious compiler warning message
+ inquire( iolength=irecl ) cinfo,field1
+ open (unit=ipunit,file=cpipe,status='old',
+ & action='read',recl=irecl,
+ & form='unformatted')
+#endif
+ open (unit=lpunit,file='PIPE_base.out',status='unknown')
+ else ! slave
+ open (unit=17,file='PIPE_SLAVE', status='old',
+ & form='formatted')
+ read ( 17,'(a)') cpipe
+ close(unit=17)
+ write(lp,'(a,a)') 'slave opening pipe for writing: ',
+ & cpipe(1:len_trim(cpipe))
+ call flush(lp)
+#if defined(ALPHA)
+c --- work-around a compiler bug by skipping irecl
+ open (unit=ipunit,file=cpipe,status='old',
+ & action='write',
+ & form='unformatted')
+#else
+ cinfo=' ' !removes spurious compiler warning message
+ inquire( iolength=irecl ) cinfo,field1
+ open (unit=ipunit,file=cpipe,status='old',
+ & action='write',recl=irecl,
+ & form='unformatted')
+#endif
+ open (unit=lpunit,file='PIPE_test.out',status='unknown')
+c
+ if (lshift) then
+ open (unit=17,file='PIPE_SHIFT', status='old',
+ & form='formatted')
+ read ( 17,*) ishift,jshift
+ close(unit=17)
+ write(lp,'(a,2i5)') 'slave periodic shift is:',
+ & ishift,jshift
+ call flush(lp)
+ endif ! shift
+ endif ! master/slave
+ endif !1st tile only.
+ call xcsync(flush_lp)
+ endif ! pipeio
+c
+ if (lsym) then
+ open (unit=17,file='PIPE_SYM', status='old',
+ & form='formatted')
+ read ( 17,*) nsym
+ close(unit=17)
+ if (mnproc.eq.1) then
+ lpunit=19
+ open (unit=lpunit,file='PIPE_base.out',status='unknown')
+ write(lpunit,'(a,i2)') 'symmetry type is:',nsym
+ write(lp, '(a,i2)') 'symmetry type is:',nsym
+ call flush(lpunit)
+ endif
+ if (nsym.ne. 0 .and.
+ & nsym.ne. 1 .and.
+ & nsym.ne. 2 .and.
+ & nsym.ne.-2 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(a)') 'symmetry type is not supported'
+ endif
+ call xcstop('(pipe_init)')
+ stop '(pipe_init)'
+ endif
+ call xcsync(flush_lp)
+ endif ! sym
+c
+ return
+ end subroutine pipe_init
+c
+ subroutine pipe_compare(field,mask,what)
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: field
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+ character*12,
+ & intent(in) :: what
+c
+c --- call this routine from anywhere in the code (from both versions, of
+c --- course) to check whether data stored in 'field' are identical
+c
+ integer i,i1,j,j1
+ logical fail
+ character*12 which
+c
+ if (lpipeio) then
+ if (lmaster) then
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask(i,j)
+ enddo
+ enddo
+ call xcaget(tmask, amask, 1)
+ endif !master
+ call xcaget(field2, field, 1)
+c
+ if (mnproc.eq.1) then
+ if (lslave) then
+ if (.not.lshift) then
+ write (lpunit,'(2a)') 'writing for comparison: ',what
+ call flush(lpunit)
+ write (ipunit) what, field2
+ else ! shift slave array by ishift,jshift
+ do j=1,jtdm
+ j1 = mod( j-1+jshift+jtdm, jtdm ) + 1
+ do i=1,itdm
+ i1 = mod( i-1+ishift+itdm, itdm ) + 1
+ field1(i1,j1) = field2(i,j)
+ enddo
+ enddo
+ write (lpunit,'(2a)') 'writing for comparison: ',what
+ call flush(lpunit)
+ write (ipunit) what, field1
+ endif
+ else ! master
+ read (ipunit) which,field1
+ write (lpunit,'(2a)') 'reading for comparison: ',which
+ call flush(lpunit)
+ if (what.ne.which) then
+ write (lpunit,'(4a)') 'out of sync -- trying to compare ',
+ & what,' to ',which
+ call xchalt('(pipe_compare)')
+ stop '(pipe_compare)'
+ endif
+c
+ fail=.false.
+ do j=1,jtdm
+ do i=1,itdm
+ if (tmask(i,j).gt.0.0 .and.
+ & field2(i,j).ne.field1(i,j)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' master:',field2(i,j),
+ & ' error:', field2(i,j)-field1(i,j),what
+ fail=.true.
+ endif
+ enddo
+ enddo
+ if (fail) then ! optional
+ call xchalt('(pipe_compare)')
+ stop '(pipe_compare)'
+ endif
+ endif !slave:master
+ endif !1st tile
+ call xcsync(no_flush) ! wait for 1st tile
+ endif !lpipeio
+ return
+ end subroutine pipe_compare
+
+ subroutine pipe_compare_sym1(field,mask,what)
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: field
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+ character*12,
+ & intent(in) :: what
+c
+c --- call this routine from anywhere in the code
+c --- to check whether data stored in 'field' is symmetric.
+c
+c --- pass through to pipe_compare when in master/slave mode.
+c
+ integer i,io,j,jo
+ logical fail
+c
+ if (lpipeio) then
+ call pipe_compare(field,mask,what)
+ elseif (lsym) then
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask(i,j)
+ enddo
+ enddo
+ call xcaget(tmask, amask, 1)
+ call xcaget(field1, field, 1)
+ if (mnproc.eq.1) then
+ write (lpunit,'(2a)') 'comparing: ',what
+ call flush(lpunit)
+ fail=.false.
+ if (nsym.eq.-2) then !arctic
+ j = jtdm
+ jo = jtdm-1
+ do i=1,itdm
+ io = itdm-mod(i-1,itdm)
+ if (tmask(i,j).gt.0.0 .and.
+ & field1(i,j).ne.field1(io,jo)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(io,jo),what
+ fail=.true.
+ endif
+ enddo !i
+ else !standard symteries
+ do j=1,jtdm
+ do i=1,itdm
+ if (nsym.eq.0) then ! constant field
+ if (field1(i,j).ne.field1(1,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(1,1),what
+ fail=.true.
+ endif
+ elseif (nsym.eq.2) then ! constant field in j direction
+ if (field1(i,j).ne.field1(i,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(i,1),what
+ fail=.true.
+ endif
+ elseif (nsym.eq.1) then ! p=p.transpose
+ if (tmask(i,j).gt.0.0 .and.
+ & field1(i,j).ne.field1(j,i)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(j,i),what
+ fail=.true.
+ endif
+ endif
+ enddo !i
+ enddo !j
+ endif !nsym==-2:else
+ if (fail) then ! optional
+ call flush(lpunit)
+ call xchalt('(pipe_compare_sym1)')
+ stop '(pipe_compare_sym1)'
+ endif
+ endif !1st tile
+ call xcsync(no_flush) ! wait for 1st tile
+ endif !lpipeio:sym
+ return
+ end subroutine pipe_compare_sym1
+
+ subroutine pipe_compare_sym2(field_u,mask_u,what_u,
+ & field_v,mask_v,what_v)
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: field_u,field_v
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask_u,mask_v
+ character*12,
+ & intent(in) :: what_u,what_v
+c
+c --- call this routine from anywhere in the code
+c --- to check whether data stored in 'field_[uv]' is symmetric.
+c
+c --- pass through to pipe_compare when in master/slave mode.
+c
+ integer i,io,j,jo
+ logical fail
+c
+ if (lpipeio) then
+ call pipe_compare(field_u,mask_u,what_u)
+ call pipe_compare(field_v,mask_v,what_v)
+ elseif (lsym) then
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask_u(i,j)
+ enddo
+ enddo
+ call xcaget(tmask, amask, 1)
+ call xcaget(field1, field_u, 1)
+ call xcaget(field2, field_v, 1)
+ if (nsym.eq.-2) then !arctic
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask_v(i,j)
+ enddo
+ enddo
+ call xcaget(vmask, amask, 1)
+ endif
+ if (mnproc.eq.1) then
+ write (lpunit,'(4a)') 'comparing: ',what_u,' and ',what_v
+ call flush(lpunit)
+ fail=.false.
+ if (nsym.eq.-2) then !arctic
+ j = jtdm
+ jo = jtdm-1
+ do i=1,itdm
+ io = mod(itdm-(i-1),itdm)+1
+ if (tmask(i,j).gt.0.0 .and.
+ & field1(i,j).ne.-field1(io,jo)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)+field1(io,jo),what_u
+ fail=.true.
+ endif
+ enddo !i
+ j = jtdm
+ jo = jtdm
+ do i=1,itdm
+ io = itdm-mod(i-1,itdm)
+ if (vmask(i,j).gt.0.0 .and.
+ & field2(i,j).ne.-field2(io,jo)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field2(i,j),
+ & ' error:',field2(i,j)+field2(io,jo),what_v
+ fail=.true.
+ endif
+ enddo !i
+ else !standard symteries
+ do j=1,jtdm
+ do i=1,itdm
+ if (nsym.eq.0) then ! constant field
+ if (field1(i,j).ne.field1(1,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(1,1),what_u
+ fail=.true.
+ endif
+ if (field2(i,j).ne.field2(1,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field2(i,j),
+ & ' error:',field2(i,j)-field2(1,1),what_v
+ fail=.true.
+ endif
+ elseif (nsym.eq.2) then ! constant field in j direction
+ if (field1(i,j).ne.field1(i,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field1(i,1),what_u
+ fail=.true.
+ endif
+ if (field2(i,j).ne.field2(i,1)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field2(i,j),
+ & ' error:',field2(i,j)-field2(i,1),what_v
+ fail=.true.
+ endif
+ elseif (nsym.eq.1) then ! u==v.transpose
+ if (tmask(i,j).gt.0.0 .and.
+ & field1(i,j).ne.field2(j,i)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' uvel :',field1(i,j),
+ & ' error:',field1(i,j)-field2(j,i),what_u
+ fail=.true.
+ endif
+ endif
+ enddo !i
+ enddo !j
+ endif
+ if (fail) then ! optional
+ call xchalt('(pipe_compare_sym2)')
+ stop '(pipe_compare_sym2)'
+ endif
+ endif !1st tile
+ call xcsync(no_flush) ! wait for 1st tile
+ endif !lpipeio:sym
+ return
+ end subroutine pipe_compare_sym2
+
+ subroutine pipe_compare_same(fielda,fieldb,mask,what)
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: fielda,fieldb
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+ character*12,
+ & intent(in) :: what
+c
+c --- call this routine from anywhere in the code
+c --- to check whether data stored in 'fielda' and 'fieldb'
+c --- are identical.
+c
+c --- only active in PIPE_TRACER mode.
+c --- typically fielda is temp and fieldb is a "temperature" tracer.
+c
+ integer i,j
+ logical fail
+c
+ if (ltracer) then
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask(i,j)
+ enddo
+ enddo
+ call xcaget(tmask, amask, 1)
+ call xcaget(field1, fielda, 1)
+ call xcaget(field2, fieldb, 1)
+ if (mnproc.eq.1) then
+ write (lpunit,'(2a)') 'comparing: ',what
+ call flush(lpunit)
+ fail=.false.
+ do j=1,jtdm
+ do i=1,itdm
+ if (tmask(i,j).gt.0.0 .and.
+ & field1(i,j).ne.field2(i,j)) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j)-field2(i,j),what
+ fail=.true.
+ endif
+ enddo
+ enddo
+ if (fail) then ! optional
+ call xchalt('(pipe_compare_same)')
+ stop '(pipe_compare_same)'
+ endif
+ endif !1st tile
+ call xcsync(no_flush) ! wait for 1st tile
+ endif !ltracer
+ return
+ end subroutine pipe_compare_same
+
+ subroutine pipe_compare_notneg(field,mask,what)
+ implicit none
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: field
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+ character*12,
+ & intent(in) :: what
+c
+c --- call this routine from anywhere in the code
+c --- to check whether data stored in 'field' is non-negative.
+c
+c --- only active in PIPE_TRACER mode.
+c --- typically field is a tracer.
+c
+ integer i,j
+ logical fail
+c
+ if (ltracer) then
+ do j=1,jj
+ do i=1,ii
+ amask(i,j) = mask(i,j)
+ enddo
+ enddo
+ call xcaget(tmask, amask, 1)
+ call xcaget(field1, field, 1)
+ if (mnproc.eq.1) then
+ write (lpunit,'(2a)') 'comparing: ',what
+ call flush(lpunit)
+ fail=.false.
+ do j=1,jtdm
+ do i=1,itdm
+ if (tmask(i,j).gt.0.0) then
+ if (field1(i,j).lt.0.0) then
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j),what
+ fail=.true.
+ elseif (field1(i,j).ne.field1(i,j)) then !NaN
+ write (lpunit,'(a,2i5,1p,2(a,e12.5),4x,a)')
+ & 'i,j=',i,j,
+ & ' orig :',field1(i,j),
+ & ' error:',field1(i,j),what
+ fail=.true.
+ endif !errors
+ endif !tmask.gt.0
+ enddo
+ enddo
+ if (fail) then ! optional
+ call xchalt('(pipe_compare_notneg)')
+ stop '(pipe_compare_notneg)'
+ endif
+ endif !1st tile
+ call xcsync(no_flush) ! wait for 1st tile
+ endif !ltracer
+ return
+ end subroutine pipe_compare_notneg
+
+ subroutine pipe_comparall(m,n, cinfo)
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer, intent(in) :: m,n
+ character*12,
+ & intent(in) :: cinfo
+c
+c --- write out a standard menu of arrays for testing
+c
+ logical hycom_isnaninf !function to detect NaN and Inf
+c
+ character*99 cformat
+ character*12 txt1,txt2
+ integer i,imax,imin,j,jja,jmax,jmin,k,ktr,l,mnp
+ real diso,dmax,dmin,damax,damin
+ real*8 tmean,smean,pmean,rmean
+ real*8 d1,d2,d3,d4
+ real r1,r2,r3,r4
+c
+ real*8 tmean0,smean0,rmean0,
+ & tmean1,smean1,rmean1
+ save tmean0,smean0,rmean0,
+ & tmean1,smean1,rmean1
+ data tmean0,smean0,rmean0 / 3*0.0d0 /
+c
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,'(a,i10)') cinfo,nstep
+cdiag call flush(lp)
+cdiag endif
+c
+ if (ldebugssh) then
+c
+c --- printout SSH in cm at point itest,jtest.
+c
+ if (min(ittest,jttest).le.0) then
+ call xcstop('(pipe_comparall: debug_ssh ambiguity)')
+ stop '(pipe_comparall: debug_ssh ambiguity)'
+ endif
+ if (i0.lt.ittest .and. i0+ii.ge.ittest .and.
+ & j0.lt.jttest .and. j0+jj.ge.jttest ) then
+c ssh,montg,thref*pbavg (cm)
+ write (lp,"(i8,i5,i4,1x,a,a,3f15.8)")
+ & nstep,itest+i0,jtest+j0,cinfo(1:6),':',
+ & (100.0/g)*srfhgt(itest,jtest),
+ & (100.0/g)*montg1(itest,jtest),
+ & (100.0/g)*srfhgt(itest,jtest)-
+ & (100.0/g)*montg1(itest,jtest)
+ endif ! ittest,jttest tile
+ call xcsync(flush_lp)
+ endif !ldebugssh
+c
+ if (ldebug .and. ittest.ne.-1 .and. jttest.ne.-1) then
+c
+c --- printout at point itest,jtest.
+c
+ if (min(ittest,jttest).le.0) then
+ call xcstop('(pipe_comparall: debug ambiguity)')
+ stop '(pipe_comparall: debug ambiguity)'
+ endif
+ if (i0.lt.ittest .and. i0+ii.ge.ittest .and.
+ & j0.lt.jttest .and. j0+jj.ge.jttest ) then
+ if (ntracr.eq.0) then
+ write(cformat,'(a,a)')
+ & '(i8,i5,i4,1x,a,a/',
+ & '(i8,5x,i4,1x,a,a,2f7.3,2f7.3,f8.4,f9.3,f9.2))'
+ else
+ write(cformat,'(a,i2,a,a,i2,a)')
+ & '(i8,i5,i4,1x,a,a,',ntracr,'a / ',
+ & '(i8,5x,i4,1x,a,a,2f7.3,2f7.3,f8.4,f9.3,f9.2,',
+ & ntracr,'f8.4))'
+ endif
+* write(lp,'(3a)') '"',trim(cformat),'"'
+ if (.not.mxlkrt) then
+ write (lp,cformat)
+ & nstep,itest+i0,jtest+j0,cinfo(1:6),
+ & ': utot vtot temp saln dens thkns dpth',
+ & (' tracer',ktr=1,ntracr),
+ & (nstep,k, cinfo(1:6),':',
+ & u(itest,jtest,k,n)+ubavg(itest,jtest,n),
+ & v(itest,jtest,k,n)+vbavg(itest,jtest,n),
+ & temp(itest,jtest,k,n),
+ & saln(itest,jtest,k,n),
+ & th3d(itest,jtest,k,n)+thbase,
+ & dp(itest,jtest,k,n)/onem,
+ & p(itest,jtest,k+1)/onem,
+ & (tracer(itest,jtest,k,n,ktr),ktr=1,ntracr),
+ & k=1,kk)
+ else
+c --- include KT mixed layer values.
+ write (lp,cformat)
+ & nstep,itest+i0,jtest+j0,cinfo(1:6),
+ & ': utot vtot temp saln dens thkns dpth',
+ & (' tracer',ktr=1,ntracr),
+ & nstep,0, cinfo(1:6),':',
+ & 0.0,
+ & 0.0,
+ & tmix(itest,jtest),
+ & smix(itest,jtest),
+ & thmix(itest,jtest)+thbase,
+ & dpmixl(itest,jtest,n)/onem,
+ & dpmixl(itest,jtest,n)/onem,
+ & (0.0,ktr=1,ntracr),
+ & (nstep,k, cinfo(1:6),':',
+ & u(itest,jtest,k,n)+ubavg(itest,jtest,n),
+ & v(itest,jtest,k,n)+vbavg(itest,jtest,n),
+ & temp(itest,jtest,k,n),
+ & saln(itest,jtest,k,n),
+ & th3d(itest,jtest,k,n)+thbase,
+ & dp(itest,jtest,k,n)/onem,
+ & p(itest,jtest,k+1)/onem,
+ & (tracer(itest,jtest,k,n,ktr),ktr=1,ntracr),
+ & k=1,kk)
+ endif
+ if (mxlmy) then
+ write(cformat,'(a,a)')
+ & '(i8,i5,i4,1x,a,a/',
+ & '(i8,5x,i4,1x,a,a,g15.5,g15.5,f9.3,f9.2))'
+ write (lp,cformat)
+ & nstep,itest+i0,jtest+j0,cinfo(1:6),
+ & ': q2 q2l thkns dpth',
+ & (nstep,k, cinfo(1:6),':',
+ & q2(itest,jtest,k,n),
+ & q2l(itest,jtest,k,n),
+ & dp(itest,jtest,k,n)/onem,
+ & p(itest,jtest,k+1)/onem,
+ & k=1,kk)
+ endif !'mxlmy'
+ if (cinfo(1:6).eq.'mxkprf' .and. .not.mxlkrt) then
+ write(cformat,'(a,a)')
+ & '(i8,i5,i4,1x,a,a/',
+ & '(i8,5x,i4,1x,a,a,f7.3,f8.2,f7.3,f8.2,f9.3,f9.2))'
+ write (lp,cformat)
+ & nstep,itest+i0,jtest+j0,cinfo(1:6),
+ & ': temp t-diff saln s-diff thkns dpth',
+ & (nstep,k, cinfo(1:6),':',
+ & temp(itest,jtest,k,n),
+ & dift(itest,jtest,k+1)*1.e4,
+ & saln(itest,jtest,k,n),
+ & difs(itest,jtest,k+1)*1.e4,
+ & dp(itest,jtest,k,n)/onem,
+ & p(itest,jtest,k+1)/onem,
+ & k=1,klist(itest,jtest))
+ endif !'mxkprf'
+ endif ! ittest,jttest tile
+ call xcsync(flush_lp)
+ endif
+c
+ if (ldebug .and. ittest.eq.-1) then
+c
+c --- printout min/max/iospycnal th3d
+c
+ 104 format (i8,a3,1x,a,a)
+ 105 format (i8,i3,1x,a,a,2i5,f9.5,f7.3,f9.5,2i5,i7)
+ if (mnproc.eq.1) then
+ write(lp,104)
+ & nstep,' k',cinfo(1:6),
+ & ': imin jmin denamin deniso denamax imax jmax mnproc'
+ endif
+ call xcsync(flush_lp)
+ do k= 1,kk
+ diso=sigma(k)-thbase
+ dmin= huge
+ dmax=-huge
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+ if (th3d(i,j,k,n).lt.dmin) then
+ dmin=th3d(i,j,k,n)
+ imin=i
+ jmin=j
+ endif
+ if (th3d(i,j,k,n).gt.dmax) then
+ dmax=th3d(i,j,k,n)
+ imax=i
+ jmax=j
+ endif
+ endif
+ enddo
+ enddo
+ damin=dmin
+ call xcminr(damin)
+ damax=dmax
+ call xcmaxr(damax)
+ do mnp= 1,ijpr
+ if (mnp.eq.mnproc) then
+ if (dmin.eq.damin .or. dmax.eq.damax) then
+ write (lp,105)
+ & nstep,k,cinfo(1:6),
+ & ':',imin,jmin,dmin-diso,
+ & diso+thbase,
+ & dmax-diso,imax,jmax,mnproc
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo
+ enddo
+ call flush(lp)
+ endif
+c
+ if (ldebug .and. jttest.eq.-1) then
+c
+c --- printout basin-wide means.
+c
+#if defined(ARCTIC)
+c --- Arctic (tripole) domain, top row is replicated (ignore it)
+ jja = min( jj, jtdm-1-j0 )
+ if (jja.ne.jj) then
+ do i=1,ii
+ util5(i,jj)=0.0
+ util6(i,jj)=0.0
+ util3(i,jj)=0.0
+ util4(i,jj)=0.0
+ enddo
+ endif
+#else
+ jja = jj
+#endif
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jja
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util5(i,j)= dp(i,j,1,n)*scp2(i,j)
+ util6(i,j)=temp(i,j,1,n)*dp(i,j,1,n)*scp2(i,j)
+ util3(i,j)=saln(i,j,1,n)*dp(i,j,1,n)*scp2(i,j)
+ util4(i,j)=th3d(i,j,1,n)*dp(i,j,1,n)*scp2(i,j)
+ do k=2,kk
+ util5(i,j)=util5(i,j)+
+ & dp(i,j,k,n)*scp2(i,j)
+ util6(i,j)=util6(i,j)+
+ & temp(i,j,k,n)*dp(i,j,k,n)*scp2(i,j)
+ util3(i,j)=util3(i,j)+
+ & saln(i,j,k,n)*dp(i,j,k,n)*scp2(i,j)
+ util4(i,j)=util4(i,j)+
+ & th3d(i,j,k,n)*dp(i,j,k,n)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d1, util5,ip)
+ call xcsum(d2, util6,ip)
+ call xcsum(d3, util3,ip)
+ call xcsum(d4, util4,ip)
+ pmean=d1
+ tmean=d2/pmean
+ smean=d3/pmean
+ rmean=d4/pmean
+c
+ 106 format (i8,3x,1x,a,a,3f8.4,1p3e10.2)
+ if (mnproc.eq.1) then
+ write (lp,106)
+ & nstep,cinfo(1:6),
+ & ': t,s,th',
+ & tmean,smean,rmean+thbase,
+ & tmean-tmean0,smean-smean0,rmean-rmean0
+ call flush(lp)
+ endif
+c
+c --- NaN detection.
+ r1 = d1
+ r2 = d2
+ r3 = d3
+ r4 = d4
+ if (hycom_isnaninf(r1) .or.
+ & hycom_isnaninf(r2) .or.
+ & hycom_isnaninf(r3) .or.
+ & hycom_isnaninf(r4) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error - NaN or Inf detected'
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ endif !NaN
+!$OMP PARALLEL DO PRIVATE(j,i,k)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do i=1,ii
+ if (iu(i,j).eq.1) then
+ util5(i,j)=u(i,j,1,n)
+ do k=2,kk
+ util5(i,j)=util5(i,j)+u(i,j,k,n)
+ enddo
+ endif !iu
+ if (iv(i,j).eq.1) then
+ util6(i,j)=v(i,j,1,n)
+ do k=2,kk
+ util6(i,j)=util6(i,j)+v(i,j,k,n)
+ enddo
+ endif !iv
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d1, util5,iu)
+ call xcsum(d2, util6,iv)
+ r1 = d1
+ r2 = d2
+ if (hycom_isnaninf(r1) .or.
+ & hycom_isnaninf(r2) ) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) 'error - u or v NaN or Inf detected'
+ write(lp,*)
+ call flush(lp)
+ endif !1st tile
+ endif !NaN
+c
+ if (cinfo(1:6).eq.'ENTER ') then
+ tmean1=tmean
+ smean1=smean
+ rmean1=rmean
+ elseif (cinfo(1:6).eq.'tsadvc') then
+ if (mnproc.eq.1) then
+ write (lp,106)
+ & nstep,'cn+tsa',
+ & ': t,s,th',
+ & tmean,smean,rmean+thbase,
+ & tmean-tmean1,smean-smean1,rmean-rmean1
+ call flush(lp)
+ endif
+ elseif (cinfo(1:6).eq.'hybgen') then
+ if (mnproc.eq.1) then
+ write (lp,106)
+ & nstep,'EXIT ',
+ & ': t,s,th',
+ & tmean,smean,rmean+thbase,
+ & tmean-tmean1,smean-smean1,rmean-rmean1
+ call flush(lp)
+ endif
+ endif
+c
+ tmean0=tmean
+ smean0=smean
+ rmean0=rmean
+ endif
+c
+ if (ltracer .and. cinfo(1:1).ne.'i') then
+ do ktr= 1,ntracr
+ if (mnproc.eq.1) then
+ write (lpunit,'(a,i10)') cinfo,nstep
+ endif
+ call xcsync(flush_lp)
+ if (trcflg(ktr).eq.2) then
+c
+c --- compare temp and this temperature tracer.
+c
+ do k=1,kk
+ write (txt1,'(a9,i3)') 'temp(kn) ',k
+ call pipe_compare_same( temp(1-nbdy,1-nbdy,k,n),
+ & tracer(1-nbdy,1-nbdy,k,n,ktr),
+ $ ip,txt1)
+ enddo
+ else
+c
+c --- check that tracer is non-negative.
+c
+ do k=1,kk
+ write (txt1,'(a6,i3,i3)') 'tracer',ktr,k
+ call pipe_compare_notneg(tracer(1-nbdy,1-nbdy,k,n,ktr),
+ $ ip,txt1)
+ enddo
+ endif
+ enddo !ktr
+ if (mnproc.eq.1) then
+ write (lpunit,'(a,i10,a)') cinfo,nstep,' -- OK'
+ endif
+ call xcsync(flush_lp)
+ endif !ltracer
+c
+ if (lpipe) then
+c
+c --- pipe_compare_sym[12] works for both lsym and lpipeio.
+c
+ if (mnproc.eq.1) then
+ write (lpunit,'(a,i10)') cinfo,nstep
+ endif
+ call xcsync(flush_lp)
+ txt1='ubavg(n) '
+ txt2='vbavg(n) '
+ call pipe_compare_sym2(ubavg(1-nbdy,1-nbdy,n),iu,txt1,
+ & vbavg(1-nbdy,1-nbdy,n),iv,txt2)
+ txt1='pbavg(n) '
+ call pipe_compare_sym1(pbavg(1-nbdy,1-nbdy,n),ip,txt1)
+ txt1='montg(1) '
+ call pipe_compare_sym1(montg(1-nbdy,1-nbdy,1,1),ip,txt1)
+ if (cinfo(1:6).eq.'icloan' .or.
+ & cinfo(1:6).eq.'icecpl' ) then !ice fields
+ txt1='covice '
+ call pipe_compare_sym1(covice,ip,txt1)
+ txt1='flxice '
+ call pipe_compare_sym1(flxice,ip,txt1)
+ txt1='fswice '
+ call pipe_compare_sym1(fswice,ip,txt1)
+ txt1='sflice '
+ call pipe_compare_sym1(sflice,ip,txt1)
+ endif
+ if (cinfo(1:6).eq.'icloan' .or.
+ & cinfo(1:6).eq.'icecpl' .or.
+ & cinfo(1:6).eq.'thermf' ) then !surface fields
+ txt1='surflx '
+ call pipe_compare_sym1(surflx,ip,txt1)
+ txt1='sswflx '
+ call pipe_compare_sym1(sswflx,ip,txt1)
+ txt1='salflx '
+ call pipe_compare_sym1(salflx,ip,txt1)
+ endif
+ do k=1,kk
+ write(txt1(10:12),'(i3)') k
+ write(txt2(10:12),'(i3)') k
+c
+ txt1(1:9) = 'u(kn) k='
+ txt2(1:9) = 'v(kn) k='
+ call pipe_compare_sym2( u(1-nbdy,1-nbdy,k,n),iu,txt1,
+ & v(1-nbdy,1-nbdy,k,n),iv,txt2)
+ txt1(1:9) = 'dp(kn) k='
+ call pipe_compare_sym1( dp(1-nbdy,1-nbdy,k,n),ip,txt1)
+ txt1(1:9) = 'temp(kn) '
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,n),ip,txt1)
+ txt1(1:9) = 'saln(kn) '
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,n),ip,txt1)
+ txt1(1:9) = 'th3d(kn) '
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,n),ip,txt1)
+* write(lpunit,'(a,a12,a,i3)') '***',txt1,'*** k=',k
+ enddo
+ if (mnproc.eq.1) then
+ write (lpunit,'(a,i10,a)') cinfo,nstep,' -- OK'
+ endif
+ call xcsync(flush_lp)
+ endif !lpipe
+c
+ return
+ end subroutine pipe_comparall
+c
+ end module mod_pipe
+c
+c
+c> Revision history:
+c>
+c> Oct 2000 - added PIPE_DEBUG for debugging printout
+c> Aug 2001 - added PIPE_SHIFT for shifted comparision
+c> Aug 2001 - added PIPE_SYM for symmetric comparision
+c> Feb 2004 - added PIPE_SYM arctic option for arctic bipolar patch
+c> Jun 2005 - added PIPE_DEBUG_SSH for debugging SSH printout
diff --git a/src_2.2.18_3_one/mod_tides.F b/src_2.2.18_3_one/mod_tides.F
new file mode 100755
index 0000000..31ac3e3
--- /dev/null
+++ b/src_2.2.18_3_one/mod_tides.F
@@ -0,0 +1,909 @@
+ module mod_tides
+ use mod_xc ! HYCOM communication interface
+c
+ implicit none
+c
+c --- HYCOM tides
+c
+ integer, parameter, public :: ncon=8 !number of tidal consituents
+c
+ logical, parameter, private :: debug_tides=.false. !usually .false.
+c
+ integer, save, public ::
+ & tidflg, ! 0:notide,1:open bdy. only;2:body (and if lbflag=3:open bdy)
+ & tidcon, ! 1 digit per constituent (Q1K2P1N2O1K1S2M2), 0=off,1=on
+ & nhrly ! number of valid hourly samples (0 to 25)
+c
+ logical, save, public ::
+ & tidgen ! generic time (don't correct tides for actual year)
+c
+ real*8, save, public ::
+ & ramp_orig, ! tide ramp origin (model day)
+ & time_8 ! model time for tides
+c
+ real, save, public ::
+ & tidsal, ! scalar self attraction and loading factor (beta)
+ & ramp_time ! tide ramping time (days)
+c
+ real, allocatable, dimension(:,:),
+ & save, public ::
+ & etide, ! body tide, in m
+ & untide, ! de-tided u-velocity, average of uhrly
+ & vntide ! de-tided u-velocity, average of vhrly
+c
+ real, allocatable, dimension(:,:,:),
+ & save, public ::
+ & uhrly, ! hourly u-velocity samples
+ & vhrly ! hourly v-velocity samples
+c
+ logical, save, private ::
+ & tide_on(ncon)
+c
+ real, allocatable, dimension(:,:,:),
+ & save, private ::
+ & atide, ! coefficents for body tide
+ & btide ! coefficents for body tide
+
+ real*8, save, private ::
+ & amp(ncon),omega(ncon),timeref,
+ & pu8(ncon),pf8(ncon),arg8(ncon),time_mjd
+
+ contains
+
+ subroutine tides_set(flag)
+ implicit none
+ include 'common_blocks.h'
+c
+ integer flag
+c
+c --- body force tide setup
+c
+ integer iyear,iyrold,iday,ihour,inty
+ integer i,ihr,j,k,nleap,tidcon1
+ real*8 t,h0,s0,p0,db
+ real*8 rad
+ real alpha2q1,alpha2o1,alpha2p1,alpha2k1
+ real alpha2m2,alpha2s2,alpha2n2,alpha2k2
+ real diur_cos,diur_sin,semi_cos,semi_sin
+ data rad/ 0.0174532925199432d0 /
+ save iyrold,rad
+
+ if (tidflg.eq.2) then
+
+ if(flag.eq.0) then
+ tidcon1 = tidcon
+ do i =1,ncon
+ tide_on(i) = mod(tidcon1,10) .eq. 1
+ tidcon1 = tidcon1/10 ! shift by one decimal digit
+ enddo
+ endif
+
+ if (yrflag.eq.3) then
+ call forday(time_8,yrflag,iyear,iday,ihour)
+ if (flag.eq.0) then
+ iyrold=iyear-1 !.ne.iyear
+ endif
+ if (iyear.ne.iyrold) then !.or. flag.eq.0
+ iyrold=iyear
+
+c in the following, the origin (time_mjd) is in modified
+c julian days, i.e. with zero on Nov 17 0:00 1858
+c This is updated once pr year (Jan 1), with jan 1 = 1 (day one)
+c time_ref is the time from hycom-origin, i.e. from jan 1 1901 0:00,
+c to jan 1 0:00 in the computation year.
+c It is used in tideforce below.
+
+c no of leap years in the two reference periods mentioned above:
+ nleap = (iyear-1901)/4
+ if(iyear.lt.1900)then
+ inty = (iyear-1857)/4
+ else
+ inty = ((iyear-1857)/4)-1 !there was no leap year in 1900
+ endif
+
+ timeref = 365.d0*(iyear-1901) + nleap
+ & + 1.d0 !so jan 1 = 1 (day one)
+ time_mjd = 365.d0*(iyear-1858) + inty
+ & - (31+28+31+30+31+30+31+31+30+31+17)
+ & + 1.d0 !so jan 1 = 1 (day one)
+
+
+ if (mnproc.eq.1) then
+ write (lp,*) 'tide_set: calling tides_nodal for a new year'
+ endif !1st tile
+ call xcsync(flush_lp)
+ call tides_nodal
+ endif !iyear.ne.iyrold (.or. flag.eq.0)
+ endif !yrflag.eq.3
+
+ if(flag.eq.0) then
+ if (mnproc.eq.1) then
+ write (lp,*) ' now initializing tidal body forcing ...'
+ write (lp,'(/a,i8.8/)') ' Q1K2P1N2O1K1S2M2 = ',tidcon
+ endif !1st tile
+ call xcsync(flush_lp)
+
+ allocate( atide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ncon),
+ & btide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ncon),
+ & etide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+c
+c --- amp is in m, and omega in 1/day.
+c
+ amp ( 3)= 0.1424079984D+00
+ omega( 3)= 0.6300387913D+01 ! K1
+ amp ( 4)= 0.1012659967D+00
+ omega( 4)= 0.5840444971D+01 ! O1
+ amp ( 6)= 0.4712900147D-01
+ omega( 6)= 0.6265982327D+01 ! P1
+ amp ( 8)= 0.1938699931D-01
+ omega( 8)= 0.5612418128D+01 ! Q1
+ amp ( 1)= 0.2441020012D+00
+ omega( 1)= 0.1214083326D+02 ! M2
+ amp ( 2)= 0.1135720015D+00
+ omega( 2)= 0.1256637061D+02 ! S2
+ amp ( 5)= 0.4673499987D-01
+ omega( 5)= 0.1191280642D+02 ! N2
+ amp ( 7)= 0.3087499924D-01
+ omega( 7)= 0.1260077583D+02 ! K2
+
+c --- alpha2=(1+k-h)g; Love numbers k,h taken from
+c --- Foreman et al. JGR,98,2509-2532,1993
+ alpha2q1=1.0+0.298-0.603
+ alpha2o1=1.0+0.298-0.603
+ alpha2p1=1.0+0.287-0.581
+ alpha2k1=1.0+0.256-0.520
+ alpha2m2=1.0+0.302-0.609
+ alpha2s2=alpha2m2
+ alpha2n2=alpha2m2
+ alpha2k2=alpha2m2
+!$OMP PARALLEL DO PRIVATE(j,i,semi_cos,semi_sin,diur_cos,diur_sin)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ semi_cos=cos(rad*plat(i,j))**2*cos(rad*2*plon(i,j))
+ semi_sin=cos(rad*plat(i,j))**2*sin(rad*2*plon(i,j))
+ diur_cos=sin(2.*rad*plat(i,j))*cos(rad*plon(i,j))
+ diur_sin=sin(2.*rad*plat(i,j))*sin(rad*plon(i,j))
+
+ atide(i,j,3)= amp(3)*alpha2k1* diur_cos
+ btide(i,j,3)= amp(3)*alpha2k1* diur_sin
+ atide(i,j,4)= amp(4)*alpha2o1* diur_cos
+ btide(i,j,4)= amp(4)*alpha2o1* diur_sin
+ atide(i,j,6)= amp(6)*alpha2p1* diur_cos
+ btide(i,j,6)= amp(6)*alpha2p1* diur_sin
+ atide(i,j,8)= amp(8)*alpha2q1* diur_cos
+ btide(i,j,8)= amp(8)*alpha2q1* diur_sin
+
+ atide(i,j,1)= amp(1)*alpha2m2* semi_cos
+ btide(i,j,1)= amp(1)*alpha2m2* semi_sin
+ atide(i,j,2)= amp(2)*alpha2s2* semi_cos
+ btide(i,j,2)= amp(2)*alpha2s2* semi_sin
+ atide(i,j,5)= amp(5)*alpha2n2* semi_cos
+ btide(i,j,5)= amp(5)*alpha2n2* semi_sin
+ atide(i,j,7)= amp(7)*alpha2k2* semi_cos
+ btide(i,j,7)= amp(7)*alpha2k2* semi_sin
+
+ etide(i,j) = 0.0
+ enddo !i
+ enddo !j
+
+ call xctilr(atide(1-nbdy,1-nbdy,1),1,ncon, nbdy,nbdy, halo_ps)
+ call xctilr(btide(1-nbdy,1-nbdy,1),1,ncon, nbdy,nbdy, halo_ps)
+
+ if (mnproc.eq.1) then
+ write (lp,*) ' ...finished initializing tidal body forcing'
+ endif !1st tile
+ call xcsync(flush_lp)
+
+ endif !flag.eq.0
+
+ endif !tidflg.eq.2
+
+ if(flag.eq.0) then
+ if (.not.allocated(uhrly)) then
+c --- restart_in did not allocate/input [uv]hrly
+ allocate( uhrly(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,25),
+ & vhrly(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,25),
+ & untide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & vntide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ do ihr= 1,25
+ uhrly(i,j,ihr) = 0.0
+ vhrly(i,j,ihr) = 0.0
+ enddo !ihr
+ enddo !i
+ enddo !j
+ nhrly = 0
+ endif !.not.allocated
+ call tides_detide(1, .false.) !initialise 25-hour average
+ endif !flag.eq.0
+
+ return
+ end subroutine tides_set
+
+ subroutine tides_detide(n, update)
+ implicit none
+ include 'common_blocks.h'
+c
+ integer n
+ logical update
+c
+c --- form 25-hour averages
+c
+ integer i,ihr,j,k,l
+ real pthkbl,pbop,phi,plo,ubot,vbot
+ real*8 usum,vsum
+c
+ if (update) then
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,
+!$OMP& pthkbl,pbop,phi,plo,ubot,vbot)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do i=1,ii
+ util5(i,j)=0.0 !probably not needed
+ util6(i,j)=0.0 !probably not needed
+ enddo !i
+ do l=1,isu(j)
+ do i=max(1,ifu(j,l)),min(ii,ilu(j,l))
+ pthkbl=thkdrg*onem !thknss of bot. b.l.
+ pbop=depthu(i,j)-pthkbl !top of bot. b.l.
+ phi =max(0.5*(p(i,j,1)+p(i+1,j,1)),pbop)
+ ubot=0.0
+ do k=1,kk
+ plo =phi ! max(0.5*(p(i,j,k) +p(i-1,j,k) ),pbop)
+ phi =max(min(depthu(i,j),0.5*(p(i,j,k+1)+p(i-1,j,k+1))),
+ & pbop)
+ ubot=ubot + u(i,j,k,n)*(phi-plo)
+ enddo !k
+ util5(i,j)=ubot/min(pthkbl,depthu(i,j)) + ubavg(i,j,n)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1,ifv(j,l)),min(ii,ilv(j,l))
+ pthkbl=thkdrg*onem !thknss of bot. b.l.
+ pbop=depthv(i,j)-pthkbl !top of bot. b.l.
+ phi =max(0.5*(p(i,j,1)+p(i+1,j,1)),pbop)
+ vbot=0.0
+ do k=1,kk
+ plo =phi ! max(0.5*(p(i,j,k) +p(i-1,j,k) ),pbop)
+ phi =max(min(depthv(i,j),0.5*(p(i,j,k+1)+p(i-1,j,k+1))),
+ & pbop)
+ vbot=vbot + v(i,j,k,n)*(phi-plo)
+ enddo !k
+ util6(i,j)=vbot/min(pthkbl,depthv(i,j)) + vbavg(i,j,n)
+ enddo !i
+ enddo !l
+ enddo !j
+ call xctilr(util5,1,1, nbdy,nbdy, halo_uv)
+ call xctilr(util6,1,1, nbdy,nbdy, halo_vv)
+ if (nhrly.eq.25) then
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ usum = 0.0
+ vsum = 0.0
+ do ihr= 1,24
+ uhrly(i,j,ihr) = uhrly(i,j,ihr+1)
+ vhrly(i,j,ihr) = vhrly(i,j,ihr+1)
+ usum = usum + uhrly(i,j,ihr)
+ vsum = vsum + vhrly(i,j,ihr)
+ enddo !ihr
+ uhrly(i,j, 25) = util5(i,j)
+ vhrly(i,j, 25) = util6(i,j)
+ usum = usum + uhrly(i,j,25)
+ vsum = vsum + vhrly(i,j,25)
+ untide(i,j) = usum/25.d0
+ vntide(i,j) = vsum/25.d0
+ enddo !i
+ enddo !j
+ else
+ nhrly = nhrly + 1
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ uhrly(i,j,nhrly) = util5(i,j)
+ vhrly(i,j,nhrly) = util6(i,j)
+ untide(i,j) = 0.0
+ vntide(i,j) = 0.0
+ enddo !i
+ enddo !j
+ endif !nhrly:else
+ else
+ if (nhrly.eq.25) then
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ usum = uhrly(i,j,1)
+ vsum = vhrly(i,j,1)
+ do ihr= 2,25
+ usum = usum + uhrly(i,j,ihr)
+ vsum = vsum + vhrly(i,j,ihr)
+ enddo !ihr
+ untide(i,j) = usum/25.d0
+ vntide(i,j) = vsum/25.d0
+ enddo !i
+ enddo !j
+ else
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ untide(i,j) = 0.0
+ vntide(i,j) = 0.0
+ enddo !i
+ enddo !j
+ endif !nhrly:else
+ endif !update:else
+
+ if (debug_tides) then
+ if (itest.gt.0 .and. jtest.gt.0) then
+ write (lp,'(i9,2i5,3x,a,i2.2,a,2f10.6)')
+ & nstep,itest+i0,jtest+j0,
+ & ' hr',nhrly,' = ',
+ & uhrly(itest,jtest,nhrly), vhrly(itest,jtest,nhrly)
+ write (lp,'(i9,2i5,3x,a,2f10.6)')
+ & nstep,itest+i0,jtest+j0,
+ & 'ntide = ',
+ & untide(itest,jtest), vntide(itest,jtest)
+ endif
+ call xcsync(flush_lp)
+ endif !debug_tides
+ return
+ end subroutine tides_detide
+
+ subroutine tides_force(ll)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+
+ integer ll
+
+c
+c --- calculate body tide
+c
+
+ integer i,j
+ real*8 timet,timermp
+ real ramp
+ real etide1,etide2,etide3,etide4,etide5,etide6,etide7,etide8
+
+c ramp-up of tide signal
+ ramp =1.0
+ timermp=time_8+(ll*dlt/86400.d0)
+ if(ramp_time.gt.0.0 ) then
+ if(timermp .ge.ramp_orig)then
+ timermp=(timermp-ramp_orig)/ramp_time
+ ramp=ramp*(1.0-exp(-5.0*timermp))
+ else
+ ramp=0.0
+ endif
+ endif !ramp_time
+
+ if (.not.tidgen) then
+ call tides_set(1)
+ else
+ arg8(1:ncon) = 0.0 !no correction for a specific year
+ endif !standard:generic
+
+ if (yrflag.eq.3) then
+ timet=time_8+(ll*dlt/86400.d0)-timeref !time from jan 1 00:00
+ else
+ timet=time_8+(ll*dlt/86400.d0)-ramp_orig !time since ramp_orig
+ endif
+
+ etide1 = 0.0
+ etide2 = 0.0
+ etide3 = 0.0
+ etide4 = 0.0
+ etide5 = 0.0
+ etide6 = 0.0
+ etide7 = 0.0
+ etide8 = 0.0
+!$OMP PARALLEL DO PRIVATE(j,i,
+!$OMP& etide1,etide2,etide3,etide4,etide5,etide6,etide7,etide8)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ if (tide_on(1)) then
+ etide1=atide(i,j,1)*cos(omega(1)*timet+arg8(1))-
+ & btide(i,j,1)*sin(omega(1)*timet+arg8(1))
+ endif
+ if (tide_on(2)) then
+ etide2=atide(i,j,2)*cos(omega(2)*timet+arg8(2))-
+ & btide(i,j,2)*sin(omega(2)*timet+arg8(2))
+ endif
+ if (tide_on(3)) then
+ etide3=atide(i,j,3)*cos(omega(3)*timet+arg8(3))-
+ & btide(i,j,3)*sin(omega(3)*timet+arg8(3))
+ endif
+ if (tide_on(4)) then
+ etide4=atide(i,j,4)*cos(omega(4)*timet+arg8(4))-
+ & btide(i,j,4)*sin(omega(4)*timet+arg8(4))
+ endif
+ if (tide_on(5)) then
+ etide5=atide(i,j,5)*cos(omega(5)*timet+arg8(5))-
+ & btide(i,j,5)*sin(omega(5)*timet+arg8(5))
+ endif
+ if (tide_on(6)) then
+ etide6=atide(i,j,6)*cos(omega(6)*timet+arg8(6))-
+ & btide(i,j,6)*sin(omega(6)*timet+arg8(6))
+ endif
+ if (tide_on(7)) then
+ etide7=atide(i,j,7)*cos(omega(7)*timet+arg8(7))-
+ & btide(i,j,7)*sin(omega(7)*timet+arg8(7))
+ endif
+ if (tide_on(8)) then
+ etide8=atide(i,j,8)*cos(omega(8)*timet+arg8(8))-
+ & btide(i,j,8)*sin(omega(8)*timet+arg8(8))
+ endif
+
+ etide(i,j)= etide1
+ & +etide2
+ & +etide3
+ & +etide4
+ & +etide5
+ & +etide6
+ & +etide7
+ & +etide8
+ etide(i,j)=ramp*etide(i,j)
+ enddo !i
+ enddo !j
+ return
+ end subroutine tides_force
+
+ subroutine tides_driver(z1rall,z1iall,dtime,
+ & astroflag,zpredall,start,ijtdm,ndat) !normal
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+
+ integer ijtdm
+ real z1rall(ijtdm,ncon), z1iall(ijtdm,ncon),zpredall(ijtdm)
+ real zpred(ndat),z1r(ndat,ncon),z1i(ndat,ncon)
+ real Ai(ncon), Ar(ncon)
+ integer ind(ncon),start
+ real*8 dtime
+
+ character*10 cdate
+ character*8 ctime
+ logical interp_micon, astroflag
+ integer n,m,ndat,i,j,k,ic
+
+c From ptide
+ real ww(17,ncon)
+
+ real*8 ttime
+
+c from make_a
+c If l_sal=.true. - NO solid Earth correction is applied
+c USING beta_SE coefficients
+ logical l_sal
+ real beta_SE(ncon)
+ real ci(ncon),cr(ncon)
+
+c the succession is: M2,S2,K1,O1,N2,P1,K2,Q1 (corresponding to
+c succession in tidalports_*.input)
+
+ data beta_SE/
+ 1 0.9540,0.9540,0.9400,0.9400,
+ 2 0.9540,0.9400,0.9540,0.9400/
+ save beta_SE
+
+ l_sal = .TRUE.
+ interp_micon =.FALSE.
+
+ do i =1,ndat
+ zpred(i) = zpredall(start+i-1)
+ do ic =1,ncon
+ z1r(i,ic) = z1rall(start+i-1,ic)
+ z1i(i,ic) = z1iall(start+i-1,ic)
+ enddo
+ enddo
+
+ do i =1,ncon
+ ind(i) = i
+ enddo
+
+ ttime=dtime-timeref !days from jan 1 00:00
+
+c ndat is the number of lat/lon pairs
+c output is zpred which is the elevations
+ do k = 1, ndat
+
+c Currently disabled
+c. to include get ww from weights.h
+ if(interp_micon)call tides_mkw(interp_micon,ind,ncon,ww)
+
+ do j=1,ncon
+ i=ind(j)
+ if(i.ne.0)then
+ cr(j) = pf8(i)*cos(omega(i)*ttime+arg8(i)+pu8(i))
+ ci(j) = pf8(i)*sin(omega(i)*ttime+arg8(i)+pu8(i))
+ endif
+ enddo
+
+c .true. means NO solid Earth correction will be applied in make_a
+c remove solid Earth tide
+ if(.not.l_sal)then
+ do j=1,ncon
+ Ar(j)=0.
+ Ai(j)=0.
+ if(ind(j).ne.0) then
+ Ar(j)=cr(j)*beta_SE(ind(j))
+ Ai(j)=ci(j)*beta_SE(ind(j))
+ endif
+
+ enddo
+ else
+ do j=1,ncon
+ Ar(j)=cr(j)*1.
+ Ai(j)=ci(j)*1.
+ enddo
+ endif
+
+
+ if(ncon.eq.0)then
+ zpred(k)=0
+ else
+ zpred(k)=0
+ do i=1,ncon
+ zpred(k)=zpred(k)+z1r(k,i)*Ar(i)
+ * -z1i(k,i)*Ai(i)
+ enddo
+ endif
+
+ zpredall(start+k-1) = zpred(k)
+
+ enddo
+
+
+ close(1)
+
+
+ return
+ end subroutine tides_driver
+
+ subroutine tides_mkw(interp,ind,nc,wr)
+ real wr(17,ncon)
+ logical interp
+ integer i,j,nc,ind(nc)
+ real w(17,ncon)
+ data w(1,:)/1.0, .00, .00, .00, .00, .00, .00, .00/
+ data w(2,:)/0.0, 1.00, .00, .00, .00, .00, .00, .00/
+ data w(3,:)/0.0, .00, 1.0, .00, .00, .00, .00, .00/
+ data w(4,:)/0.0, .00, .00, 1.00, .00, .00, .00, .00/
+ data w(5,:)/0.0, .00, .00, .00, 1.00, .00, .00, .00/
+ data w(6,:)/0.0, .00, .00, .00, .00, 1.00, .00, .00/
+ data w(7,:)/0.0, .00, .00, .00, .00, .00, 1.00, .00/
+ data w(8,:)/0.0, .00, .00, .00, .00, .00, .00, 1.00/
+ data w(9,:)/-0.0379, .0,.00, .00, .30859 ,0.0, .03289,.0/
+ data w(10,:)/-0.03961,.0,.00, .00, .34380, 0.0, .03436,.0/
+ data w(11,:)/.00696, .0,.00, .00, .15719, 0.0, -.00547,.0/
+ data w(12,:)/.02884, .0,.00, .00, -.05036, 0.0, .07424,.0/
+ data w(13,:)/.00854, .0,.00, .00, -.01913, 0.0, .17685,.0/
+ data w(14,:)/.0, .0, -.00571, .11234, .0, .05285, .0, -.26257/
+ data w(15,:)/.0, .0, .00749, .07474, .0, .03904, .0, -.12959/
+ data w(16,:)/.0, .0, -.03748, .12419, .0, .05843, .0, -.29027/
+ data w(17,:)/.0, .0, .00842, .01002, .0,-.03064, .0, .15028/
+ save w
+ wr=w
+ if(interp)return
+c
+ do j=1,nc
+ if(ind(j).ne.0)wr(ind(j),:)=0.
+ enddo
+ return
+ end subroutine tides_mkw
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c argUMENTS and ASTROL subroutines SUPPLIED by RICHARD RAY, March 1999
+c attached to OTIS by Lana Erofeeva (subroutine nodal.f)
+c NOTE - "no1" in constit.h corresponds to "M1" in arguments
+ciris subroutine nodal(dtime,pu8,pf8,arg8)
+
+ subroutine tides_nodal
+ implicit none
+
+ integer ncmx
+ parameter(ncmx = 21)
+c 21 put here instead of ncmx for compatability with old constit.h
+ integer index(ncmx),i
+ real*8 latitude,pu(ncmx),pf(ncmx)
+ real*8 arg(53),f(53),u(53),pi
+
+
+ data pi/3.14159265358979/
+c index gives correspondence between constit.h and Richard's subroutines
+c constit.h: M2,S2,K1,O1,N2,P1,K2,q1,2N2,mu2,nu2,L2,t2,
+c J1,M1(no1),OO1,rho1,Mf,Mm,SSA,M4
+ data index/30,35,19,12,27,17,37,10,25,26,28,33,34,
+ * 23,14,24,11,5,3,2,45/
+
+ call tidal_arguments(time_mjd,arg,f,u)
+ do i=1,ncmx
+c u is returned by "tidal_arguments" in degrees
+ pu(i)=u(index(i))*pi/180.d0
+ pf(i)=f(index(i))
+c write(*,*)pu(i),pf(i)
+ enddo
+
+ do i =1,ncon
+ pu8(i) = pu(i)
+ pf8(i) = pf(i)
+ arg8(i)= arg(index(i))*pi/180.d0
+ enddo
+
+ return
+ end subroutine tides_nodal
+
+ subroutine tidal_arguments( time1, arg, f, u)
+ implicit none
+
+ real*8 time1, arg(*), f(*), u(*)
+*
+* Kernel routine for subroutine hat53. Calculate tidal arguments.
+*
+ real*8 xi
+ real*8 shpn(4),s,h,p,omega,pp,hour,t1,t2
+ real*8 tmp1,tmp2,temp1,temp2
+ real*8 cosn,cos2n,sinn,sin2n,sin3n
+ real*8 zero,one,two,three,four,five
+ real*8 fiften,thirty,ninety
+ real*8 pi, rad
+ parameter (pi=3.141592654d0, rad=pi/180.d0)
+ parameter (zero=0.d0, one=1.d0)
+ parameter (two=2.d0, three=3.d0, four=4.d0, five=5.d0)
+ parameter (fiften=15.d0, thirty=30.d0, ninety=90.d0)
+ parameter (pp=282.94) ! solar perigee at epoch 2000.
+ equivalence (shpn(1),s),(shpn(2),h),(shpn(3),p),(shpn(4),omega)
+*
+* Determine equilibrium arguments
+* -------------------------------
+ call tides_astrol( time1, shpn )
+ hour = (time1 - int(time1))*24.d0
+ t1 = fiften*hour
+ t2 = thirty*hour
+ arg( 1) = h - pp ! Sa
+ arg( 2) = two*h ! Ssa
+ arg( 3) = s - p ! Mm
+ arg( 4) = two*s - two*h ! MSf
+ arg( 5) = two*s ! Mf
+ arg( 6) = three*s - p ! Mt
+ arg( 7) = t1 - five*s + three*h + p - ninety ! alpha1
+ arg( 8) = t1 - four*s + h + two*p - ninety ! 2Q1
+ arg( 9) = t1 - four*s + three*h - ninety ! sigma1
+ arg(10) = t1 - three*s + h + p - ninety ! q1
+ arg(11) = t1 - three*s + three*h - p - ninety ! rho1
+ arg(12) = t1 - two*s + h - ninety ! o1
+ arg(13) = t1 - two*s + three*h + ninety ! tau1
+ arg(14) = t1 - s + h + ninety ! M1
+ arg(15) = t1 - s + three*h - p + ninety ! chi1
+ arg(16) = t1 - two*h + pp - ninety ! pi1
+ arg(17) = t1 - h - ninety ! p1
+ arg(18) = t1 + ninety ! s1
+ arg(19) = t1 + h + ninety ! k1
+ arg(20) = t1 + two*h - pp + ninety ! psi1
+ arg(21) = t1 + three*h + ninety ! phi1
+ arg(22) = t1 + s - h + p + ninety ! theta1
+ arg(23) = t1 + s + h - p + ninety ! J1
+ arg(24) = t1 + two*s + h + ninety ! OO1
+ arg(25) = t2 - four*s + two*h + two*p ! 2N2
+ arg(26) = t2 - four*s + four*h ! mu2
+ arg(27) = t2 - three*s + two*h + p ! n2
+ arg(28) = t2 - three*s + four*h - p ! nu2
+ arg(29) = t2 - two*s + h + pp ! M2a
+ arg(30) = t2 - two*s + two*h ! M2
+ arg(31) = t2 - two*s + three*h - pp ! M2b
+ arg(32) = t2 - s + p + 180.d0 ! lambda2
+ arg(33) = t2 - s + two*h - p + 180.d0 ! L2
+ arg(34) = t2 - h + pp ! t2
+ arg(35) = t2 ! S2
+ arg(36) = t2 + h - pp + 180.d0 ! R2
+ arg(37) = t2 + two*h ! K2
+ arg(38) = t2 + s + two*h - pp ! eta2
+ arg(39) = t2 - five*s + 4.0*h + p ! MNS2
+ arg(40) = t2 + two*s - two*h ! 2SM2
+ arg(41) = 1.5*arg(30) ! M3
+ arg(42) = arg(19) + arg(30) ! MK3
+ arg(43) = three*t1 ! S3
+ arg(44) = arg(27) + arg(30) ! MN4
+ arg(45) = two*arg(30) ! M4
+ arg(46) = arg(30) + arg(35) ! MS4
+ arg(47) = arg(30) + arg(37) ! MK4
+ arg(48) = four*t1 ! S4
+ arg(49) = five*t1 ! S5
+ arg(50) = three*arg(30) ! M6
+ arg(51) = three*t2 ! S6
+ arg(52) = 7.0*t1 ! S7
+ arg(53) = four*t2 ! S8
+*
+* determine nodal corrections f and u
+* -----------------------------------
+ sinn = sin(omega*rad)
+ cosn = cos(omega*rad)
+ sin2n = sin(two*omega*rad)
+ cos2n = cos(two*omega*rad)
+ sin3n = sin(three*omega*rad)
+ f( 1) = one ! Sa
+ f( 2) = one ! Ssa
+ f( 3) = one - 0.130*cosn ! Mm
+ f( 4) = one ! MSf
+ f( 5) = 1.043 + 0.414*cosn ! Mf
+ f( 6) = sqrt((one+.203*cosn+.040*cos2n)**2 +
+ * (.203*sinn+.040*sin2n)**2) ! Mt
+
+ f( 7) = one ! alpha1
+ f( 8) = sqrt((1.+.188*cosn)**2+(.188*sinn)**2) ! 2Q1
+ f( 9) = f(8) ! sigma1
+ f(10) = f(8) ! q1
+ f(11) = f(8) ! rho1
+ f(12) = sqrt((1.0+0.189*cosn-0.0058*cos2n)**2 +
+ * (0.189*sinn-0.0058*sin2n)**2) ! O1
+ f(13) = one ! tau1
+ccc tmp1 = 2.*cos(p*rad)+.4*cos((p-omega)*rad)
+ccc tmp2 = sin(p*rad)+.2*sin((p-omega)*rad) ! Doodson's
+ tmp1 = 1.36*cos(p*rad)+.267*cos((p-omega)*rad) ! Ray's
+ tmp2 = 0.64*sin(p*rad)+.135*sin((p-omega)*rad)
+ f(14) = sqrt(tmp1**2 + tmp2**2) ! M1
+ f(15) = sqrt((1.+.221*cosn)**2+(.221*sinn)**2) ! chi1
+ f(16) = one ! pi1
+ f(17) = one ! P1
+ f(18) = one ! S1
+ f(19) = sqrt((1.+.1158*cosn-.0029*cos2n)**2 +
+ * (.1554*sinn-.0029*sin2n)**2) ! K1
+ f(20) = one ! psi1
+ f(21) = one ! phi1
+ f(22) = one ! theta1
+ f(23) = sqrt((1.+.169*cosn)**2+(.227*sinn)**2) ! J1
+ f(24) = sqrt((1.0+0.640*cosn+0.134*cos2n)**2 +
+ * (0.640*sinn+0.134*sin2n)**2 ) ! OO1
+ f(25) = sqrt((1.-.03731*cosn+.00052*cos2n)**2 +
+ * (.03731*sinn-.00052*sin2n)**2) ! 2N2
+ f(26) = f(25) ! mu2
+ f(27) = f(25) ! N2
+ f(28) = f(25) ! nu2
+ f(29) = one ! M2a
+ f(30) = f(25) ! M2
+ f(31) = one ! M2b
+ f(32) = one ! lambda2
+ temp1 = 1.-0.25*cos(two*p*rad)
+ * -0.11*cos((two*p-omega)*rad)-0.04*cosn
+ temp2 = 0.25*sin(two*p)+0.11*sin((two*p-omega)*rad)
+ * + 0.04*sinn
+ f(33) = sqrt(temp1**2 + temp2**2) ! L2
+ f(34) = one ! t2
+ f(35) = one ! S2
+ f(36) = one ! R2
+ f(37) = sqrt((1.+.2852*cosn+.0324*cos2n)**2 +
+ * (.3108*sinn+.0324*sin2n)**2) ! K2
+ f(38) = sqrt((1.+.436*cosn)**2+(.436*sinn)**2) ! eta2
+ f(39) = f(30)**2 ! MNS2
+ f(40) = f(30) ! 2SM2
+ f(41) = one ! wrong ! M3
+ f(42) = f(19)*f(30) ! MK3
+ f(43) = one ! S3
+ f(44) = f(30)**2 ! MN4
+ f(45) = f(44) ! M4
+ f(46) = f(44) ! MS4
+ f(47) = f(30)*f(37) ! MK4
+ f(48) = one ! S4
+ f(49) = one ! S5
+ f(50) = f(30)**3 ! M6
+ f(51) = one ! S6
+ f(52) = one ! S7
+ f(53) = one ! S8
+
+ u( 1) = zero ! Sa
+ u( 2) = zero ! Ssa
+ u( 3) = zero ! Mm
+ u( 4) = zero ! MSf
+ u( 5) = -23.7*sinn + 2.7*sin2n - 0.4*sin3n ! Mf
+ u( 6) = atan(-(.203*sinn+.040*sin2n)/
+ * (one+.203*cosn+.040*cos2n))/rad ! Mt
+ u( 7) = zero ! alpha1
+ u( 8) = atan(.189*sinn/(1.+.189*cosn))/rad ! 2Q1
+ u( 9) = u(8) ! sigma1
+ u(10) = u(8) ! q1
+ u(11) = u(8) ! rho1
+ u(12) = 10.8*sinn - 1.3*sin2n + 0.2*sin3n ! O1
+ u(13) = zero ! tau1
+ u(14) = atan2(tmp2,tmp1)/rad ! M1
+ u(15) = atan(-.221*sinn/(1.+.221*cosn))/rad ! chi1
+ u(16) = zero ! pi1
+ u(17) = zero ! P1
+ u(18) = zero ! S1
+ u(19) = atan((-.1554*sinn+.0029*sin2n)/
+ * (1.+.1158*cosn-.0029*cos2n))/rad ! K1
+ u(20) = zero ! psi1
+ u(21) = zero ! phi1
+ u(22) = zero ! theta1
+ u(23) = atan(-.227*sinn/(1.+.169*cosn))/rad ! J1
+ u(24) = atan(-(.640*sinn+.134*sin2n)/
+ * (1.+.640*cosn+.134*cos2n))/rad ! OO1
+ u(25) = atan((-.03731*sinn+.00052*sin2n)/
+ * (1.-.03731*cosn+.00052*cos2n))/rad ! 2N2
+ u(26) = u(25) ! mu2
+ u(27) = u(25) ! N2
+ u(28) = u(25) ! nu2
+ u(29) = zero ! M2a
+ u(30) = u(25) ! M2
+ u(31) = zero ! M2b
+ u(32) = zero ! lambda2
+ u(33) = atan(-temp2/temp1)/rad ! L2
+ u(34) = zero ! t2
+ u(35) = zero ! S2
+ u(36) = zero ! R2
+ u(37) = atan(-(.3108*sinn+.0324*sin2n)/
+ * (1.+.2852*cosn+.0324*cos2n))/rad ! K2
+ u(38) = atan(-.436*sinn/(1.+.436*cosn))/rad ! eta2
+ u(39) = u(30)*two ! MNS2
+ u(40) = u(30) ! 2SM2
+ u(41) = 1.5d0*u(30) ! M3
+ u(42) = u(30) + u(19) ! MK3
+ u(43) = zero ! S3
+ u(44) = u(30)*two ! MN4
+ u(45) = u(44) ! M4
+ u(46) = u(30) ! MS4
+ u(47) = u(30)+u(37) ! MK4
+ u(48) = zero ! S4
+ u(49) = zero ! S5
+ u(50) = u(30)*three ! M6
+ u(51) = zero ! S6
+ u(52) = zero ! S7
+ u(53) = zero ! S8
+
+ return
+ end subroutine tidal_arguments
+
+
+ SUBROUTINE TIDES_ASTROL( time, SHPN )
+*
+* Computes the basic astronomical mean longitudes s, h, p, N.
+* Note N is not N', i.e. N is decreasing with time.
+* These formulae are for the period 1990 - 2010, and were derived
+* by David Cartwright (personal comm., Nov. 1990).
+* time is UTC in decimal MJD.
+* All longitudes returned in degrees.
+* R. D. Ray Dec. 1990
+*
+* Non-vectorized version.
+*
+c IMPLICIT REAL*8 (A-H,O-Z)
+ real*8 circle,shpn,t,time
+ DIMENSION SHPN(4)
+ PARAMETER (CIRCLE=360.0D0)
+*
+ T = time - 51544.4993D0
+*
+* mean longitude of moon
+* ----------------------
+ SHPN(1) = 218.3164D0 + 13.17639648D0 * T
+*
+* mean longitude of sun
+* ---------------------
+ SHPN(2) = 280.4661D0 + 0.98564736D0 * T
+*
+* mean longitude of lunar perigee
+* -------------------------------
+ SHPN(3) = 83.3535D0 + 0.11140353D0 * T
+*
+* mean longitude of ascending lunar node
+* --------------------------------------
+ SHPN(4) = 125.0445D0 - 0.05295377D0 * T
+
+ SHPN(1) = MOD(SHPN(1),CIRCLE)
+ SHPN(2) = MOD(SHPN(2),CIRCLE)
+ SHPN(3) = MOD(SHPN(3),CIRCLE)
+ SHPN(4) = MOD(SHPN(4),CIRCLE)
+
+ IF (SHPN(1).LT.0.D0) SHPN(1) = SHPN(1) + CIRCLE
+ IF (SHPN(2).LT.0.D0) SHPN(2) = SHPN(2) + CIRCLE
+ IF (SHPN(3).LT.0.D0) SHPN(3) = SHPN(3) + CIRCLE
+ IF (SHPN(4).LT.0.D0) SHPN(4) = SHPN(4) + CIRCLE
+ RETURN
+ END SUBROUTINE TIDES_ASTROL
+
+c
+ end module mod_tides
+c
+c
+c> Revision history:
+c>
+c> Nov 2006 - 1st module version
diff --git a/src_2.2.18_3_one/mod_xc.F b/src_2.2.18_3_one/mod_xc.F
new file mode 100755
index 0000000..40b96e6
--- /dev/null
+++ b/src_2.2.18_3_one/mod_xc.F
@@ -0,0 +1,100 @@
+ module mod_xc
+ use mod_dimensions !include 'dimensions.h'
+ implicit none
+c
+c --- HYCOM communication interface.
+c --- see README.src.mod_xc for more details.
+c
+ include 'unit_offset.h'
+c
+c --- tile dimensions and tile numbers (counting from 1), see xcspmd
+ integer, public, save :: ipr, jpr, ijpr,
+ & mproc,nproc,mnproc,
+ & mp_1st
+#if defined(MPI)
+c
+c --- needed for some versions of mod_za
+ integer, public, save :: group_1st_in_row
+#endif
+c
+c --- region type (-1==unknown,
+c --- 0== closed/closed,
+c --- 1==periodic/closed,
+c --- 2==periodic/arctic,
+c --- 3==periodic/fplane
+c --- 4== closed/fplane)
+ integer, public, save :: nreg
+c
+c --- timers on, usually and default .true.
+ logical, public, save :: timer_on=.true.
+c
+c --- fill value for land, usually 0.0
+ real, public, save :: vland
+ real*4, public, save :: vland4 !xcget4 only
+c
+c --- xctilr halo options
+ integer, public, parameter :: halo_ps=1, halo_pv=11,
+ & halo_qs=2, halo_qv=12,
+ & halo_us=3, halo_uv=13,
+ & halo_vs=4, halo_vv=14
+c
+c --- xcsync stdout flushing options
+ logical, public, parameter :: flush_lp=.true.,
+ & no_flush=.false.
+c
+c --- generic subroutine names
+ interface xcmaxr
+ module procedure xcmaxr_0 ! rank 0 array (i.e. scalar)
+ module procedure xcmaxr_1 ! rank 1 array
+ module procedure xcmaxr_0o ! rank 0 array, old interface
+ module procedure xcmaxr_1o ! rank 1 array, old interface
+ end interface
+
+ interface xcminr
+ module procedure xcminr_0 ! rank 0 array (i.e. scalar)
+ module procedure xcminr_1 ! rank 1 array
+ module procedure xcminr_0o ! rank 0 array, old interface
+ module procedure xcminr_1o ! rank 1 array, old interface
+ end interface
+#if defined(USE_ESMF)
+c
+c --- public data structures for ESMF, see xcspmd
+ integer, public, save :: countde1(iqr),
+ & countde2(jqr)
+#endif
+c
+c --- private timer variables, see xctmri
+ character*6, private, dimension(97), save :: cc
+ integer, private, save :: nxc
+ integer, private, dimension(97), save :: nc
+ real*8, private, dimension(97), save :: tc,t0
+ real*8, private, dimension(2), save :: tcxc,tcxl
+#if defined(MPI) || defined(SHMEM)
+c
+c --- private message passing data structures, see xcspmd
+ integer, private, save :: idproc( 0: iqr+1,0:jqr+1),
+ & idproc1(0:ijqr+1),idhalo(2),
+ & i0_pe(iqr,jqr),ii_pe(iqr,jqr),
+ & j0_pe(iqr,jqr),jj_pe(iqr,jqr),
+ & mpe_1( jqr),
+ & mpe_e( jqr),
+ & mpe_i(itdm,jqr),npe_j(jtdm)
+ integer, private, save :: i1sum(iqr,jqr),iisum(iqr,jqr)
+ integer, private, save :: m0_top,i0_st(iqr),ii_st(iqr),
+ & mm_top,i0_gt(iqr),ii_gt(iqr),
+ & m0_bot,i0_sb(iqr),ii_sb(iqr),
+ & mm_bot,i0_gb(iqr),ii_gb(iqr)
+ integer, private, save :: null_tile
+#endif
+#if defined(MPI)
+ integer, private, save :: mpi_comm_hycom
+#endif
+c
+c --- actual module subroutines
+ contains
+#if defined(MPI) || defined(SHMEM)
+# include "mod_xc_mp.h"
+#else
+# include "mod_xc_sm.h"
+#endif
+ end module mod_xc
diff --git a/src_2.2.18_3_one/mod_xc_mp.h b/src_2.2.18_3_one/mod_xc_mp.h
new file mode 100755
index 0000000..ec61063
--- /dev/null
+++ b/src_2.2.18_3_one/mod_xc_mp.h
@@ -0,0 +1,4449 @@
+
+/* BARRIER set a barrier; for SPMD versions */
+#if defined(MPI)
+# define BARRIER call mpi_barrier(mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+# define BARRIER call shmem_barrier_all()
+#endif
+
+/* BARRIER_MP halo synchronization; SHMEM only */
+/* BARRIER_NP halo synchronization; SHMEM only */
+#if defined(RINGB)
+#define BARRIER_MP call xctbar(idproc(mproc-1,nproc),idproc(mproc+1,nproc))
+#define BARRIER_NP call xctbar(idproc(mproc,nproc-1),idproc(mproc,nproc+1))
+#else
+#define BARRIER_MP BARRIER
+#define BARRIER_NP BARRIER
+#endif
+
+#if defined(MPI)
+/* #define MPISR */
+/* MTYPE4 mpi type for real*4 */
+/* MTYPER mpi type for real */
+/* MTYPED mpi type for real*8 */
+/* MTYPEI mpi type for integer */
+/* MPI_SEND either mpi_send or mpi_ssend */
+/* MPI_ISEND either mpi_isend or mpi_issend */
+#if defined(NOMPIR8) /* LAM does not support mpi_real[48] */
+#if defined(REAL4)
+# define MTYPE4 mpi_real
+# define MTYPER mpi_real
+# define MTYPED mpi_double_precision
+# define MTYPEI mpi_integer
+#else /* REAL8 */
+# define MTYPE4 mpi_real
+# define MTYPER mpi_double_precision
+# define MTYPED mpi_double_precision
+# define MTYPEI mpi_integer
+#endif
+#else /* most MPI's allow mpi_real[48] */
+#if defined(REAL4)
+# define MTYPE4 mpi_real4
+# define MTYPER mpi_real4
+# define MTYPED mpi_real8
+# define MTYPEI mpi_integer
+#else /* REAL8 */
+# define MTYPE4 mpi_real4
+# define MTYPER mpi_real8
+# define MTYPED mpi_real8
+# define MTYPEI mpi_integer
+#endif
+#endif
+#if defined(SSEND)
+# define MPI_SEND mpi_ssend
+# define MPI_ISEND mpi_issend
+#else
+# define MPI_SEND mpi_send
+# define MPI_ISEND mpi_isend
+#endif /* SSEND:else */
+#endif /* MPI */
+
+#if defined(SHMEM)
+/* SHMEM_GET4 get real*4 variables */
+/* SHMEM_GETR get real variables */
+/* SHMEM_GETD get real*8 variables */
+/* SHMEM_GETI get integer variables */
+/* SHMEM_MYPE return number of this PE (0...npes-1) */
+/* SHMEM_NPES return number of PEs */
+#if defined(REAL4)
+# define SHMEM_GET4 shmem_get32
+# define SHMEM_GETR shmem_get32
+# define SHMEM_GETD shmem_get64
+# define SHMEM_GETI shmem_integer_get
+#else /* REAL8 */
+# define SHMEM_GET4 shmem_get32
+# define SHMEM_GETR shmem_get64
+# define SHMEM_GETD shmem_get64
+# define SHMEM_GETI shmem_integer_get
+#endif
+# define SHMEM_MYPE shmem_my_pe
+# define SHMEM_NPES shmem_n_pes
+#endif /* SHMEM */
+
+c
+c-----------------------------------------------------------------------
+c
+c auxillary routines that involve off-processor communication.
+c message passing version, contained in module mod_xc.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine xcaget(aa, a, mnflg)
+ implicit none
+c
+ real, intent(out) :: aa(itdm,jtdm)
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from tiled to non-tiled layout.
+c
+c 3) mnflg selects which nodes must return the array
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real output non-tiled target array
+c a real input tiled source array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+ real al,at
+ common/xcagetr/ al(itdm,jdm),at(idm*jdm)
+ save /xcagetr/
+c
+ integer i,j,mp,np,mnp
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 1)
+ nxc = 1
+ endif
+#endif
+c
+c gather each row of tiles onto the first tile in the row.
+c
+#if defined(MPI)
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,i0
+ al(i,j) = vland
+ enddo
+ do i= 1,ii
+ al(i0+i,j) = a(i,j)
+ enddo
+ do i= i0+ii+1,itdm
+ al(i,j) = vland
+ enddo
+ enddo
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ call MPI_RECV(at,ii_pe(mp,nproc)*jj,MTYPER,
+ & idproc(mp,nproc), 9941,
+ & mpi_comm_hycom, mpistat, mpierr)
+ do j= 1,jj
+ do i= 1,ii_pe(mp,nproc)
+ al(i0_pe(mp,nproc)+i,j) = at(i+(j-1)*ii_pe(mp,nproc))
+ enddo
+ enddo
+ enddo
+ else !mproc>1
+ do j= 1,jj
+ do i= 1,ii
+ at(i+(j-1)*ii) = a(i,j)
+ enddo
+ enddo
+ call MPI_SEND(at,ii*jj,MTYPER,
+ & idproc(mpe_1(nproc),nproc), 9941,
+ & mpi_comm_hycom, mpierr)
+ endif
+#elif defined(SHMEM)
+ do j= 1,jj
+ do i= 1,ii
+ at(i+(j-1)*ii) = a(i,j)
+ enddo
+ enddo
+ BARRIER
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,i0
+ al(i,j) = vland
+ enddo
+ do i= 1,ii
+ al(i0+i,j) = a(i,j)
+ enddo
+ do i= i0+ii+1,itdm
+ al(i,j) = vland
+ enddo
+ enddo
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ call SHMEM_GETR(at,
+ & at,ii_pe(mp,nproc)*jj, idproc(mp,nproc))
+ do j= 1,jj
+ do i= 1,ii_pe(mp,nproc)
+ al(i0_pe(mp,nproc)+i,j) = at(i+(j-1)*ii_pe(mp,nproc))
+ enddo
+ enddo
+ enddo
+ endif
+ BARRIER
+#endif /* MPI:SHMEM */
+c
+c gather each row of tiles onto the output array.
+c
+#if defined(MPI)
+ mnp = max(mnflg,1)
+c
+ if (mnproc.eq.mnp) then
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,itdm
+ aa(i,j+j0) = al(i,j)
+ enddo
+ enddo
+ endif
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (idproc(mp,np).ne.idproc(mproc,nproc)) then
+ call MPI_RECV(al,itdm*jj_pe(mp,np),MTYPER,
+ & idproc(mp,np), 9942,
+ & mpi_comm_hycom, mpistat, mpierr)
+ do j= 1,jj_pe(mp,np)
+ do i= 1,itdm
+ aa(i,j+j0_pe(mp,np)) = al(i,j)
+ enddo
+ enddo
+ endif
+ enddo
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_SEND(al,itdm*jj,MTYPER,
+ & idproc1(mnp), 9942,
+ & mpi_comm_hycom, mpierr)
+ endif
+c
+ if (mnflg.eq.0) then
+ call mpi_bcast(aa,itdm*jtdm,MTYPER,
+ & idproc1(1),mpi_comm_hycom,mpierr)
+ endif
+#elif defined(SHMEM)
+ if (mnflg.eq.0 .or. mnproc.eq.mnflg) then
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,itdm
+ aa(i,j+j0) = al(i,j)
+ enddo
+ enddo
+ endif
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (idproc(mp,np).ne.idproc(mproc,nproc)) then
+ call SHMEM_GETR(al,
+ & al,itdm*jj_pe(mp,np), idproc(mp,np))
+ do j= 1,jj_pe(mp,np)
+ do i= 1,itdm
+ aa(i,j+j0_pe(mp,np)) = al(i,j)
+ enddo
+ enddo
+ endif
+ enddo
+ endif
+ ! no barrier needed here because of double buffering (at and then al)
+#endif /* MPI:SHMEM */
+#if defined(TIMER)
+c
+ if (nxc.eq. 1) then
+ call xctmr1( 1)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcaget
+
+ subroutine xcaget4(aa, a, mnflg)
+ implicit none
+c
+ real*4, intent(out) :: aa(itdm,jtdm)
+ real*4, intent(in) :: a(ii,jj)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from tiled to non-tiled layout.
+c
+c 2) Special version for zaiord and zaiowr only.
+c arrays are real*4 and tiled array has no halo.
+c
+c 3) mnflg selects which nodes must return the array
+c =-1; first node in each row returns that row
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real output non-tiled target array
+c a real input tiled source array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+ real al8,at8
+ common/xcagetr/ al8(itdm,jdm),at8(idm*jdm)
+ save /xcagetr/
+c
+ real*4 al4(itdm,jdm), at4(idm*jdm)
+ equivalence (al4(1,1),al8(1,1)), (at4(1),at8(1))
+c
+ integer i,j,mp,np,mnp
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 1)
+ nxc = 1
+ endif
+#endif
+c
+c gather each row of tiles onto the first tile in the row.
+c
+#if defined(MPI)
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,i0
+ al4(i,j) = vland4
+ enddo
+ do i= 1,ii
+ al4(i0+i,j) = a(i,j)
+ enddo
+ do i= i0+ii+1,itdm
+ al4(i,j) = vland4
+ enddo
+ enddo
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ call MPI_RECV(at4,ii_pe(mp,nproc)*jj,MTYPE4,
+ & idproc(mp,nproc), 9941,
+ & mpi_comm_hycom, mpistat, mpierr)
+ do j= 1,jj
+ do i= 1,ii_pe(mp,nproc)
+ al4(i0_pe(mp,nproc)+i,j) = at4(i+(j-1)*ii_pe(mp,nproc))
+ enddo
+ enddo
+ enddo
+ else !mproc>1
+ call MPI_SEND(a,ii*jj,MTYPE4,
+ & idproc(mpe_1(nproc),nproc), 9941,
+ & mpi_comm_hycom, mpierr)
+ endif
+#elif defined(SHMEM)
+ do j= 1,jj
+ do i= 1,ii
+ at4(i+(j-1)*ii) = a(i,j)
+ enddo
+ enddo
+ BARRIER
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,i0
+ al4(i,j) = vland4
+ enddo
+ do i= 1,ii
+ al4(i0+i,j) = a(i,j)
+ enddo
+ do i= i0+ii+1,itdm
+ al4(i,j) = vland4
+ enddo
+ enddo
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ call SHMEM_GET4(at4,
+ & at4,ii_pe(mp,nproc)*jj, idproc(mp,nproc))
+ do j= 1,jj
+ do i= 1,ii_pe(mp,nproc)
+ al4(i0_pe(mp,nproc)+i,j) = at4(i+(j-1)*ii_pe(mp,nproc))
+ enddo
+ enddo
+ enddo
+ endif
+ BARRIER
+#endif /* MPI:SHMEM */
+ if (mnflg.eq.-1) then
+c
+c we are essentially done.
+c
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,itdm
+ aa(i,j+j0) = al4(i,j)
+ enddo
+ enddo
+ endif
+ else !mnflg.ne.-1
+c
+c gather each row of tiles onto the output array.
+c
+#if defined(MPI)
+ mnp = max(mnflg,1)
+c
+ if (mnproc.eq.mnp) then
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,itdm
+ aa(i,j+j0) = al4(i,j)
+ enddo
+ enddo
+ endif
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (idproc(mp,np).ne.idproc(mproc,nproc)) then
+ call MPI_RECV(al4,itdm*jj_pe(mp,np),MTYPE4,
+ & idproc(mp,np), 9942,
+ & mpi_comm_hycom, mpistat, mpierr)
+ do j= 1,jj_pe(mp,np)
+ do i= 1,itdm
+ aa(i,j+j0_pe(mp,np)) = al4(i,j)
+ enddo
+ enddo
+ endif
+ enddo
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_SEND(al4,itdm*jj,MTYPE4,
+ & idproc1(mnp), 9942,
+ & mpi_comm_hycom, mpierr)
+ endif
+c
+ if (mnflg.eq.0) then
+ call mpi_bcast(aa,itdm*jtdm,MTYPE4,
+ & idproc1(1),mpi_comm_hycom,mpierr)
+ endif
+#elif defined(SHMEM)
+ if (mnflg.eq.0 .or. mnproc.eq.mnflg) then
+ if (mproc.eq.mpe_1(nproc)) then
+ do j= 1,jj
+ do i= 1,itdm
+ aa(i,j+j0) = al4(i,j)
+ enddo
+ enddo
+ endif
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (idproc(mp,np).ne.idproc(mproc,nproc)) then
+ call SHMEM_GET4(al4,
+ & al4,itdm*jj_pe(mp,np), idproc(mp,np))
+ do j= 1,jj_pe(mp,np)
+ do i= 1,itdm
+ aa(i,j+j0_pe(mp,np)) = al4(i,j)
+ enddo
+ enddo
+ endif
+ enddo
+ endif
+ ! no barrier needed here because of double buffering (at and then al)
+#endif /* MPI:SHMEM */
+ endif !mnflg.eq.-1:else
+#if defined(TIMER)
+c
+ if (nxc.eq. 1) then
+ call xctmr1( 1)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcaget4
+
+ subroutine xcaput(aa, a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: aa(itdm,jtdm)
+ real, intent(out) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from non-tiled to tiled layout.
+c
+c 3) mnflg selects which nodes must contain the non-tiled array
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c if mnflg.ne.0 the array aa may be broadcast to all nodes,
+c so aa must exist and be overwritable on all nodes.
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real input non-tiled source array
+c a real output tiled target array
+c mnflg integer input node source flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ integer mpireqa(jpr),mpireqb(ipr)
+#endif
+ real al,at
+ common/xcagetr/ al(itdm,jdm),at(idm*jdm)
+ save /xcagetr/
+c
+ integer i,j,mp,np,mnp
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ BARRIER
+ call xctmr0( 4)
+ nxc = 4
+ endif
+#endif
+*
+* if (mnproc.eq.1) then
+* write(lp,'(a,g20.10)') 'xcaput - vland =',vland
+* endif
+c
+c use xclput for now,
+c this is slow for mnflg.ne.0, but easy to implement.
+c
+ if (mnflg.ne.0) then
+c "broadcast" row sections of aa to all processors in the row.
+ if (mnproc.ne.mnflg) then
+ aa(:,:) = vland
+ endif
+#if defined(MPI)
+ if (mnproc.eq.mnflg) then
+ j = 0
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (np.eq.nproc .and. mp.eq.mproc) then
+ al(:,1:jj) = aa(:,j0+1:j0+jj)
+ else
+ j = j + 1
+ call MPI_ISEND(aa(1,j0_pe(mp,np)+1),
+ & itdm*jj_pe(mp,np),MTYPER,
+ & idproc(mp,np), 9951,
+ & mpi_comm_hycom, mpireqa(j), mpierr)
+ endif
+ enddo
+ call mpi_waitall( j, mpireqa, mpistat, mpierr)
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_RECV(al,itdm*jj,MTYPER,
+ & idproc1(mnflg), 9951,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+c
+ if (mproc.eq.mpe_1(nproc)) then
+ i = 0
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ i = i + 1
+ call MPI_ISEND(al,itdm*jj,MTYPER,
+ & idproc(mp,nproc), 9952,
+ & mpi_comm_hycom, mpireqb(i), mpierr)
+ enddo
+ call mpi_waitall( i, mpireqb, mpistat, mpierr)
+ else
+ call MPI_RECV(al,itdm*jj,MTYPER,
+ & idproc(mpe_1(nproc),nproc), 9952,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+c
+ aa(:,j0+1:j0+jj) = al(:,1:jj)
+#elif defined(SHMEM)
+c assume aa is in common.
+ BARRIER
+ if (mnproc.ne.mnflg) then
+ do j= 1,jj
+ call SHMEM_GETR(aa(1,j0+j),
+ & aa(1,j0+j),itdm,idproc1(mnflg))
+ enddo
+ endif
+ BARRIER
+#endif
+ endif
+ do j= 1,jtdm
+ call xclput(aa(1,j),itdm, a, 1,j,1,0)
+ enddo
+#if defined(TIMER)
+c
+ if (nxc.eq. 4) then
+ call xctmr1( 4)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcaput
+
+ subroutine xcaput4(aa, a, mnflg)
+ implicit none
+c
+ real*4, intent(inout) :: aa(itdm,jtdm)
+ real*4, intent(out) :: a(ii,jj)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from non-tiled to tiled layout.
+c
+c 2) Special version for zaiord and zaiowr only.
+c arrays are real*4 and tiled array has no halo.
+c
+c 3) mnflg selects which nodes must contain the non-tiled array
+c =-1; first node in each row contains that row
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c if mnflg.ne.0 the array aa may be broadcast to all nodes,
+c so aa must exist and be overwritable on all nodes.
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real input non-tiled source array
+c a real output tiled target array
+c mnflg integer input node source flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ integer mpireqa(jpr),mpireqb(ipr)
+#endif
+ real al8,at8
+ common/xcagetr/ al8(itdm,jdm),at8(idm*jdm)
+ save /xcagetr/
+c
+ real*4 al4(itdm,jdm), at4(idm*jdm)
+ equivalence (al4(1,1),al8(1,1)), (at4(1),at8(1))
+c
+ integer i,j,mp,np,mnp
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ BARRIER
+ call xctmr0( 4)
+ nxc = 4
+ endif
+#endif
+*
+* if (mnproc.eq.1) then
+* write(lp,'(a,g20.10)') 'xcaput - vland =',vland
+* endif
+c
+c use xclput for now,
+c this is slow for mnflg.ne.0, but easy to implement.
+c
+ if (mnflg.gt.0) then
+c "broadcast" row sections of aa to all processors in the row.
+ if (mnproc.ne.mnflg) then
+ aa(:,:) = vland4
+ endif
+#if defined(MPI)
+ if (mnproc.eq.mnflg) then
+ j = 0
+ do np= 1,jpr
+ mp = mpe_1(np)
+ if (np.eq.nproc .and. mp.eq.mproc) then
+ al4(:,1:jj) = aa(:,j0+1:j0+jj)
+ else
+ j = j + 1
+ call MPI_ISEND(aa(1,j0_pe(mp,np)+1),
+ & itdm*jj_pe(mp,np),MTYPE4,
+ & idproc(mp,np), 9951,
+ & mpi_comm_hycom, mpireqa(j), mpierr)
+ endif
+ enddo
+ call mpi_waitall( j, mpireqa, mpistat, mpierr)
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_RECV(al4,itdm*jj,MTYPE4,
+ & idproc1(mnflg), 9951,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+c
+ if (mproc.eq.mpe_1(nproc)) then
+ i = 0
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ i = i + 1
+ call MPI_ISEND(al4,itdm*jj,MTYPE4,
+ & idproc(mp,nproc), 9952,
+ & mpi_comm_hycom, mpireqb(i), mpierr)
+ enddo
+ call mpi_waitall( i, mpireqb, mpistat, mpierr)
+ else
+ call MPI_RECV(al4,itdm*jj,MTYPE4,
+ & idproc(mpe_1(nproc),nproc), 9952,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+c
+ aa(:,j0+1:j0+jj) = al4(:,1:jj)
+#elif defined(SHMEM)
+c assume aa is in common.
+ BARRIER
+ if (mnproc.ne.mnflg) then
+ call SHMEM_GET4(aa(1,j0+1),
+ & aa(1,j0+1),itdm*jj,idproc1(mnflg))
+ endif
+ BARRIER
+#endif
+ elseif (mnflg.eq.-1) then
+c "broadcast" row sections of aa to all processors in the row.
+#if defined(MPI)
+ if (mproc.eq.mpe_1(nproc)) then
+ i = 0
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ i = i + 1
+ call MPI_ISEND(aa(1,j0+1),itdm*jj,MTYPE4,
+ & idproc(mp,nproc), 9952,
+ & mpi_comm_hycom, mpireqb(i), mpierr)
+ enddo
+ call mpi_waitall( i, mpireqb, mpistat, mpierr)
+ else
+ call MPI_RECV(aa(1,j0+1),itdm*jj,MTYPE4,
+ & idproc(mpe_1(nproc),nproc), 9952,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+#elif defined(SHMEM)
+c assume aa is in common.
+ BARRIER
+ if (mproc.ne.mpe_1(nproc)) then
+ call SHMEM_GET4(aa(1,j0+1),
+ & aa(1,j0+1),itdm*jj,
+ & idproc(mpe_1(nproc),nproc))
+ endif
+ BARRIER
+#endif
+ endif !mnflg.gt.0:mnflg.eq.-1
+c
+ do j= 1,jtdm
+ call xclput4(aa(1,j),itdm, a, 1,j,1,0)
+ enddo
+#if defined(TIMER)
+c
+ if (nxc.eq. 4) then
+ call xctmr1( 4)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcaput4
+
+ subroutine xcastr(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) broadcast array a to all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node originator flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer nmax
+ parameter (nmax=1024)
+c
+ real b,c
+ common/xcmaxr4/ b(nmax),c(nmax)
+ save /xcmaxr4/
+c
+ integer i,is0,isl,mn,n,nn
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 9)
+ nxc = 9
+ endif
+#endif
+c
+c stripmine a.
+c
+ n = size(a)
+c
+ do is0= 0,n-1,nmax
+ isl = min(is0+nmax,n)
+ nn = isl - is0
+ if (mnproc.eq.mnflg) then
+ do i= 1,nn
+ b(i) = a(is0+i)
+ enddo
+ endif
+#if defined(MPI)
+ call mpi_bcast(b,nn,MTYPER,
+ & idproc1(mnflg),
+ & mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+ BARRIER
+ if (mnproc.ne.mnflg) then
+c get from source processor
+ call SHMEM_GETR(b,b,nn, idproc1(mnflg))
+ endif
+ BARRIER
+#endif
+ if (mnproc.ne.mnflg) then
+ do i= 1,nn
+ a(is0+i) = b(i)
+ enddo
+ endif
+ enddo ! stripmine loop
+#if defined(TIMER)
+c
+ if (nxc.eq. 9) then
+ call xctmr1( 9)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcastr
+
+ subroutine xceget(aelem, a, ia,ja)
+ implicit none
+c
+ real, intent(out) :: aelem
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: ia,ja
+c
+c**********
+c*
+c 1) find the value of a(ia,ja) on the non-tiled 2-D grid.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aelem real output required element
+c a real input source array
+c ia integer input 1st index into a
+c ja integer input 2nd index into a
+c
+c 3) the global variable vland is returned when outside active tiles.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+c double buffer to reduce the number of required barriers.
+c
+ real elem(0:1)
+ common/xcegetr/ elem
+ save /xcegetr/
+c
+ integer, save :: kdb = 0
+c
+ integer i,j,mp,np
+#if defined(TIMER)
+c
+* if (nxc.eq.0) then
+* call xctmr0( 2)
+* nxc = 2
+* endif
+#endif
+c
+ kdb = mod(kdb+1,2) ! the least recently used of the two buffers
+c
+c find the host tile.
+c
+ np = npe_j(ja)
+ mp = mpe_i(ia,np)
+c
+ if (mp.le.0) then
+c
+c no tile.
+c
+ elem(kdb) = vland
+ elseif (mp.eq.mproc .and. np.eq.nproc) then
+c
+c this tile.
+c
+ i = ia - i0
+ j = ja - j0
+c
+ elem(kdb) = a(i,j)
+#if defined(MPI)
+ call mpi_bcast(elem(kdb),1,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+ BARRIER
+#endif
+ else
+c
+c another tile.
+c
+#if defined(MPI)
+ call mpi_bcast(elem(kdb),1,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+ BARRIER
+ call SHMEM_GETR(elem(kdb),
+ & elem(kdb),1,idproc(mp,np))
+ ! no barrier needed here because of double buffering
+#endif
+ endif
+ aelem = elem(kdb)
+#if defined(TIMER)
+c
+* if (nxc.eq. 2) then
+* call xctmr1( 2)
+* nxc = 0
+* endif
+#endif
+ return
+ end subroutine xceget
+
+ subroutine xceput(aelem, a, ia,ja)
+ implicit none
+c
+ integer, intent(in) :: ia,ja
+ real, intent(in) :: aelem
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) fill a single element in the non-tiled 2-D grid.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aelem real input element value
+c a real in/out target array
+c ia integer input 1st index into a
+c ja integer input 2nd index into a
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer mp,np
+#if defined(TIMER)
+c
+* if (nxc.eq.0) then
+* call xctmr0( 5)
+* nxc = 5
+* endif
+#endif
+ if (i0.lt.ia .and. ia.le.i0+ii .and.
+ & j0.lt.ja .and. ja.le.j0+jj ) then
+c
+c this tile.
+c
+ a(ia-i0,ja-j0) = aelem
+ endif
+#if defined(TIMER)
+c
+* if (nxc.eq. 5) then
+* call xctmr1( 5)
+* nxc = 0
+* endif
+#endif
+ return
+ end subroutine xceput
+
+ subroutine xcgetc(iline)
+ implicit none
+c
+ integer, intent(inout) :: iline(81)
+c
+c**********
+c*
+c 1) machine specific routine for broadcasting iline.
+c
+c 2) only use in zagetc (hence the name).
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+c broadcast to all processors
+c
+#if defined(MPI)
+ call mpi_bcast(iline,81,MTYPEI,
+ & idproc1(1),mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+ BARRIER
+ if (mnproc.ne.1) then
+ call SHMEM_GETI(iline,
+ & iline,81, idproc1(1))
+ endif
+ ! no barrier needed here because zagetc is using two buffers
+#endif
+ return
+ end subroutine xcgetc
+
+ subroutine xchalt(cerror)
+ implicit none
+c
+ character*(*), intent(in) :: cerror
+c
+c**********
+c*
+c 1) stop all processes.
+c
+c 2) only one processes need call this routine, i.e. it is for
+c emergency stops. use 'xcstop' for ordinary stops called
+c by all processes.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c cerror char*(*) input error message
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+c message passing version.
+c
+ if (cerror.ne.' ') then
+ write(lp,*) '**************************************************'
+ write(lp,*) cerror
+ endif
+ write(lp,*) '**************************************************'
+ write(lp,*) 'XCHALT CALLED ON PROC = ',mnproc,mproc,nproc
+ write(lp,*) '**************************************************'
+ call flush(lp)
+c
+#if defined(MPI)
+ call mpi_abort(mpi_comm_hycom,9)
+#else
+ call abort()
+#endif
+ stop '(xchalt)'
+ end subroutine xchalt
+
+ subroutine xclget(aline,nl, a, i1,j1,iinc,jinc, mnflg)
+ implicit none
+c
+ integer, intent(in) :: nl,i1,j1,iinc,jinc,mnflg
+ real, intent(out) :: aline(nl)
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) extract a line of elements from the non-tiled 2-D grid.
+c
+c 2) aline(i) == aa(i1+iinc*(i-1),j1+jinc*(i-1)), for i=1...nl.
+c where aa is the non-tiled representation of a, and
+c iinc and jinc can each be -1, 0, or +1.
+c
+c 3) mnflg selects which nodes must return the line
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aline real output required line of elements
+c nl integer input dimension of aline
+c a real input source array
+c i1 integer input 1st index into a
+c j1 integer input 2nd index into a
+c iinc integer input 1st index increment
+c jinc integer input 2nd index increment
+c mnflg integer input node return flag
+c
+c 5) the global variable vland is returned when outside active tiles.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+c pad al to guard against false sharing.
+c double buffer to reduce the number of required barriers.
+c
+ real al
+ common/xclgetr/ al(-47:itdm+jtdm+48,0:1)
+ save /xclgetr/
+c
+ integer, save :: kdb = 0
+c
+ real dummy
+ integer i1n,iif,iil,j1n,jjf,jjl,l,lx0,nxl,mp,np
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 3)
+ nxc = 3
+ endif
+#endif
+c
+ kdb = mod(kdb+1,2) ! the least recently used of the two buffers
+c
+ if ((jinc.eq.0 .and. iinc.eq.1) .or. nl.eq.1) then
+c
+c --- horizontal forward line.
+c
+ al(1:nl,kdb) = vland
+c
+ np = npe_j(j1)
+ do mp= mpe_1(np),mpe_e(np)
+ iif = max(i1, i0_pe(mp,np)+1)
+ iil = min(i1+nl-1,i0_pe(mp,np)+ii_pe(mp,np))
+ lx0 = iif - i1
+ nxl = iil - iif + 1
+ if (nxl.le.0) then
+ cycle ! no elements from tile (mp,np)
+ endif
+c
+ if (mp.eq.mproc .and. np.eq.nproc) then
+c
+c this tile.
+c
+ do l= lx0+1,lx0+nxl
+ al(l,kdb) = a(i1+l-1-i0,j1-j0)
+ enddo
+#if defined(MPI)
+ if (mnflg.eq.0) then
+ call mpi_bcast(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+ elseif (mnflg.ne.mnproc) then
+ call MPI_SEND(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc1(mnflg), 9931,
+ & mpi_comm_hycom, mpierr)
+ endif
+ else
+c
+c another tile.
+c
+ if (mnflg.eq.0) then
+ call mpi_bcast(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+ elseif (mnflg.eq.mnproc) then
+ call MPI_RECV(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np), 9931,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+#endif /* MPI */
+ endif
+c
+ if (lx0+nxl.eq.nl) then
+ exit
+ endif
+ enddo ! np=1,jpr
+#if defined(SHMEM)
+c
+c spliting process into two phases saves on barriers.
+c
+ BARRIER
+ do mp= mpe_1(np),mpe_e(np)
+ iif = max(i1, i0_pe(mp,np)+1)
+ iil = min(i1+nl-1,i0_pe(mp,np)+ii_pe(mp,np))
+ lx0 = iif - i1
+ nxl = iil - iif + 1
+ if (nxl.le.0) then
+ cycle ! no elements from tile (mp,np)
+ endif
+c
+ if (mp.eq.mproc .and. np.eq.nproc) then
+c
+c nothing to do here (see 1st phase, above).
+c
+ else
+c
+c another tile.
+c
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ call SHMEM_GETR(al(lx0+1,kdb),
+ & al(lx0+1,kdb),nxl,idproc(mp,np))
+ endif
+ endif
+c
+ if (lx0+nxl.eq.nl) then
+ exit
+ endif
+ enddo ! np=1,jpr
+ ! no barrier needed here because of double buffering
+#endif /* SHMEM */
+c
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ aline(1:nl) = al(1:nl,kdb)
+ endif
+ elseif (iinc.eq.0 .and. jinc.eq.1) then
+c
+c --- vertical forward line.
+c
+ al(1:nl,kdb) = vland
+c
+ do np= 1,jpr
+ mp = mpe_i(i1,np)
+ if (mp.le.0) then
+ cycle ! an all-land column
+ endif
+ jjf = max(j1, j0_pe(mp,np)+1)
+ jjl = min(j1+nl-1,j0_pe(mp,np)+jj_pe(mp,np))
+ lx0 = jjf - j1
+ nxl = jjl - jjf + 1
+ if (nxl.le.0) then
+ cycle ! no elements from tile (mp,np)
+ endif
+c
+ if (mp.eq.mproc .and. np.eq.nproc) then
+c
+c this tile.
+c
+ do l= lx0+1,lx0+nxl
+ al(l,kdb) = a(i1-i0,j1+l-1-j0)
+ enddo
+#if defined(MPI)
+ if (mnflg.eq.0) then
+ call mpi_bcast(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+ elseif (mnflg.ne.mnproc) then
+ call MPI_SEND(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc1(mnflg), 9931,
+ & mpi_comm_hycom, mpierr)
+ endif
+ else
+c
+c another tile.
+c
+ if (mnflg.eq.0) then
+ call mpi_bcast(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np),mpi_comm_hycom,mpierr)
+ elseif (mnflg.eq.mnproc) then
+ call MPI_RECV(al(lx0+1,kdb),nxl,MTYPER,
+ & idproc(mp,np), 9931,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+#endif /* MPI */
+ endif
+c
+ if (lx0+nxl.eq.nl) then
+ exit
+ endif
+ enddo ! np=1,jpr
+#if defined(SHMEM)
+c
+c spliting process into two phases saves on barriers.
+c
+ BARRIER
+ do np= 1,jpr
+ mp = mpe_i(i1,np)
+ if (mp.le.0) then
+ cycle ! an all-land column
+ endif
+ jjf = max(j1, j0_pe(mp,np)+1)
+ jjl = min(j1+nl-1,j0_pe(mp,np)+jj_pe(mp,np))
+ lx0 = jjf - j1
+ nxl = jjl - jjf + 1
+ if (nxl.le.0) then
+ cycle ! no elements from tile (mp,np)
+ endif
+c
+ if (mp.eq.mproc .and. np.eq.nproc) then
+c
+c nothing to do here (see 1st phase, above).
+c
+ else
+c
+c another tile.
+c
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ call SHMEM_GETR(al(lx0+1,kdb),
+ & al(lx0+1,kdb),nxl,idproc(mp,np))
+ endif
+ endif
+c
+ if (lx0+nxl.eq.nl) then
+ exit
+ endif
+ enddo ! np=1,jpr
+ ! no barrier needed here because of double buffering
+#endif /* SHMEM */
+c
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ aline(1:nl) = al(1:nl,kdb)
+ endif
+ else
+c
+c diagonal and reversing lines - repeatedly call xceget.
+c this always works, but is very slow.
+c
+ do l= 1,nl
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ call xceget(aline(l), a, i1+iinc*(l-1),j1+jinc*(l-1))
+ else
+ call xceget(dummy, a, i1+iinc*(l-1),j1+jinc*(l-1))
+ endif
+ enddo
+ endif
+#if defined(TIMER)
+c
+ if (nxc.eq. 3) then
+ call xctmr1( 3)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xclget
+
+ subroutine xclput(aline,nl, a, i1,j1,iinc,jinc)
+ implicit none
+c
+ integer, intent(in) :: nl,i1,j1,iinc,jinc
+ real, intent(in) :: aline(nl)
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) fill a line of elements in the non-tiled 2-D grid.
+c
+c 2) aline(i) == aa(i1+i1*(i-1),j1+j1*(i-1)), for i=1...nl.
+c where aa is the non-tiled representation of a, and
+c one of iinc and jinc must be 0, and the other must be 1.
+c also updates the halo.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aline real input line of element values
+c nl integer input dimension of aline
+c a real in/out target array
+c i1 integer input 1st index into a
+c j1 integer input 2nd index into a
+c iinc integer input 1st index increment
+c jinc integer input 2nd index increment
+c*
+c**********
+c
+ integer i,j
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 5)
+ nxc = 5
+ endif
+#endif
+c
+ if (jinc.eq.0) then
+ if (j1-j0.ge.1-nbdy .and. j1-j0.le.jj+nbdy) then
+ do i= max(1-nbdy,i1-i0),min(i1-i0+nl-1,ii+nbdy)
+ a(i,j1-j0) = aline(i+i0-i1+1)
+ enddo
+ if (nreg.ne.0 .and.
+ & i0.eq.0 .and. i1+nl-1.ge.itdm-nbdy+1) then ! periodic
+ do i= max(itdm-nbdy+1,i1),i1+nl-1
+ a(i-itdm,j1-j0) = aline(i)
+ enddo
+ endif
+ if (nreg.ne.0 .and.
+ & i0+ii.eq.itdm .and. i1.le.nbdy) then ! periodic
+ do i= i1,min(nbdy,i1+nl-1)
+ a(ii+i,j1-j0) = aline(i)
+ enddo
+ endif
+ endif
+ elseif (iinc.eq.0) then
+ if (i1-i0.ge.1-nbdy .and. i1-i0.le.ii+nbdy) then
+ do j= max(1-nbdy,j1-j0),min(j1-j0+nl-1,jj+nbdy)
+ a(i1-i0,j) = aline(j+j0-j1+1)
+ enddo
+ endif
+ if (nreg.ne.0 .and.
+ & i0.eq.0 .and. i1.ge.itdm-nbdy+1) then ! periodic
+ do j= max(1-nbdy,j1-j0),min(j1-j0+nl-1,jj+nbdy)
+ a(i1-itdm,j) = aline(j+j0-j1+1)
+ enddo
+ endif
+ if (nreg.ne.0 .and.
+ & i0+ii.eq.itdm .and. i1.le.nbdy) then ! periodic
+ do j= max(1-nbdy,j1-j0),min(j1-j0+nl-1,jj+nbdy)
+ a(ii+i1,j) = aline(j+j0-j1+1)
+ enddo
+ endif
+ endif
+#if defined(TIMER)
+c
+ if (nxc.eq. 5) then
+ call xctmr1( 5)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xclput
+
+ subroutine xclput4(aline,nl, a, i1,j1,iinc,jinc)
+ implicit none
+c
+ integer, intent(in) :: nl,i1,j1,iinc,jinc
+ real*4, intent(in) :: aline(nl)
+ real*4, intent(inout) :: a(ii,jj)
+c
+c**********
+c*
+c 1) fill a line of elements in the non-tiled 2-D grid.
+c Special version for xcaput4 only.
+c
+c 2) aline(i) == aa(i1+i1*(i-1),j1+j1*(i-1)), for i=1...nl.
+c where aa is the non-tiled representation of a, and
+c one of iinc and jinc must be 0, and the other must be 1.
+c also updates the halo.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aline real input line of element values
+c nl integer input dimension of aline
+c a real in/out target array
+c i1 integer input 1st index into a
+c j1 integer input 2nd index into a
+c iinc integer input 1st index increment
+c jinc integer input 2nd index increment
+c*
+c**********
+c
+ integer i,j
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 5)
+ nxc = 5
+ endif
+#endif
+c
+ if (jinc.eq.0) then
+ if (j1-j0.ge.1 .and. j1-j0.le.jj) then
+ do i= max(1,i1-i0),min(i1-i0+nl-1,ii)
+ a(i,j1-j0) = aline(i+i0-i1+1)
+ enddo
+ if (nreg.ne.0 .and.
+ & i0.eq.0 .and. i1+nl-1.ge.itdm+1) then ! periodic
+ do i= max(itdm+1,i1),i1+nl-1
+ a(i-itdm,j1-j0) = aline(i)
+ enddo
+ endif
+ endif
+ elseif (iinc.eq.0) then
+ if (i1-i0.ge.1 .and. i1-i0.le.ii) then
+ do j= max(1,j1-j0),min(j1-j0+nl-1,jj)
+ a(i1-i0,j) = aline(j+j0-j1+1)
+ enddo
+ endif
+ if (nreg.ne.0 .and.
+ & i0.eq.0 .and. i1.ge.itdm+1) then ! periodic
+ do j= max(1,j1-j0),min(j1-j0+nl-1,jj)
+ a(i1-itdm,j) = aline(j+j0-j1+1)
+ enddo
+ endif
+ endif
+#if defined(TIMER)
+c
+ if (nxc.eq. 5) then
+ call xctmr1( 5)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xclput4
+
+ subroutine xcmaxr_0(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise maximum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c mnflg integer input node return flag
+c*
+c**********
+c
+ real a1(1)
+c
+ a1(1) = a
+ call xcmaxr_1(a1, mnflg)
+ a = a1(1)
+ return
+ end subroutine xcmaxr_0
+
+ subroutine xcmaxr_1(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace array a with its element-wise maximum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer nmax
+ parameter (nmax=1024)
+c
+ real b,c
+ common/xcmaxr4/ b(nmax),c(nmax)
+ save /xcmaxr4/
+c
+ integer i,is0,isl,mn,mnp,n,nn
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0(10)
+ nxc = 10
+ endif
+#endif
+c
+c stripmine a.
+c
+ n = size(a)
+c
+ do is0= 0,n-1,nmax
+ isl = min(is0+nmax,n)
+ nn = isl - is0
+ do i= 1,nn
+ b(i) = a(is0+i)
+ enddo
+c
+#if defined(MPI)
+ if (mnflg.eq.0) then
+ call mpi_allreduce(b,c,nn,MTYPER,mpi_max,
+ & mpi_comm_hycom,mpierr)
+ else
+ call mpi_reduce( b,c,nn,MTYPER,mpi_max,
+ & idproc1(mnflg),
+ & mpi_comm_hycom,mpierr)
+ endif
+#elif defined(SHMEM)
+ BARRIER
+ mnp = max(1,mnflg)
+ if (mnproc.eq.mnp) then
+c form global maximum on one processor
+ do i= 1,nn
+ c(i) = b(i)
+ enddo
+ do mn= 1,ijpr
+ if (mn.ne.mnp) then
+ call SHMEM_GETR(b,b,nn, idproc1(mn))
+ do i= 1,nn
+ c(i) = max(c(i),b(i))
+ enddo
+ endif !.ne.mnp
+ enddo
+ BARRIER
+ elseif (mnflg.eq.0) then
+c get global maximum from 1st processor
+ BARRIER
+ call SHMEM_GETR(c,c,nn, idproc1(mnp))
+ endif
+ ! no barrier needed here because using two buffers (b and c)
+#endif
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ do i= 1,nn
+ a(is0+i) = c(i)
+ enddo
+ endif
+ enddo ! stripmine loop
+#if defined(TIMER)
+c
+ if (nxc.eq.10) then
+ call xctmr1(10)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcmaxr_1
+
+ subroutine xcmaxr_0o(a)
+ implicit none
+c
+ real, intent(inout) :: a
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise maximum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c*
+c**********
+c
+ integer mnflg
+ real a1(1)
+c
+ mnflg = 0 !all nodes
+ a1(1) = a
+ call xcmaxr_1(a1, mnflg)
+ a = a1(1)
+ return
+ end subroutine xcmaxr_0o
+
+ subroutine xcmaxr_1o(a)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+c
+c**********
+c*
+c 1) replace array a with its element-wise maximum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c*
+c**********
+c
+ integer mnflg
+c
+ mnflg = 0 !all nodes
+ call xcmaxr_1(a, mnflg)
+ return
+ end subroutine xcmaxr_1o
+
+ subroutine xcminr_0(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise minimum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c mnflg integer input node return flag
+c*
+c**********
+c
+ real a1(1)
+c
+ a1(1) = a
+ call xcminr_1(a1, mnflg)
+ a = a1(1)
+ return
+ end subroutine xcminr_0
+
+ subroutine xcminr_1(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace array a with its element-wise minimum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer nmax
+ parameter (nmax=1024)
+c
+ real b,c
+ common/xcmaxr4/ b(nmax),c(nmax)
+ save /xcmaxr4/
+c
+ integer i,is0,isl,mn,mnp,n,nn
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0(10)
+ nxc = 10
+ endif
+#endif
+c
+c stripmine a.
+c
+ n = size(a)
+c
+ do is0= 0,n-1,nmax
+ isl = min(is0+nmax,n)
+ nn = isl - is0
+ do i= 1,nn
+ b(i) = a(is0+i)
+ enddo
+c
+#if defined(MPI)
+ if (mnflg.eq.0) then
+ call mpi_allreduce(b,c,nn,MTYPER,mpi_min,
+ & mpi_comm_hycom,mpierr)
+ else
+ call mpi_reduce( b,c,nn,MTYPER,mpi_min,
+ & idproc1(mnflg),
+ & mpi_comm_hycom,mpierr)
+ endif
+#elif defined(SHMEM)
+ BARRIER
+ mnp = max(1,mnflg)
+ if (mnproc.eq.mnp) then
+c form global minimum on one processor
+ do i= 1,nn
+ c(i) = b(i)
+ enddo
+ do mn= 1,ijpr
+ if (mn.ne.mnp) then
+ call SHMEM_GETR(b,b,nn, idproc1(mn))
+ do i= 1,nn
+ c(i) = min(c(i),b(i))
+ enddo
+ endif !.ne.mnp
+ enddo
+ BARRIER
+ elseif (mnflg.eq.0) then
+c get global minimum from 1st processor
+ BARRIER
+ call SHMEM_GETR(c,c,nn, idproc1(mnp))
+ endif
+ ! no barrier needed here because using two buffers (b and c)
+#endif
+ if (mnflg.eq.0 .or. mnflg.eq.mnproc) then
+ do i= 1,nn
+ a(is0+i) = c(i)
+ enddo
+ endif
+ enddo
+#if defined(TIMER)
+c
+ if (nxc.eq.10) then
+ call xctmr1(10)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcminr_1
+
+ subroutine xcminr_0o(a)
+ implicit none
+c
+ real, intent(inout) :: a
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise minimum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c*
+c**********
+c
+ integer mnflg
+ real a1(1)
+c
+ mnflg = 0 !all nodes
+ a1(1) = a
+ call xcminr_1(a1, mnflg)
+ a = a1(1)
+ return
+ end subroutine xcminr_0o
+
+ subroutine xcminr_1o(a)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+c
+c**********
+c*
+c 1) replace array a with its element-wise minimum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c*
+c**********
+c
+ integer mnflg
+c
+ mnflg = 0 !all nodes
+ call xcminr_1(a, mnflg)
+ return
+ end subroutine xcminr_1o
+
+#if defined(USE_ESMF)
+ subroutine xcspmd(mpi_comm_vm)
+ implicit none
+c
+ integer mpi_comm_vm
+#else
+ subroutine xcspmd
+#if defined(USE_CCSM3)
+ use ccsm3
+ use ccsm3_io
+#endif
+ implicit none
+#endif
+c
+c**********
+c*
+c 1) initialize data structures that identify the tiles.
+c
+c 2) data structures (public):
+c ipr - 1st 2-D node dimension (<=iqr)
+c jpr - 2nd 2-D node dimension (<=jqr)
+c ijpr - 1-D node dimension (ipr*jpr)
+c mproc - 1st 2-D node index
+c nproc - 2nd 2-D node index
+c mnproc - 1-D node index
+c mp_1st - 1st node in this row of 2-D nodes, mpe_1(nproc)
+c i0 - 1st dimension offset for this tile, i0_pe(mproc,nproc)
+c ii - 1st dimension extent for this tile, ii_pe(mproc,nproc)
+c j0 - 2nd dimension offset for this tile, j0_pe(mproc,nproc)
+c jj - 2nd dimension extent for this tile, jj_pe(mproc,nproc)
+c margin - how much of the halo is currently valid
+c nreg - region type
+c vland - fill value for land (standard value 0.0)
+c
+c 3) data structures (private):
+c idproc - 2-D node addresses, with periodic wrap
+c idproc1 - 1-D node addresses, with periodic wrap
+c idhalo - left and right halo target nodes
+c i0_pe - 1st dimension tile offsets
+c ii_pe - 1st dimension tile extents (<=idm)
+c j0_pe - 2nd dimension tile offsets
+c jj_pe - 2nd dimension tile extents (<=jdm)
+c mpe_1 - 1st node in each row of 2-D nodes
+c mpe_e - end node in each row of 2-D nodes
+c mpe_i - mapping from 1st global dimension to 2-D nodes
+c npe_j - mapping from 2nd global dimension to 2-D nodes
+c i1sum - local index of 1st partial sum on each tile
+c iisum - number of partial sums on each tile
+c m0_top - tile offset: top neighbors (0:jpr-1)
+c mm_top - tile extent: top neighbors (<=jpr)
+c i0_st - halo offsets: send top neighbors
+c ii_st - halo lengths: send top neighbors
+c i0_gt - halo offsets: get top neighbors
+c ii_gt - halo lengths: get top neighbors
+c m0_bot - tile offset: bot neighbors (0:jpr-1)
+c mm_bot - tile extent: bot neighbors (<=jpr)
+c i0_sb - halo offsets: send bot neighbors
+c ii_sb - halo lengths: send bot neighbors
+c i0_gb - halo offsets: get bot neighbors
+c ii_gb - halo lengths: get bot neighbors
+c
+c 4) all data structures are based on the processor number and
+c the patch distribution file, 'patch.input'.
+c*
+c**********
+c
+ integer mxsum
+ parameter (mxsum=(idm+4*nbdy)/(2*nbdy+1))
+c
+ integer i,idm_in,itdm_in,ios,ixsum,
+ & j,jdm_in,jtdm_in,l,m,mm,mn,mypei,n,npesi
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+c standard mpi (message passing) version.
+c
+#if defined(USE_ESMF)
+ call mpi_comm_dup(mpi_comm_vm, mpi_comm_hycom, mpierr)
+#elif defined(USE_CCSM3)
+ call mpi_comm_dup(mpi_comm_ocn, mpi_comm_hycom, mpierr)
+#else
+ call mpi_init(mpierr)
+ call mpi_comm_dup(mpi_comm_world, mpi_comm_hycom, mpierr)
+#endif
+c
+ call mpi_comm_rank(mpi_comm_hycom, mypei, mpierr)
+ call mpi_comm_size(mpi_comm_hycom, npesi, mpierr)
+c
+ mnproc = mypei + 1 ! mnproc counts from 1
+#if defined(DEBUG_ALL)
+ lp = 6
+ write(lp,'(a,i5)') 'mnproc =',mnproc
+ call xcsync(flush_lp)
+#endif
+#elif defined(SHMEM)
+ integer SHMEM_MYPE,SHMEM_NPES
+c
+c shmem version.
+c
+ call start_pes(0)
+c
+ mypei = SHMEM_MYPE()
+ npesi = SHMEM_NPES()
+c
+ mnproc = mypei + 1 ! mnproc counts from 1
+#else
+ lp = 6
+c
+ write(lp,*)
+ write(lp,*) '***** ERROR - UNDEFINED SPMD MACHINE TYPE *****'
+ write(lp,*)
+ call flush(lp)
+ stop '(xcspmd)'
+#endif
+c
+ vland = 0.0
+ vland4 = 0.0
+c
+ lp = 6
+#if defined(T3E)
+ open(unit=lp,delim='none') ! forces open on stdout
+#endif
+c
+c read in the tile locations and sizes.
+c patch distibution file on unit 21 (fort.21).
+c
+c here is an example of a patch file, with a leading "!" added:
+c
+! npes npe mpe idm jdm ibig jbig nreg
+! 16 4 4 57 52 19 15 0
+!
+!ispt( 1) = 22 35 42 49
+!iipe( 1) = 13 7 7 7
+!ispt( 2) = 1 15 25 34
+!iipe( 2) = 14 10 9 9
+!ispt( 3) = 2 21 29 38
+!iipe( 3) = 19 8 9 10
+!ispt( 4) = 18 28 35 42
+!iipe( 4) = 10 7 7 9
+!
+!jspt( 1) = 1 15 26 38
+!jjpe( 1) = 14 11 12 15
+c
+c ispt(j) is the 1st i-point on each tile in the j-th row
+c iipe(j) is the i-extent of each tile in the j-th row
+c jspt(1) is the 1st j-point on each tile in all columns
+c jjpe(1) is the j-extent of each tile in all columns
+c
+c note that each tile row can have a different tile layout,
+c but each tile column is identical. So a tile can have at
+c most one nieghbor in the E and W directions, but several
+c nieghbors in the N and S directions.
+c
+c iipe can be zero, indicating an empty tile (not included in the
+c active tile count, npes) and therefore at least a halo widths
+c land separation between active tiles to its east and west. In
+c periodic cases, the last non-empty tile can periodic wrap to the
+c first tile in the row (i.e. trailing "empty" tiles can be null
+c tiles, rather than all-land tiles).
+c
+#if defined(USE_CCSM3)
+ open(unit=uoff+99,file=trim(flnmptchd)//'patch.input',
+ & iostat=ios)
+#else
+ open(unit=uoff+99,file='./patch.input',
+ & iostat=ios)
+#endif
+ if (ios.ne.0) then
+ call xcstop('xcspmd: error opening patch.input')
+ stop '(xcspmd)'
+ endif
+ read(uoff+99,'(/8i6/)',iostat=ios) ijpr,ipr,jpr,
+ & itdm_in,jtdm_in,idm_in,jdm_in,nreg
+ if (ios.ne.0) then
+ call xcstop('xcspmd: error reading patch.input')
+ stop '(xcspmd)'
+ elseif (ijpr.gt.ijqr .or. ipr.gt.iqr .or. jpr.gt.jqr) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,3i5)') 'input: ijpr,ipr,jpr =',ijpr,ipr,jpr
+ write(lp,'(a,3i5)') 'param: ijqr,iqr,jqr =',ijqr,iqr,jqr
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: patch.input for wrong ipr,jpr,ijpr')
+ stop '(xcspmd)'
+ elseif (itdm_in.ne.itdm .or. jtdm_in.ne.jtdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,2i5)') 'input: itdm,jtdm =',itdm_in,jtdm_in
+ write(lp,'(a,2i5)') 'param: itdm,jtdm =',itdm, jtdm
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: patch.input for wrong itdm,jtdm')
+ stop '(xcspmd)'
+ elseif (idm_in.gt.idm .or. jdm_in.gt.jdm) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,2i5)') 'input: idm,jdm =',idm_in,jdm_in
+ write(lp,'(a,2i5)') 'param: idm,jdm =',idm, jdm
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: patch.input for wrong idm,jdm')
+ stop '(xcspmd)'
+#if defined(ARCTIC)
+ elseif (nreg.ne.3) then ! not arctic
+ if (mnproc.eq.1) then
+ write(lp,'(a,i5)') 'input: nreg =',nreg
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: patch.input must be for arctic')
+ stop '(xcspmd)'
+#else
+ elseif (nreg.lt.0 .or. nreg.gt.2) then ! not closed or periodic
+ ! use TYPE=one/omp for f-plane
+ if (mnproc.eq.1) then
+ write(lp,'(a,i5)') 'input: nreg =',nreg
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: patch.input for wrong nreg')
+ stop '(xcspmd)'
+#endif /* ARCTIC:else */
+ endif
+c
+c individual tile rows.
+c
+ do n= 1,jpr
+ read( uoff+99,'(12x,8i6)') (i0_pe(m,n),m=1,ipr) ! ispt=i0+1
+ read( uoff+99,'(12x,8i6)') (ii_pe(m,n),m=1,ipr) ! iipe
+ if (maxval(ii_pe(1:ipr,n)).le.0) then
+ call xcstop('xcspmd: patch.input has an empty row')
+ stop '(xcspmd)'
+ endif
+ do m= 1,ipr
+ i0_pe(m,n) = i0_pe(m,n) - 1
+ enddo
+ enddo
+#if defined(ARCTIC)
+c
+c --- all arctic patch tiles must be the same size or empty,
+c --- and empty tiles must be "twinned" across the top boundary.
+c
+ if (ipr.gt.1) then
+ do m= 1,ipr
+ if (ii_pe(m,jpr).eq.0) then
+ if (ii_pe(ipr+1-m,jpr).ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,i3,a,i3,a)')
+ & 'error - tile',m,',jpr is empty but tile',
+ & ipr+1-m,',jpr is not'
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: arctic empty tiles are not twins')
+ stop '(xcspmd)'
+ endif
+ elseif (ii_pe(m,jpr).ne.itdm/ipr) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,i5)')
+ & 'error - arctic patch tiles should have ii =',itdm/ipr
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: arctic tiles are not the right size')
+ stop '(xcspmd)'
+ endif
+ enddo !m
+ endif
+#endif /* ARCTIC */
+c
+c the generic tile column (must cover entire column).
+c
+ read( uoff+99,*)
+ read( uoff+99,'(12x,8i6)') (j0_pe(1,n),n=1,jpr) ! jspt = io+1
+ read( uoff+99,'(12x,8i6)') (jj_pe(1,n),n=1,jpr) ! jjpe
+ if (j0_pe(1,1).ne.1) then
+ call xcstop('xcspmd: patch.input for wrong jspt')
+ stop '(xcspmd)'
+ endif
+ j0_pe(1,1) = 0
+ do n= 2,jpr
+ j0_pe(1,n) = j0_pe(1,n) - 1
+ if (j0_pe(1,n).ne.j0_pe(1,n-1)+jj_pe(1,n-1)) then
+ call xcstop('xcspmd: patch.input non-contiguous')
+ stop '(xcspmd)'
+ endif
+ enddo
+ if (j0_pe(1,jpr)+jj_pe(1,jpr).ne.jtdm) then
+ call xcstop('xcspmd: patch.input for wrong jjpe')
+ stop '(xcspmd)'
+ endif
+ do m= 2,ipr
+ j0_pe(m,:) = j0_pe(1,:)
+ jj_pe(m,:) = jj_pe(1,:)
+ enddo
+ close(uoff+99)
+c
+#if defined(MPI)
+c
+c do we have the right number of pes?
+c
+ if (npesi.ne.ijpr) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) '***** ERROR - WRONG MPI SIZE *****'
+ write(lp,*)
+ write(lp,*) 'NPES = ',npesi
+ write(lp,*) ' IJPR = ', ijpr
+ write(lp,*) 'IPR,JPR = ',ipr,jpr
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('Error in xcspmd')
+ stop
+ endif
+c
+c mpi messages are sent and received by pe number (0:ijpr-1).
+c
+ null_tile = mpi_proc_null
+c
+ mn = 0
+ do n= 1,jpr
+ mpe_1(n) = 0
+ do m= 1,ipr
+ if (ii_pe(m,n).eq.0) then
+ idproc(m,n) = null_tile
+ else
+ idproc1(mn+1) = mn
+ idproc(m,n) = mn
+ mn = mn + 1
+ if (mnproc.eq.mn) then
+ mproc = m
+ nproc = n
+ endif
+ mpe_e(n) = m
+ if (mpe_1(n).eq.0) then
+ mpe_1(n) = m
+ endif
+ endif
+ enddo
+ enddo
+c
+ mp_1st = mpe_1(nproc) !1st node in this row (public)
+c
+c mpi-2 i/o group (public), see mod_za.
+c
+ if (mproc.eq.mp_1st) then
+ i = 1
+ call mpi_comm_split(mpi_comm_hycom, i,0,
+ & group_1st_in_row, mpierr)
+ else
+ i = 0
+ call mpi_comm_split(mpi_comm_hycom, i,0,
+ & group_1st_in_row, mpierr)
+ call mpi_comm_free( group_1st_in_row, mpierr)
+ endif
+#elif defined(SHMEM)
+c
+c do we have the right number of pes?
+c
+ if (npesi.ne.ijpr) then
+ if (mnproc.eq.1) then
+ write(lp,*)
+ write(lp,*) '***** ERROR - WRONG SHMEM SIZE *****'
+ write(lp,*)
+ write(lp,*) 'NPES = ',npesi
+ write(lp,*) ' IJPR = ', ijpr
+ write(lp,*) 'IPR,JPR = ',ipr,jpr
+ write(lp,*)
+ call flush(lp)
+ endif
+ call xcstop('Error in xcspmd')
+ stop
+ endif
+c
+c shmem messages are sent and received by pe number (0:ijpr-1).
+c
+ null_tile = -1
+c
+ mn = 0
+ do n= 1,jpr
+ mpe_1(n) = 0
+ do m= 1,ipr
+ if (ii_pe(m,n).eq.0) then
+ idproc(m,n) = null_tile
+ else
+ idproc1(mn+1) = mn
+ idproc(m,n) = mn
+ mn = mn + 1
+ if (mnproc.eq.mn) then
+ mproc = m
+ nproc = n
+ endif
+ mpe_e(n) = m
+ if (mpe_1(n).eq.0) then
+ mpe_1(n) = m
+ endif
+ endif
+ enddo
+ enddo
+c
+ mp_1st = mpe_1(nproc) !1st node in this row (public)
+#endif
+c
+ if (mn.ne.ijpr) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,i5)') 'input: ijpr =',ijpr
+ write(lp,'(a,i5)') 'calc: ijpr =',mn
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: wrong number of sea tiles')
+ stop '(xcspmd)'
+ endif
+c
+ if (nreg.eq.0) then
+c
+c longitudinal tile dimension is closed (not periodic)
+c
+ do n= 1,jpr
+ idproc( 0,n) = null_tile
+ idproc(ipr+1,n) = null_tile
+ enddo
+ else
+c
+c longitudinal tile dimension is potentially periodic.
+c
+ do n= 1,jpr
+ idproc( 0,n) = null_tile
+ idproc(ipr+1,n) = null_tile
+c
+ i = maxval((i0_pe(1:ipr,n)+ii_pe(1:ipr,n)))
+ if (i0_pe(1,n).eq.0 .and. i.eq.itdm) then
+ idproc( 0,n) = idproc(mpe_e(n),n)
+ idproc(mpe_e(n)+1,n) = idproc( 1,n)
+ endif
+ enddo
+ endif
+#if defined(ARCTIC)
+c
+c must have ipr even or 1 for arctic boundary case.
+c
+ if (ipr.gt.1 .and. mod(ipr,2).ne.0) then
+ call xcstop('Error in xcspmd (arctic) - ipr must be even')
+ stop '(xcspmd)'
+ endif
+c
+c latitudinal tile dimension is closed/arctic.
+c
+ do m= 1,ipr
+ idproc(m, 0) = null_tile
+ idproc(m,jpr+1) = idproc(ipr+1-m,jpr) !arctic tile mapping
+ enddo
+ idproc( 0, 0) = null_tile
+ idproc(ipr+1, 0) = null_tile
+ idproc( 0,jpr+1) = idproc(ipr,jpr+1)
+ idproc(ipr+1,jpr+1) = idproc(1, jpr+1)
+#else
+c
+c latitudinal tile dimension is closed
+c
+ do m= 0,ipr+1
+ idproc(m, 0) = null_tile
+ idproc(m,jpr+1) = null_tile
+ enddo
+#endif /* ARCTIC:else */
+c
+c 1-d tiling logic is easier if assumed periodic.
+c
+ idproc1( 0) = idproc1(ijpr)
+ idproc1(ijpr+1) = idproc1( 1)
+c
+c mapping from global i,j to mp,np.
+c ia,ja is on tile mpe_i(ia,npe_j(ja)),npe_j(ja),
+c or on no tile if mpe_i(ia,npe_j(ja)) is 0 or -1.
+c
+ do n= 1,jpr
+ mpe_i(1:itdm,n) = 0 ! default is an empty tile
+ do m= 1,ipr ! i-map potentially varies with n
+ if (ii_pe(m,n).gt.0) then
+ do i= i0_pe(m,n)+1,i0_pe(m,n)+ii_pe(m,n)
+ mpe_i(i,n) = m
+ enddo
+ if (m.ne.ipr) then
+ if (ii_pe(m+1,n).gt.0) then
+ do i= i0_pe(m,n)+ii_pe(m,n)+1,i0_pe(m+1,n)
+ mpe_i(i,n) = -1 ! gap between tiles
+ enddo
+ endif
+ endif
+ endif
+ enddo
+ m = 1 ! only one j-map
+ do j= j0_pe(m,n)+1,j0_pe(m,n)+jj_pe(m,n)
+ npe_j(j) = n
+ enddo
+ enddo
+c
+c do each partial sum on the tile that owns its center point.
+c i1sum - local index of 1st partial sum on each tile
+c iisum - number of partial sums on each tile
+c see xcsum for how i1sum and iisum are used.
+c
+ ixsum = 0
+ do n= 1,jpr
+ do m= 1,ipr
+ if (ii_pe(m,n).le.0) then
+ i1sum(m,n) = 0
+ iisum(m,n) = 0
+ else
+ idhalo(1) = idproc(m-1,n)
+ idhalo(2) = idproc(m+1,n)
+ if (idhalo(1).ne.null_tile .and. m.ne.1) then
+ if (i0_pe(m,n).ne.i0_pe(m-1,n)+ii_pe(m-1,n)) then
+ idhalo(1) = null_tile
+ endif
+ endif
+ if (idhalo(2).ne.null_tile .and. m.ne.mpe_e(n)) then
+ if (i0_pe(m,n)+ii_pe(m,n).ne.i0_pe(m+1,n)) then
+ idhalo(2) = null_tile
+ endif
+ endif
+ i1sum(m,n) = -99
+ iisum(m,n) = 0
+ do i= 1+nbdy,itdm+nbdy,2*nbdy+1
+ if (i0_pe(m,n).lt.i .and.
+ & i.le.i0_pe(m,n)+ii_pe(m,n)) then
+ iisum(m,n) = iisum(m,n) + 1
+ if (iisum(m,n).eq.1) then
+ i1sum(m,n) = i - nbdy - i0_pe(m,n)
+ endif
+ elseif (idhalo(1).eq.null_tile .and.
+ & i.gt.i0_pe(m,n)-nbdy .and.
+ & i.le.i0_pe(m,n) ) then
+ iisum(m,n) = iisum(m,n) + 1
+ if (iisum(m,n).eq.1) then
+ i1sum(m,n) = i - nbdy - i0_pe(m,n)
+ endif
+ elseif (idhalo(2).eq.null_tile .and.
+ & i.gt.i0_pe(m,n)+ii_pe(m,n) .and.
+ & i.le.i0_pe(m,n)+ii_pe(m,n)+nbdy ) then
+ iisum(m,n) = iisum(m,n) + 1
+ if (iisum(m,n).eq.1) then
+ i1sum(m,n) = i - nbdy - i0_pe(m,n)
+ endif
+ endif
+ enddo
+ endif
+ ixsum = max( ixsum, iisum(m,n) )
+ enddo !m
+ enddo !n
+c
+c local tile extents.
+c
+ i0 = i0_pe(mproc,nproc)
+ ii = ii_pe(mproc,nproc)
+ j0 = j0_pe(mproc,nproc)
+ jj = jj_pe(mproc,nproc)
+c
+ margin = 0
+c
+c left and right halo targets
+c
+ idhalo(1) = idproc(mproc-1,nproc)
+ idhalo(2) = idproc(mproc+1,nproc)
+c
+ if (idhalo(1).ne.null_tile .and. mproc.ne.1) then
+c
+c is the left tile touching this one?
+c
+ if (i0.ne.i0_pe(mproc-1,nproc)+ii_pe(mproc-1,nproc)) then
+ idhalo(1) = null_tile
+ endif
+ endif
+c
+ if (idhalo(2).ne.null_tile .and. mproc.ne.mpe_e(nproc)) then
+c
+c is the right tile touching this one?
+c
+ if (i0+ii.ne.i0_pe(mproc+1,nproc)) then
+ idhalo(2) = null_tile
+ endif
+ endif
+c
+c local halo exchange data structures
+c
+c m0_top - tile offset: top neighbors
+c mm_top - tile extent: top neighbors (<=jpr)
+c i0_st - halo offsets: send top neighbors
+c ii_st - halo lengths: send top neighbors
+c i0_gt - halo offsets: get top neighbors
+c ii_gt - halo lengths: get top neighbors
+c m0_bot - tile offset: bot neighbors
+c mm_bot - tile extent: bot neighbors (<=jpr)
+c i0_sb - halo offsets: send bot neighbors
+c ii_sb - halo lengths: send bot neighbors
+c i0_gb - halo offsets: get bot neighbors
+c ii_gb - halo lengths: get bot neighbors
+c
+c note that send is also receive, and is w.r.t. the local tile.
+c similarly get is also put, and is w.r.t. the remote tile.
+c
+ if (nproc.eq.jpr) then
+#if defined(ARCTIC)
+c single, same size, top arctic nieghbor
+ m0_top = mproc - 1
+ mm_top = 1
+ i0_st(1) = 0
+ i0_gt(1) = 0
+ ii_st(1) = ii
+ ii_gt(1) = ii
+#else
+c no top nieghbor (closed boundary)
+ m0_top = 0
+ mm_top = 0
+#endif /* ARCTIC:else */
+ else
+ n = nproc + 1
+ m0_top = 0
+ mm_top = 0
+ m = 0
+ do i= 1,ii
+ if (mpe_i(i0+i,n).ne.m) then
+ if (mm_top.eq.0) then
+ m0_top = mpe_i(i0+i,n) - 1
+ elseif (m.ne.-1) then
+ ii_st(mm_top) = i-1 - i0_st(mm_top)
+ ii_gt(mm_top) = ii_st(mm_top)
+ endif
+ m = mpe_i(i0+i,n)
+ if (m.gt.0) then
+ mm_top = mm_top + 1
+ i0_st(mm_top) = i-1
+ i0_gt(mm_top) = i-1 + i0-i0_pe(m,n)
+ elseif (m.eq.0) then
+ mm_top = mm_top + 1
+ i0_st(mm_top) = i-1
+ i0_gt(mm_top) = i0_gt(mm_top-1) + ii_gt(mm_top-1)
+* elseif (m.eq.-1) then !do nothing
+ endif
+ endif
+ enddo
+ if (mm_top.gt.0) then
+ if (m.gt.0) then
+ ii_st(mm_top) = ii - i0_st(mm_top)
+ ii_gt(mm_top) = ii_st(mm_top)
+ elseif (m.eq.0) then
+ mm_top = mm_top-1
+* elseif (m.eq.-1) then !do nothing
+ endif
+ endif
+ endif !nproc.eq.1:else
+c
+ if (nproc.eq.1) then
+c no bottom nieghbor (closed boundary)
+ m0_bot = 0
+ mm_bot = 0
+ else
+ n = nproc - 1
+ m0_bot = 0
+ mm_bot = 0
+ m = 0
+ do i= 1,ii
+ if (mpe_i(i0+i,n).ne.m) then
+ if (mm_bot.eq.0) then
+ m0_bot = mpe_i(i0+i,n) - 1
+ elseif (m.ne.-1) then
+ ii_sb(mm_bot) = i-1 - i0_sb(mm_bot)
+ ii_gb(mm_bot) = ii_sb(mm_bot)
+ endif
+ m = mpe_i(i0+i,n)
+ if (m.gt.0) then
+ mm_bot = mm_bot + 1
+ i0_sb(mm_bot) = i-1
+ i0_gb(mm_bot) = i-1 + i0-i0_pe(m,n)
+ elseif (m.eq.0) then
+ mm_bot = mm_bot + 1
+ i0_sb(mm_bot) = i-1
+ i0_gb(mm_bot) = i0_gb(mm_bot-1) + ii_gb(mm_bot-1)
+* elseif (m.eq.-1) then !do nothing
+ endif
+ endif
+ enddo
+ if (mm_bot.gt.0) then
+ if (m.gt.0) then
+ ii_sb(mm_bot) = ii - i0_sb(mm_bot)
+ ii_gb(mm_bot) = ii_sb(mm_bot)
+ elseif (m.eq.0) then
+ mm_bot = mm_bot-1
+* elseif (m.eq.-1) then !do nothing
+ endif
+ endif
+ endif !nproc.eq.1:else
+c
+c printout the tile data structures.
+c
+ if (mnproc.eq.1) then
+ write(lp,'(/a)')
+ & 'mnproc mproc nproc i0 ii j0 jj i1sum iisum'
+ mn = 0
+ do n= 1,jpr
+ do m= 1,ipr
+ if (ii_pe(m,n).ne.0) then
+ mn= mn + 1
+ write(lp,'(i6,2i6,i7,i5,i7,i5,i7,i6)')
+ & mn,m,n,
+ & i0_pe(m,n),ii_pe(m,n),
+ & j0_pe(m,n),jj_pe(m,n),
+ & i1sum(m,n),iisum(m,n)
+ endif
+ enddo !m
+ enddo !n
+ write(lp,*)
+#if defined(ARCTIC)
+ write(lp,'(a)')
+ & 'mnproc mproc nproc mnarct'
+ mn = 0
+ do n= 1,jpr
+ do m= 1,ipr
+ if (ii_pe(m,n).ne.0) then
+ mn= mn + 1
+ if (n.eq.jpr) then
+ write(lp,'(i6,2i6,i7)')
+ & mn,m,n,idproc(m,n+1)
+ endif
+ endif
+ enddo !m
+ enddo !n
+ write(lp,*)
+#endif /* ARCTIC */
+#if defined(DEBUG_ALL)
+ do n= 1,jpr
+ write(lp,*) 'mpe_1,mpe_e = ',mpe_1(n),mpe_e(n)
+ enddo
+ do n= 1,jpr
+ write(lp,*) 'mpe_i = ',mpe_i(:,n)
+ enddo
+ write(lp,*)
+ write(lp,*) 'npe_j = ',npe_j(:)
+ write(lp,*)
+#endif
+ endif
+ call xcsync(flush_lp)
+c
+#if defined(DEBUG_ALL)
+ do n= 1,jpr
+ do m= 1,ipr
+ if (mproc.eq.m .and. nproc.eq.n) then
+ write(lp,'(a,2i3,i4,i3,16(i5,i4))')
+ & 'm,n,_top,_st = ',
+ & m,n,m0_top,mm_top,(i0_st(l),ii_st(l), l= 1,mm_top)
+#if defined(SHMEM)
+ write(lp,'(a,2i3,i4,i3,16(i5,i4))')
+ & 'm,n,_top,_gt = ',
+ & m,n,m0_top,mm_top,(i0_gt(l),ii_gt(l), l= 1,mm_top)
+#endif
+ if (m.eq.ipr) then
+ write(lp,*) !blank line
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo !m
+ do m= 1,ipr
+ if (mproc.eq.m .and. nproc.eq.n) then
+ write(lp,'(a,2i3,i4,i3,16(i5,i4))')
+ & 'm,n,_bot,_sb = ',
+ & m,n,m0_bot,mm_bot,(i0_sb(l),ii_sb(l), l= 1,mm_bot)
+#if defined(SHMEM)
+ write(lp,'(a,2i3,i4,i3,16(i5,i4))')
+ & 'm,n,_bot,_gb = ',
+ & m,n,m0_bot,mm_bot,(i0_gb(l),ii_gb(l), l= 1,mm_bot)
+#endif
+ if (m.eq.ipr) then
+ write(lp,*) !blank line
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo !m
+ do m= 1,ipr
+ if (mproc.eq.m .and. nproc.eq.n) then
+ write(lp,'(a,2i3,3i5)')
+ & 'm,n,id,idhalo = ',
+ & m,n,idproc(m,n),idhalo
+ if (m.eq.ipr) then
+ write(lp,*) !blank line
+ endif
+ endif
+ call xcsync(flush_lp)
+ enddo !m
+ enddo !n
+#endif /* DEBUG_ALL */
+#if defined(USE_ESMF)
+c
+c --- Currently ESMF only implemented for simplest block decomposition
+c
+ do n= 1,jpr
+ countde2(n) = jj_pe(1,n)
+ enddo !n
+ do m= 1,ipr
+ countde1(m) = ii_pe(m,1)
+ if (minval(ii_pe(m,1:jpr)).ne.
+ & maxval(ii_pe(m,1:jpr)) ) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,3i5)') 'm,min(ii),max(ii) = ',
+ & m,minval(ii_pe(m,1:jpr)),
+ & maxval(ii_pe(m,1:jpr))
+ call flush(lp)
+ endif
+ call xcstop('xcspmd: bad ii for ESMF')
+ stop '(xcspmd)'
+ endif
+ enddo !m
+#endif
+c
+c mxsum large enough?
+c
+ if (ixsum.gt.mxsum) then
+ if (mnproc.eq.1) then
+ write(lp,'(a,2i5)') 'mxsum,ixsum =',mxsum,ixsum
+ call flush(lp)
+ endif
+ call xcstop('Error in xcspmd - mxsum too small')
+ stop '(xcspmd)'
+ endif
+c
+c initialize timers.
+c
+ call xctmri
+#if defined(TIMER)
+ call xctmrn( 1,'xcaget')
+ call xctmrn( 2,'xceget')
+ call xctmrn( 3,'xclget')
+ call xctmrn( 4,'xcaput')
+ call xctmrn( 5,'xcXput')
+ call xctmrn( 6,'xcsum ')
+ call xctmrn( 9,'xcastr')
+ call xctmrn(10,'xcmaxr')
+ call xctmrn(12,'xctilr')
+#endif
+ return
+ end subroutine xcspmd
+
+ subroutine xcstop(cerror)
+ implicit none
+c
+ character*(*), intent(in) :: cerror
+c
+c**********
+c*
+c 1) stop all processes.
+c
+c 2) all processes must call this routine.
+c use 'xchalt' for emergency stops.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c cerror char*(*) input error message
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+c print active timers.
+c
+ call xctmrp
+c
+c message passing version, set barrier and then stop everything.
+c use xcsync as the barrier so that stdout is flushed.
+c note that the system will hang unless all processes call xcstop.
+c
+ call xcsync(flush_lp)
+ if (mnproc.eq.1 .and. cerror.ne.' ') then
+ write(lp,*) '**************************************************'
+ write(lp,*) cerror
+ write(lp,*) '**************************************************'
+ write(lp,*)
+ endif
+ call xcsync(flush_lp)
+c
+#if defined(USE_ESMF) || defined(USE_CCSM3)
+c
+c --- we may not be running on all processes, so call mpi_abort
+c
+ if (mnproc.eq.1) then
+ call mpi_abort(mpi_comm_hycom,9)
+ endif
+ call xcsync(flush_lp)
+#elif defined(MPI)
+ write(lp,*) 'mpi_finalize called on processor ',mnproc
+ call xcsync(flush_lp)
+ call mpi_finalize(mpierr)
+c
+#endif
+ stop '(xcstop)'
+ end subroutine xcstop
+
+ subroutine xcsum(sum, a,mask)
+ implicit none
+c
+ real*8, intent(out) :: sum
+ real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) sum a 2-d array, where mask==1
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sum real*8 output sum of a
+c a real input source array
+c mask integer input mask array
+c
+c 3) sum is bit for bit reproducable for the same halo size, nbdy.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer mxsum
+ parameter (mxsum=(idm+4*nbdy)/(2*nbdy+1))
+c
+ real*8 sum8t,sum8j,sum8s
+ common/xcsum8/ sum8t(mxsum*jdm),sum8j(jdm),sum8s
+ save /xcsum8/
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8
+ real vsave
+ integer i,i1,j,l,mp,np
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 6)
+ nxc = 6
+ endif
+#endif
+c
+c halo update so that 2*nbdy+1 wide strips are on chip.
+c
+ vsave = vland
+ vland = 0.0
+ call xctilr(a,1,1, nbdy,0, halo_ps)
+ vland = vsave
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,l,sum8)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l= 1,iisum(mproc,nproc)
+ i1 = i1sum(mproc,nproc) + (l-1)*(2*nbdy+1)
+ sum8 = zero8
+ do i= max(i1,1-nbdy),min(i1+2*nbdy,ii+nbdy,itdm-i0)
+ if (mask(i,j).eq.1) then
+ sum8 = sum8 + a(i,j)
+ endif
+ enddo
+ sum8t(l + (j-1)*iisum(mproc,nproc)) = sum8
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+c complete row sums on first processor in each row.
+c
+#if defined(SHMEM)
+ BARRIER
+#endif
+ if (mproc.eq.mpe_1(nproc)) then
+ do j=1,jj
+ sum8j(j) = zero8
+ do l= 1,iisum(mproc,nproc)
+ sum8j(j) = sum8j(j) + sum8t(l + (j-1)*iisum(mproc,nproc))
+ enddo
+* write(lp,'(a,i3,i5,f12.2)') 'xcsum: np,j,sum = ',
+* & 1,j,sum8j(j)
+ enddo
+c
+c remote sums.
+c
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ l = iisum(mp,nproc)*jj
+ if (l.gt.0) then
+#if defined(MPI)
+ call MPI_RECV(sum8t,l,MTYPED,
+ & idproc(mp,nproc), 9900,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(SHMEM)
+ call SHMEM_GETD(sum8t,
+ & sum8t,l,idproc(mp,nproc))
+#endif
+ do j=1,jj
+ do l= 1,iisum(mp,nproc)
+ sum8j(j) = sum8j(j) + sum8t(l + (j-1)*iisum(mp,nproc))
+ enddo
+* write(lp,'(a,i3,i5,f12.2)') 'xcsum: np,j,sum = ',
+* & mp,j,sum8j(j)
+ enddo
+ endif
+ enddo
+#if defined(MPI)
+ else
+ l = iisum(mproc,nproc)*jj
+ if (l.gt.0) then
+ call MPI_SEND(sum8t,l,MTYPED,
+ & idproc(mpe_1(nproc),nproc), 9900,
+ & mpi_comm_hycom, mpierr)
+ endif
+#endif
+ endif
+c
+c sum of row sums, on first processor.
+c
+#if defined(SHMEM)
+ BARRIER
+#endif
+ if (mnproc.eq.1) then
+ sum8 = zero8
+ do j= 1,jj
+ sum8 = sum8 + sum8j(j)
+ enddo
+* write(lp,'(a,i5,f12.2)') 'xcsum: jj,sum = ',jj,sum8
+c
+ do np= 2,jpr
+ mp = mpe_1(np)
+#if defined(MPI)
+ call MPI_RECV(sum8j,jj_pe(mp,np),MTYPED,
+ & idproc(mp,np), 9901,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(SHMEM)
+ call SHMEM_GETD(sum8j,
+ & sum8j,jj_pe(mp,np),idproc(mp,np))
+#endif
+ do j= 1,jj_pe(mp,np)
+ sum8 = sum8 + sum8j(j)
+ enddo
+* write(lp,'(a,i5,f12.2)') 'xcsum: jj,sum = ',
+* & jj_pe(mp,np),sum8
+ enddo
+ sum8s = sum8
+#if defined(MPI)
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_SEND(sum8j,jj,MTYPED,
+ & idproc1(1), 9901,
+ & mpi_comm_hycom, mpierr)
+#endif
+ endif
+c
+c broadcast result to all processors.
+c
+#if defined(MPI)
+ call mpi_bcast(sum8s,1,MTYPED,
+ & idproc1(1),mpi_comm_hycom,mpierr)
+#elif defined(SHMEM)
+ BARRIER
+ if (mnproc.ne.1) then
+ call SHMEM_GETD(sum8s,
+ & sum8s,1,idproc1(1))
+ endif
+#endif
+c
+ sum = sum8s
+#if defined(TIMER)
+c
+ if (nxc.eq. 6) then
+ call xctmr1( 6)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcsum
+
+ subroutine xcsumj(sumj, a,mask)
+ implicit none
+c
+ real*8, intent(out) :: sumj(jtdm)
+ real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) rwo-sum of a 2-d array, where mask==1, on first processor only.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sumj real*8 output row-sum of a
+c a real input source array
+c mask integer input mask array
+c
+c 3) sum is bit for bit reproducable for the same halo size, nbdy.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer mxsum
+ parameter (mxsum=(idm+4*nbdy)/(2*nbdy+1))
+c
+ real*8 sum8t,sum8j,sum8s
+ common/xcsum8/ sum8t(mxsum*jdm),sum8j(jdm),sum8s
+ save /xcsum8/
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8
+ real vsave
+ integer i,i1,j,l,mp,np
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0( 6)
+ nxc = 6
+ endif
+#endif
+c
+c halo update so that 2*nbdy+1 wide strips are on chip.
+c
+ vsave = vland
+ vland = 0.0
+ call xctilr(a,1,1, nbdy,0, halo_ps)
+ vland = vsave
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,l,sum8)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l= 1,iisum(mproc,nproc)
+ i1 = i1sum(mproc,nproc) + (l-1)*(2*nbdy+1)
+ sum8 = zero8
+ do i= i1,min(i1+2*nbdy,ii+nbdy,itdm-i0)
+ if (mask(i,j).eq.1) then
+ sum8 = sum8 + a(i,j)
+ endif
+ enddo
+ sum8t(l + (j-1)*iisum(mproc,nproc)) = sum8
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+c complete row sums on first processor in each row.
+c
+#if defined(SHMEM)
+ BARRIER
+#endif
+ if (mproc.eq.mpe_1(nproc)) then
+ do j=1,jj
+ sum8j(j) = zero8
+ do l= 1,iisum(mproc,nproc)
+ sum8j(j) = sum8j(j) + sum8t(l + (j-1)*iisum(mproc,nproc))
+ enddo
+* write(lp,'(a,i3,i5,f12.2)') 'xcsum: np,j,sum = ',
+* & 1,j,sum8j(j)
+ enddo
+c
+c remote sums.
+c
+ do mp= mpe_1(nproc)+1,mpe_e(nproc)
+ l = iisum(mp,nproc)*jj
+ if (l.gt.0) then
+#if defined(MPI)
+ call MPI_RECV(sum8t,l,MTYPED,
+ & idproc(mp,nproc), 9900,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(SHMEM)
+ call SHMEM_GETD(sum8t,
+ & sum8t,l,idproc(mp,nproc))
+#endif
+ do j=1,jj
+ do l= 1,iisum(mp,nproc)
+ sum8j(j) = sum8j(j) + sum8t(l + (j-1)*iisum(mp,nproc))
+ enddo
+* write(lp,'(a,i3,i5,f12.2)') 'xcsum: np,j,sum = ',
+* & mp,j,sum8j(j)
+ enddo
+ endif
+ enddo
+#if defined(MPI)
+ else
+ l = iisum(mproc,nproc)*jj
+ if (l.gt.0) then
+ call MPI_SEND(sum8t,l,MTYPED,
+ & idproc(mpe_1(nproc),nproc), 9900,
+ & mpi_comm_hycom, mpierr)
+ endif
+#endif
+ endif
+c
+c send row sums to first processor.
+c
+#if defined(SHMEM)
+ BARRIER
+#endif
+ if (mnproc.eq.1) then
+ do j= 1,jj
+ sumj(j) = sum8j(j)
+ enddo
+c
+ do np= 2,jpr
+ mp = mpe_1(np)
+#if defined(MPI)
+ call MPI_RECV(sum8j,jj_pe(mp,np),MTYPED,
+ & idproc(mp,np), 9901,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(SHMEM)
+ call SHMEM_GETD(sum8j,
+ & sum8j,jj_pe(mp,np),idproc(mp,np))
+#endif
+ do j= 1,jj_pe(1,np)
+ sumj(j+j0_pe(1,np)) = sum8j(j)
+ enddo
+ enddo
+#if defined(MPI)
+ elseif (mproc.eq.mpe_1(nproc)) then
+ call MPI_SEND(sum8j,jj,MTYPED,
+ & idproc1(1), 9901,
+ & mpi_comm_hycom, mpierr)
+#endif
+ endif
+#if defined(TIMER)
+c
+ if (nxc.eq. 6) then
+ call xctmr1( 6)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xcsumj
+
+ subroutine xcsync(lflush)
+ implicit none
+c
+ logical, intent(in) :: lflush
+c
+c**********
+c*
+c 1) barrier, no processor exits until all arrive (and flush stdout).
+c
+c 2) some MPI implementations only flush stdout as a collective
+c operation, and hence the lflush=.true. option to flush stdout.
+c
+c 3) typically this is just a wrapper to the "BARRIER" macro.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ if (lflush) then
+#if defined(MPI) && defined(AIX) && ! (defined(AIX_NOFL) || defined(USE_ESMF) || defined(USE_CCSM3))
+ call mp_flush(1) ! flushes stdout, and implies a barrier
+#else
+ call flush(lp)
+ BARRIER
+#endif
+ else
+ BARRIER
+ endif
+ return
+ end subroutine xcsync
+
+#if defined(SHMEM) && defined(RINGB)
+ subroutine xctbar(ipe1,ipe2)
+ implicit none
+c
+ integer, intent(in) :: ipe1,ipe2
+c
+c**********
+c*
+c 1) sync with processors ipe1 and ipe2.
+c
+c 2) this is a global collective operation, and the calls on ipe1
+c and ipe2 must list this processor as one of the two targets.
+c
+c 3) this is used in place of a global barrier in halo operations,
+c but it only provides syncronization of one or two processors
+c with the local processor.
+c
+c 4) ipe1 and/or ipe2 can be null_tile, to indicate no processor.
+c*
+c**********
+c
+ integer cache_line,ilarge
+ parameter (cache_line=32, ilarge=2**30)
+c
+ integer ibp
+ common/halobp/ ibp(cache_line,-1:ijpr-1)
+ save /halobp/
+c
+ integer i
+c
+ integer icount
+ save icount
+ data icount / -1 /
+c
+ icount = mod(icount+1,ilarge)
+ if (icount.eq.0) then
+ call shmem_barrier_all()
+ do i= -1,ijpr-1
+ ibp(1,i) = -1
+ enddo
+ call shmem_barrier_all()
+ endif
+c
+ ibp(1,-1) = icount
+ if (ipe1.ne.null_tile) then
+ call shmem_integer_put(ibp(1,mnproc-1),icount,1,ipe1)
+ endif
+ if (ipe2.ne.null_tile) then
+ call shmem_integer_put(ibp(1,mnproc-1),icount,1,ipe2)
+ endif
+ call shmem_fence
+c
+ i = -1
+ do while (i.lt.icount)
+c this assignment statement must not be optimized away.
+cdir$ suppress
+ i = min(ibp(1,ipe1),ibp(1,ipe2))
+ enddo
+ return
+ end subroutine xctbar
+#endif /* SHMEM && RINGB */
+
+#if defined(ARCTIC)
+ recursive subroutine xctilr(a,l1,ld,mh,nh,itype)
+ implicit none
+c
+ integer, intent(in) :: l1,ld,mh,nh,itype
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+c
+c**********
+c*
+c 1) update the tile overlap halo of a real array.
+c
+c this version of arctic bi-polar patch only
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c l1 integer input 3rd dim. start index
+c ld integer input 3rd dimension of a
+c mh integer input 1st (EW) update halo size
+c nh integer input 2nd (NS) update halo size
+c itype integer input grid and field type
+c
+c 3) itype selects both the grid and field type
+c itype= 1; p-grid, scalar field
+c itype= 2; q-grid, scalar field
+c itype= 3; u-grid, scalar field
+c itype= 4; v-grid, scalar field
+c itype=11; p-grid, vector field
+c itype=12; q-grid, vector field
+c itype=13; u-grid, vector field
+c itype=14; v-grid, vector field
+c
+c 4) the global variable vland is returned by halos over land.
+c*
+c**********
+c
+ integer ilen,jlen
+ parameter (ilen= idm *kdm*nbdy+64,
+ & jlen=(jdm+2*nbdy)*kdm*nbdy+64)
+c
+c halo buffer (in common for enhanced MPI safety).
+c
+ real ai,aj
+ common/xctilr4/ ai(ilen,4),aj(jlen,4)
+ save /xctilr4/
+c
+ real aia
+ common/xctilra/ aia(kdm*nbdy+64,2)
+ save /xctilra/
+c
+ integer i,io,itynew,j,k,l,lg0,ls0,lm,m,mhl,nhl
+ real sarc
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+c persistent communication handles.
+c
+ integer mpireqa(4*iqr),mpireqb(4),nreqa,
+ & klmold,klnold,mhlold,nhlold,ityold
+ save mpireqa,mpireqb,nreqa,
+ & klmold,klnold,mhlold,nhlold,ityold
+c
+ data nreqa,klmold,klnold,mhlold,nhlold,ityold / 0,0,0,0,0,0 /
+#endif /* MPI */
+c
+c --- split large requests into smaller pieces
+c
+ if (ld-l1+1.gt.kdm) then
+ do k= l1,ld,kdm
+ l = min(k+kdm-1,ld)
+ call xctilr(a,k,l,mh,nh,itype)
+ enddo
+ return
+ endif
+c
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0(12)
+ nxc = 12
+ endif
+#endif
+c
+ mhl = max(0,min(mh,nbdy))
+ nhl = max(0,min(nh,nbdy))
+c
+ if (itype.lt.10) then
+ sarc = 1.0
+ else
+ sarc = -1.0
+ endif
+c
+ if (nhl.gt.0) then
+ if (ipr.eq.1 .and. jpr.eq.1) then
+ do k= l1,ld
+ do j= 1,nhl
+ do i= 1,ii
+ a(i, 1-j,k) = vland
+ enddo
+ if (itype.eq.1 .or. itype.eq.11) then
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ if (a(io,jj-1-j,k).ne.vland) then
+ a(i,jj+j,k) = sarc*a(io,jj-1-j,k)
+ else
+ a(i,jj+j,k) = vland
+ endif
+ enddo !i
+ elseif (itype.eq.2 .or. itype.eq.12) then
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ if (a(io,jj-j,k).ne.vland) then
+ a(i,jj+j,k) = sarc*a(io,jj-j,k)
+ else
+ a(i,jj+j,k) = vland
+ endif
+ enddo !i
+ elseif (itype.eq.3 .or. itype.eq.13) then
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ if (a(io,jj-1-j,k).ne.vland) then
+ a(i,jj+j,k) = sarc*a(io,jj-1-j,k)
+ else
+ a(i,jj+j,k) = vland
+ endif
+ enddo !i
+ elseif (itype.eq.4 .or. itype.eq.14) then
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ if (a(io,jj-j,k).ne.vland) then
+ a(i,jj+j,k) = sarc*a(io,jj-j,k)
+ else
+ a(i,jj+j,k) = vland
+ endif
+ enddo !i
+ endif !itype
+ enddo !j
+ enddo !k
+ else
+ if (nproc.ne.jpr) then
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ ai(l,1) = a(i,jj+1-j,k)
+ ai(l,2) = a(i, j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo !j
+ enddo !k
+ enddo !i
+ elseif (itype.eq.1 .or. itype.eq.11) then !p-grid
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ io = ii+1-i !ii:1:-1
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(io,jj-1-j,k).ne.vland) then
+ ai(l,1) = sarc*a(io,jj-1-j,k)
+ else
+ ai(l,1) = vland
+ endif
+ ai(l,2) = a(i,j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo !j
+ enddo !k
+ enddo !i
+ elseif (itype.eq.3 .or. itype.eq.13) then !u-grid
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ io = ii+2-i !ii+1:2:-1
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(io,jj-1-j,k).ne.vland) then
+ ai(l,1) = sarc*a(io,jj-1-j,k)
+ else
+ ai(l,1) = vland
+ endif
+ ai(l,2) = a(i,j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo !j
+ enddo !k
+ enddo !i
+ l = 0
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(1,jj-1-j,k).ne.vland) then
+ aia(l,1) = sarc*a(1,jj-1-j,k)
+ else
+ aia(l,1) = vland
+ endif
+ aia(l,2) = vland
+ enddo !j
+ enddo !k
+ elseif (itype.eq.2 .or. itype.eq.12) then !q-grid
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ io = ii+2-i !ii+1:2:-1
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(io,jj-j,k).ne.vland) then
+ ai(l,1) = sarc*a(io,jj-j,k)
+ else
+ ai(l,1) = vland
+ endif
+ ai(l,2) = a(i,j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo !j
+ enddo !k
+ enddo !i
+ l = 0
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(1,jj-j,k).ne.vland) then
+ aia(l,1) = sarc*a(1,jj-j,k)
+ else
+ aia(l,1) = vland
+ endif
+ aia(l,2) = vland
+ enddo !j
+ enddo !k
+ else !v-grid
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ io = ii+1-i !ii:1:-1
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ if (a(io,jj-j,k).ne.vland) then
+ ai(l,1) = sarc*a(io,jj-j,k)
+ else
+ ai(l,1) = vland
+ endif
+ ai(l,2) = a(i,j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo !j
+ enddo !k
+ enddo !i
+ endif !itype
+* write(lp,'(a,6i6)') 'xctilr - nhl,l1,ld,ii,l,mnproc = ',
+* & nhl,l1,ld,ii,l,mnproc
+* call xcsync(flush_lp)
+c
+#if defined(MPI)
+ if (itype.eq.2 .or. itype.eq.12 .or. !q-grid
+ & itype.eq.3 .or. itype.eq.13 ) then !u-grid
+ itynew = 2
+ else
+ itynew = 1
+ endif
+ if (klnold.ne.(ld-l1+1) .or.
+ & nhlold.ne.nhl .or.
+ & ityold.ne.itynew ) then !new mpi init needed
+#if defined(DEBUG_ALL)
+* if (mnproc.eq.1) then
+* write(lp,'(a,4i6)') 'xctilr - nhl,l1,ld,itype = ',
+* & nhl,l1,ld,itype
+* endif
+* call xcsync(flush_lp)
+#endif
+ do i= 1,nreqa
+ call mpi_request_free(mpireqa(i), mpierr)
+ enddo
+ klnold = ld-l1+1
+ nhlold = nhl
+ ityold = itynew
+c
+c loop through all neigboring tiles.
+c
+ l = 0
+ do m= 1,mm_top
+ l = l + 1
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ if (nproc.ne.jpr) then
+ call mpi_send_init(
+ & ai(ls0+1,1),lm,MTYPER,
+ & idproc(m0_top+m,nproc+1), 9905,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ else !arctic
+ call mpi_send_init(
+ & ai(ls0+1,1),lm,MTYPER,
+ & idproc(m0_top+m,nproc+1), 99051,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ endif
+ enddo
+ if (nproc.eq.jpr) then !arctic
+ if (itype.eq.2 .or. itype.eq.12 .or. !q-grid
+ & itype.eq.3 .or. itype.eq.13 ) then !u-grid
+ l = l + 1
+ lm = nhl*(ld-l1+1)
+ call mpi_send_init(
+ & aia(1,1),lm,MTYPER,
+ & idproc(mod(ipr+1-mproc,ipr)+1,nproc), 99052,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ endif !q-grid,u-grid
+ endif
+ do m= 1,mm_bot
+ l = l + 1
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call mpi_send_init(
+ & ai(ls0+1,2),lm,MTYPER,idproc(m0_bot+m,nproc-1), 9906,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ do m= 1,mm_top
+ l = l + 1
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ if (nproc.ne.jpr) then
+ call mpi_recv_init(
+ & ai(ls0+1,4),lm,MTYPER,
+ & idproc(m0_top+m,nproc+1), 9906,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ else !arctic
+ call mpi_recv_init(
+ & ai(ls0+1,4),lm,MTYPER,
+ & idproc(m0_top+m,nproc+1), 99051,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ endif
+ enddo
+ if (nproc.eq.jpr) then !arctic
+ if (itype.eq.2 .or. itype.eq.12 .or. !q-grid
+ & itype.eq.3 .or. itype.eq.13 ) then !u-grid
+ l = l + 1
+ lm = nhl*(ld-l1+1)
+ call mpi_recv_init(
+ & aia(1,2),lm,MTYPER,
+ & idproc(mod(ipr+1-mproc,ipr)+1,nproc), 99052,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ endif !q-grid,u-grid
+ endif
+ do m= 1,mm_bot
+ l = l + 1
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call mpi_recv_init(
+ & ai(ls0+1,3),lm,MTYPER,idproc(m0_bot+m,nproc-1), 9905,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ nreqa = l
+ endif
+ if (nreqa.gt.0) then
+ call mpi_startall(nreqa, mpireqa, mpierr)
+ call mpi_waitall( nreqa, mpireqa, mpistat, mpierr)
+ endif
+#elif defined(SHMEM)
+ BARRIER
+c
+c loop through all neigboring tiles.
+c
+ do m= 1,mm_top
+ if (idproc(m0_top+m,nproc+1).ne.null_tile) then
+ lg0 = i0_gt(m)*nhl*(ld-l1+1)
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ if (nproc.ne.jpr) then
+ call SHMEM_GETR(ai(ls0+1,4),
+ & ai(lg0+1,2),lm,
+ & idproc(m0_top+m,nproc+1))
+ else !arctic
+ call SHMEM_GETR(ai(ls0+1,4),
+ & ai(lg0+1,1),lm, !buffer 1
+ & idproc(m0_top+m,nproc+1))
+ endif
+ endif
+ enddo
+ if (nproc.eq.jpr) then !arctic
+ if (itype.eq.2 .or. itype.eq.12 .or. !q-grid
+ & itype.eq.3 .or. itype.eq.13 ) then !u-grid
+ lm = nhl*(ld-l1+1)
+ call SHMEM_GETR(aia(1,2),
+ & aia(1,1),lm,
+ & idproc(mod(ipr+1-mproc)+1,nproc))
+ endif !q-grid,u-grid
+ endif
+c
+ do m= 1,mm_bot
+ if (idproc(m0_bot+m,nproc-1).ne.null_tile) then
+ lg0 = i0_gb(m)*nhl*(ld-l1+1)
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call SHMEM_GETR(ai(ls0+1,3),
+ & ai(lg0+1,1),lm, idproc(m0_bot+m,nproc-1))
+ endif
+ enddo
+#endif /* MPI:SHMEM */
+c
+ if (nproc.eq.jpr) then !arctic
+ if (itype.eq.2 .or. itype.eq.12 .or. !q-grid
+ & itype.eq.3 .or. itype.eq.13 ) then !u-grid
+ l = 0
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ ai(l,4) = aia(l,2)
+ enddo !j
+ enddo !k
+ endif !q-grid,u-grid
+ endif !arctic
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ a(i, 1-j,k) = ai(l,3)
+ a(i,jj+j,k) = ai(l,4)
+ enddo
+ enddo
+ enddo
+ endif ! jpr.eq.1:else
+ endif ! nhl.gt.0
+c
+ if (mhl.gt.0) then
+ if (ipr.eq.1) then
+ if (nreg.eq.0) then
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = vland
+ a(ii+i,j,k) = vland
+ enddo
+ enddo
+ enddo
+ else
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = a(ii+1-i,j,k)
+ a(ii+i,j,k) = a( i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ else
+ l = 0
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ l = l + 1
+ aj(l,1) = a(ii+1-i,j,k)
+ aj(l,2) = a( i,j,k)
+ aj(l,3) = vland
+ aj(l,4) = vland
+ enddo
+ enddo
+ enddo
+* write(lp,'(a,6i6)') 'xctilr - mhl,l1,ld,jj,l,mnproc = ',
+* & mhl,l1,ld,jj,l,mnproc
+* call xcsync(flush_lp)
+#if defined(MPISR)
+ call mpi_sendrecv(
+ & aj(1,1),l,MTYPER,idhalo(2), 9907,
+ & aj(1,4),l,MTYPER,idhalo(2), 9908,
+ & mpi_comm_hycom, mpistat, mpierr)
+ call mpi_sendrecv(
+ & aj(1,2),l,MTYPER,idhalo(1), 9908,
+ & aj(1,3),l,MTYPER,idhalo(1), 9907,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(MPI)
+ if (klmold.ne.(ld-l1+1) .or. mhlold.ne.mhl) then !new mpi init
+#if defined(DEBUG_ALL)
+* if (mnproc.eq.1) then
+* write(lp,'(a,3i6)') 'xctilr - mhl,l1,ld = ',
+* & mhl,l1,ld
+* endif
+* call xcsync(flush_lp)
+#endif
+ if (klmold.ne.0) then
+ call mpi_request_free(mpireqb(1), mpierr)
+ call mpi_request_free(mpireqb(2), mpierr)
+ call mpi_request_free(mpireqb(3), mpierr)
+ call mpi_request_free(mpireqb(4), mpierr)
+ endif
+ klmold = ld-l1+1
+ mhlold = mhl
+ call mpi_send_init(
+ & aj(1,1),l,MTYPER,idhalo(2), 9907,
+ & mpi_comm_hycom, mpireqb(1), mpierr)
+ call mpi_send_init(
+ & aj(1,2),l,MTYPER,idhalo(1), 9908,
+ & mpi_comm_hycom, mpireqb(2), mpierr)
+ call mpi_recv_init(
+ & aj(1,3),l,MTYPER,idhalo(1), 9907,
+ & mpi_comm_hycom, mpireqb(3), mpierr)
+ call mpi_recv_init(
+ & aj(1,4),l,MTYPER,idhalo(2), 9908,
+ & mpi_comm_hycom, mpireqb(4), mpierr)
+ endif
+ call mpi_startall(4, mpireqb, mpierr)
+ call mpi_waitall( 4, mpireqb, mpistat, mpierr)
+#elif defined(SHMEM)
+ BARRIER_MP
+ if (idhalo(1).ne.null_tile) then
+ call SHMEM_GETR(aj(1,3),
+ & aj(1,1),l,idhalo(1))
+ endif
+ if (idhalo(2).ne.null_tile) then
+ call SHMEM_GETR(aj(1,4),
+ & aj(1,2),l,idhalo(2))
+ endif
+ BARRIER_MP
+#endif
+ l = 0
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ l = l + 1
+ a( 1-i,j,k) = aj(l,3)
+ a(ii+i,j,k) = aj(l,4)
+ enddo
+ enddo
+ enddo
+ endif ! ipr.eq.1:else
+ endif ! mhl.gt.0
+#if defined(TIMER)
+c
+ if (nxc.eq.12) then
+ call xctmr1(12)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xctilr
+#else /* !ARCTIC */
+ recursive subroutine xctilr(a,l1,ld,mh,nh,itype)
+ implicit none
+c
+ integer, intent(in) :: l1,ld,mh,nh,itype
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+c
+c**********
+c*
+c 1) update the tile overlap halo of a real array.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c l1 integer input 3rd dim. start index
+c ld integer input 3rd dimension of a
+c mh integer input 1st (EW) update halo size
+c nh integer input 2nd (NS) update halo size
+c itype integer input grid and field type
+c
+c 3) itype selects both the grid and field type
+c itype= 1; p-grid, scalar field
+c itype= 2; q-grid, scalar field
+c itype= 3; u-grid, scalar field
+c itype= 4; v-grid, scalar field
+c itype=11; p-grid, vector field
+c itype=12; q-grid, vector field
+c itype=13; u-grid, vector field
+c itype=14; v-grid, vector field
+c it is ignored here because all types are the same unless
+c the grid includes the arctic ocean
+c
+c 4) the global variable vland is returned by halos over land.
+c*
+c**********
+c
+ integer ilen,jlen
+ parameter (ilen= idm *kdm*nbdy+64,
+ & jlen=(jdm+2*nbdy)*kdm*nbdy+64)
+c
+c halo buffer (in common for enhanced MPI safety).
+c
+ real ai,aj
+ common/xctilr4/ ai(ilen,4),aj(jlen,4)
+ save /xctilr4/
+c
+ integer i,j,k,l,lg0,ls0,lm,m,mhl,nhl
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+c persistent communication handles.
+c
+ integer mpireqa(4*iqr),mpireqb(4),ilold,jlold,nreqa
+ save mpireqa,mpireqb,ilold,jlold,nreqa
+c
+ data ilold,jlold / 0,0 /
+#endif /* MPI */
+c
+c --- split large requests into smaller pieces
+c
+ if (ld-l1+1.gt.kdm) then
+ do k= l1,ld,kdm
+ l = min(k+kdm-1,ld)
+ call xctilr(a,k,l,mh,nh,itype)
+ enddo
+ return
+ endif
+c
+#if defined(TIMER)
+c
+ if (nxc.eq.0) then
+ call xctmr0(12)
+ nxc = 12
+ endif
+#endif
+c
+ mhl = max(0,min(mh,nbdy))
+ nhl = max(0,min(nh,nbdy))
+c
+ if (nhl.gt.0) then
+ if (jpr.eq.1) then
+ do k= l1,ld
+ do j= 1,nhl
+ do i= 1,ii
+ a(i, 1-j,k) = vland
+ a(i,jj+j,k) = vland
+ enddo
+ enddo
+ enddo
+ else
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ ai(l,1) = a(i,jj+1-j,k)
+ ai(l,2) = a(i, j,k)
+ ai(l,3) = vland
+ ai(l,4) = vland
+ enddo
+ enddo
+ enddo
+* write(lp,'(a,6i6)') 'xctilr - nhl,l1,ld,ii,l,mnproc = ',
+* & nhl,l1,ld,ii,l,mnproc
+* call xcsync(flush_lp)
+c
+#if defined(MPI)
+ if (jlold.ne.l) then
+ if (jlold.ne.0) then
+ do i= 1,nreqa
+ call mpi_request_free(mpireqa(i), mpierr)
+ enddo
+ endif
+ jlold = l
+c
+c loop through all neigboring tiles.
+c
+ l = 0
+ do m= 1,mm_top
+ l = l + 1
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ call mpi_send_init(
+ & ai(ls0+1,1),lm,MTYPER,idproc(m0_top+m,nproc+1), 9905,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ do m= 1,mm_bot
+ l = l + 1
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call mpi_send_init(
+ & ai(ls0+1,2),lm,MTYPER,idproc(m0_bot+m,nproc-1), 9906,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ do m= 1,mm_top
+ l = l + 1
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ call mpi_recv_init(
+ & ai(ls0+1,4),lm,MTYPER,idproc(m0_top+m,nproc+1), 9906,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ do m= 1,mm_bot
+ l = l + 1
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call mpi_recv_init(
+ & ai(ls0+1,3),lm,MTYPER,idproc(m0_bot+m,nproc-1), 9905,
+ & mpi_comm_hycom, mpireqa(l), mpierr)
+ enddo
+ nreqa = l
+ endif
+ if (nreqa.gt.0) then
+ call mpi_startall(nreqa, mpireqa, mpierr)
+ call mpi_waitall( nreqa, mpireqa, mpistat, mpierr)
+ endif
+#elif defined(SHMEM)
+ BARRIER
+c
+c loop through all neigboring tiles.
+c
+ do m= 1,mm_top
+ if (idproc(m0_top+m,nproc+1).ne.null_tile) then
+ lg0 = i0_gt(m)*nhl*(ld-l1+1)
+ ls0 = i0_st(m)*nhl*(ld-l1+1)
+ lm = ii_st(m)*nhl*(ld-l1+1)
+ call SHMEM_GETR(ai(ls0+1,4),
+ & ai(lg0+1,2),lm, idproc(m0_top+m,nproc+1))
+ endif
+ enddo
+c
+ do m= 1,mm_bot
+ if (idproc(m0_bot+m,nproc-1).ne.null_tile) then
+ lg0 = i0_gb(m)*nhl*(ld-l1+1)
+ ls0 = i0_sb(m)*nhl*(ld-l1+1)
+ lm = ii_sb(m)*nhl*(ld-l1+1)
+ call SHMEM_GETR(ai(ls0+1,3),
+ & ai(lg0+1,1),lm, idproc(m0_bot+m,nproc-1))
+ endif
+ enddo
+#endif /* MPI:SHMEM */
+c
+ l = 0
+ do i= 1,ii ! outer loop to simplify multiple neighbor case
+ do k= l1,ld
+ do j= 1,nhl
+ l = l + 1
+ a(i, 1-j,k) = ai(l,3)
+ a(i,jj+j,k) = ai(l,4)
+ enddo
+ enddo
+ enddo
+ endif ! jpr.eq.1:else
+ endif ! nhl.gt.0
+c
+ if (mhl.gt.0) then
+ if (ipr.eq.1) then
+ if (nreg.eq.0) then
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = vland
+ a(ii+i,j,k) = vland
+ enddo
+ enddo
+ enddo
+ else
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = a(ii+1-i,j,k)
+ a(ii+i,j,k) = a( i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ else
+ l = 0
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ l = l + 1
+ aj(l,1) = a(ii+1-i,j,k)
+ aj(l,2) = a( i,j,k)
+ aj(l,3) = vland
+ aj(l,4) = vland
+ enddo
+ enddo
+ enddo
+* write(lp,'(a,6i6)') 'xctilr - mhl,l1,ld,jj,l,mnproc = ',
+* & mhl,l1,ld,jj,l,mnproc
+* call xcsync(flush_lp)
+#if defined(MPISR)
+ call mpi_sendrecv(
+ & aj(1,1),l,MTYPER,idhalo(2), 9907,
+ & aj(1,4),l,MTYPER,idhalo(2), 9908,
+ & mpi_comm_hycom, mpistat, mpierr)
+ call mpi_sendrecv(
+ & aj(1,2),l,MTYPER,idhalo(1), 9908,
+ & aj(1,3),l,MTYPER,idhalo(1), 9907,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(MPI)
+ if (ilold.ne.l) then
+ if (ilold.ne.0) then
+ call mpi_request_free(mpireqb(1), mpierr)
+ call mpi_request_free(mpireqb(2), mpierr)
+ call mpi_request_free(mpireqb(3), mpierr)
+ call mpi_request_free(mpireqb(4), mpierr)
+ endif
+ ilold = l
+ call mpi_send_init(
+ & aj(1,1),l,MTYPER,idhalo(2), 9907,
+ & mpi_comm_hycom, mpireqb(1), mpierr)
+ call mpi_send_init(
+ & aj(1,2),l,MTYPER,idhalo(1), 9908,
+ & mpi_comm_hycom, mpireqb(2), mpierr)
+ call mpi_recv_init(
+ & aj(1,3),l,MTYPER,idhalo(1), 9907,
+ & mpi_comm_hycom, mpireqb(3), mpierr)
+ call mpi_recv_init(
+ & aj(1,4),l,MTYPER,idhalo(2), 9908,
+ & mpi_comm_hycom, mpireqb(4), mpierr)
+ endif
+ call mpi_startall(4, mpireqb, mpierr)
+ call mpi_waitall( 4, mpireqb, mpistat, mpierr)
+#elif defined(SHMEM)
+ BARRIER_MP
+ if (idhalo(1).ne.null_tile) then
+ call SHMEM_GETR(aj(1,3),
+ & aj(1,1),l,idhalo(1))
+ endif
+ if (idhalo(2).ne.null_tile) then
+ call SHMEM_GETR(aj(1,4),
+ & aj(1,2),l,idhalo(2))
+ endif
+ BARRIER_MP
+#endif
+ l = 0
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ l = l + 1
+ a( 1-i,j,k) = aj(l,3)
+ a(ii+i,j,k) = aj(l,4)
+ enddo
+ enddo
+ enddo
+ endif ! ipr.eq.1:else
+ endif ! mhl.gt.0
+#if defined(TIMER)
+c
+ if (nxc.eq.12) then
+ call xctmr1(12)
+ nxc = 0
+ endif
+#endif
+ return
+ end subroutine xctilr
+#endif /* ARCTIC:else */
+
+ subroutine xctmri
+ implicit none
+c
+c**********
+c*
+c 1) initialize timers.
+c
+c 2) timers 1:32 are for message passing routines,
+c timers 33:80 are for general hycom routines,
+c timers 81:96 are for user selected routines.
+c timer 97 is the total time.
+c
+c 3) call xctmri to initialize timers (called in xcspmd),
+c call xctmr0(n) to start timer n,
+c call xctmr1(n) to stop timer n and add event to timer sum,
+c call xctnrn(n,cname) to register a name for timer n,
+c call xctmrp to printout timer statistics (called by xcstop).
+c
+c 4) time every 50-th event above 1,000.
+c*
+c**********
+c
+ integer i
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ nxc = 0
+ do i= 1,97
+ cc(i) = ' '
+ nc(i) = 0
+ tc(i) = zero8
+ enddo
+c
+ call xctmrn(97,'total ')
+ call xctmr0(97)
+ return
+ end subroutine xctmri
+
+ subroutine xctmr0(n)
+ implicit none
+c
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) start timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c
+c 3) time every 50-th event above 1,000.
+c*
+c**********
+c
+ real*8 wtime
+c
+#if defined(DEBUG_TIMER_ALL)
+ if ( cc(n).ne.' ') then
+ write(lp,'(i5,2x,a,a)') mnproc,'call ',cc(n)
+ call flush(lp)
+ endif
+#endif
+#if defined(DEBUG_TIMER)
+ if (n.gt.32 .and. cc(n).ne.' ') then
+ if (mnproc.eq.1) then
+ write(lp,*) 'call ',cc(n)
+ call flush(lp)
+ endif
+ endif
+#endif
+ if (timer_on) then
+ if (mod(nc(n),50).eq.0 .or. nc(n).le.1000) then
+ t0(n) = wtime()
+ endif
+ endif !timer_on
+ return
+ end subroutine xctmr0
+
+ subroutine xctmr1(n)
+ implicit none
+c
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) add time since call to xctim0 to timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c
+c 3) time every 50-th event above 1,000.
+c*
+c**********
+c
+ real*8 wtime
+c
+ if (timer_on) then
+ if (nc(n).gt.1000) then
+ if (mod(nc(n),50).eq.0) then
+ tc(n) = tc(n) + 50.0*(wtime() - t0(n))
+ endif
+ else
+ tc(n) = tc(n) + (wtime() - t0(n))
+ endif
+ nc(n) = nc(n) + 1
+ endif !timer_on
+#if defined(DEBUG_TIMER_ALL)
+ if ( cc(n).ne.' ') then
+ write(lp,'(i5,2x,a,a)') mnproc,'exit ',cc(n)
+ call flush(lp)
+ endif
+#endif
+#if defined(DEBUG_TIMER)
+ if (n.gt.32 .and. cc(n).ne.' ') then
+ if (mnproc.eq.1) then
+ write(lp,*) 'exit ',cc(n)
+ call flush(lp)
+ endif
+ endif
+#endif
+ return
+ end subroutine xctmr1
+
+ subroutine xctmrn(n,cname)
+ implicit none
+c
+ character*6, intent(in) :: cname
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) register name of timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c cname char*(6) input timer name
+c*
+c**********
+c
+ cc(n) = cname
+ return
+ end subroutine xctmrn
+
+#if defined(TIMER_ALLOUT)
+ subroutine xctmrp
+ implicit none
+c
+c**********
+c*
+c 1) print all active timers, on all processors.
+c
+c 2) on exit all timers are reset to zero.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer i,mn
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+c get total time.
+c
+ call xctmr1(97)
+c
+ call xcsync(flush_lp) !includes a barrier for shmem
+ if (mnproc.ne.1) then
+#if defined(MPI)
+ call MPI_SEND(tc,97,MTYPED,
+ & idproc1(1), 9949,
+ & mpi_comm_hycom, mpierr)
+#endif
+ else !mnproc.eq.1
+ do mn= 1,ijpr
+ if (mn.ne.1) then
+#if defined(MPI)
+ call MPI_RECV(tc,97,MTYPED,
+ & idproc1(mn), 9949,
+ & mpi_comm_hycom, mpistat, mpierr)
+#elif defined(SHMEM)
+ call SHMEM_GETD(tc,tc,97,idproc1(mn))
+#endif
+ endif
+ write(lp,6000) mn,ijpr
+ tcxc(1) = zero8
+ do i= 1,32
+ if (nc(i).ne.0) then
+ if (cc(i).ne.' ') then
+ write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i)
+ else
+ write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i)
+ endif
+ if (cc(i)(1:2).eq.'xc') then
+ tcxc(1) = tcxc(1) + tc(i) !communication overhead
+ endif
+ endif
+ enddo !i
+ write(lp,6100) 'xc****',1,tcxc(1),tcxc(1)
+ do i= 33,97
+ if (nc(i).ne.0) then
+ if (cc(i).ne.' ') then
+ write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i)
+ else
+ write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i)
+ endif
+ endif
+ enddo !i
+ enddo !mn
+ write(lp,6200)
+ endif !mnproc.ne.1:else
+ call xcsync(flush_lp) !includes a barrier for shmem
+c
+c reset timers to zero.
+c
+ do i= 1,97
+ nc(i) = 0
+ tc(i) = zero8
+ enddo
+ tcxc(1) = zero8
+c
+c start a new total time measurement.
+c
+ call xctmr0(97)
+ return
+c
+ 6000 format(/ /
+ & 3x,' timer statistics, processor',i5,' out of',i5 /
+ & 3x,'-----------------------------------------------' /)
+ 6100 format(3x,a6,
+ & ' calls =',i9,
+ & ' time =',f11.5,
+ & ' time/call =',f14.8)
+ 6150 format(3x,' #',i2,
+ & ' calls =',i9,
+ & ' time =',f11.5,
+ & ' time/call =',f14.8)
+ 6200 format(/ /)
+ end subroutine xctmrp
+#else
+ subroutine xctmrp
+ implicit none
+c
+c**********
+c*
+c 1) print all active timers.
+c
+c 2) on exit all timers are reset to zero.
+c*
+c**********
+c
+#if defined(MPI)
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#endif
+c
+ integer i,mn,mnloc
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+c get total time.
+c
+ call xctmr1(97)
+c
+c report time on the processor with the least communication overhead
+c
+ tcxc(2) = mnproc
+ tcxc(1) = zero8
+ do i= 1,32
+ if (nc(i).ne.0 .and. cc(i)(1:2).eq.'xc') then
+ tcxc(1) = tcxc(1) + tc(i) !communication overhead
+ endif
+ enddo !i
+c
+ if (ijpr.ne.1) then
+#if defined(MPI)
+ tcxl(1) = tcxc(1)
+ tcxl(2) = tcxc(2)
+ call mpi_allreduce(tcxl,tcxc,1,
+ & mpi_2double_precision,mpi_minloc,
+ & mpi_comm_hycom,mpierr)
+ mnloc = tcxc(2) !processor with the least comm. overhead
+ if (mnproc.eq.1) then
+ if (mnloc.ne.1) then
+ call MPI_RECV(tc,97,MTYPED,
+ & idproc1(mnloc), 9949,
+ & mpi_comm_hycom, mpistat, mpierr)
+ endif
+ elseif (mnproc.eq.mnloc) then
+ call MPI_SEND(tc,97,MTYPED,
+ & idproc1(1), 9949,
+ & mpi_comm_hycom, mpierr)
+ endif
+#elif defined(SHMEM)
+ BARRIER
+ if (mnproc.eq.1) then
+ mnloc = 1
+ do mn= 2,ijpr
+ call SHMEM_GETD(tcxc(2),tcxc(1),1,idproc1(mn))
+ if (tcxc(2).gt.tcxc(1)) then
+ tcxc(1) = tcxc(2)
+ mnloc = mn
+ endif
+ enddo
+ tcxc(2) = mnloc !processor with the least comm. overhead
+ endif
+ if (mnloc.ne.1) then
+ call SHMEM_GETD(tc,tc,97,idproc1(mnloc))
+ endif
+ BARRIER
+#endif
+ endif
+c
+ call xcsync(flush_lp)
+ if (mnproc.eq.1) then
+ write(lp,6000) mnloc,ijpr
+ do i= 1,32
+ if (nc(i).ne.0) then
+ if (cc(i).ne.' ') then
+ write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i)
+ else
+ write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i)
+ endif
+ endif
+ enddo !i
+ write(lp,6100) 'xc****',1,tcxc(1),tcxc(1)
+ do i= 33,97
+ if (nc(i).ne.0) then
+ if (cc(i).ne.' ') then
+ write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i)
+ else
+ write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i)
+ endif
+ endif
+ enddo !i
+ write(lp,6200)
+ endif !mnproc.eq.1
+ call xcsync(flush_lp)
+c
+c reset timers to zero.
+c
+ do i= 1,97
+ nc(i) = 0
+ tc(i) = zero8
+ enddo
+ tcxc(1) = zero8
+c
+c start a new total time measurement.
+c
+ call xctmr0(97)
+ return
+c
+ 6000 format(/ /
+ & 3x,' timer statistics, processor',i5,' out of',i5 /
+ & 3x,'-----------------------------------------------' /)
+ 6100 format(3x,a6,
+ & ' calls =',i9,
+ & ' time =',f11.5,
+ & ' time/call =',f14.8)
+ 6150 format(3x,' #',i2,
+ & ' calls =',i9,
+ & ' time =',f11.5,
+ & ' time/call =',f14.8)
+ 6200 format(/ /)
+ end subroutine xctmrp
+#endif /* TIMER_ALLOUT:else */
diff --git a/src_2.2.18_3_one/mod_xc_sm.h b/src_2.2.18_3_one/mod_xc_sm.h
new file mode 100755
index 0000000..b1c8868
--- /dev/null
+++ b/src_2.2.18_3_one/mod_xc_sm.h
@@ -0,0 +1,1307 @@
+c
+c-----------------------------------------------------------------------
+c
+c auxillary routines that involve off-processor communication.
+c shared memory version, contained in module mod_xc.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine xcaget(aa, a, mnflg)
+ implicit none
+c
+ real, intent(out) :: aa(itdm,jtdm)
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from tiled to non-tiled layout.
+c
+c 3) mnflg selects which nodes must return the array
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real output non-tiled target array
+c a real input tiled source array
+c mnflg integer input node return flag
+c*
+c**********
+c
+ integer j
+#if defined(TIMER)
+c
+c call xctmr0( 1)
+#endif
+c
+c use xclget for now.
+c
+ do j= 1,jtdm
+ call xclget(aa(1,j),itdm, a, 1,j,1,0, mnflg)
+ enddo
+#if defined(TIMER)
+c
+c call xctmr1( 1)
+#endif
+ return
+ end subroutine xcaget
+
+ subroutine xcaput(aa, a, mnflg)
+ implicit none
+c
+ real, intent(in) :: aa(itdm,jtdm)
+ real, intent(out) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) convert an entire 2-D array from non-tiled to tiled layout.
+c
+c 3) mnflg selects which nodes must contain the non-tiled array
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aa real input non-tiled source array
+c a real output tiled target array
+c mnflg integer input node source flag
+c*
+c**********
+c
+ integer j
+#if defined(TIMER)
+c
+c call xctmr0( 4)
+#endif
+c
+c use xclput for now.
+c
+ do j= 1,jtdm
+ call xclput(aa(1,j),itdm, a, 1,j,1,0)
+ enddo
+#if defined(TIMER)
+c
+c call xctmr1( 4)
+#endif
+ return
+ end subroutine xcaput
+
+ subroutine xcastr(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) broadcast array a to all tiles.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node originator flag
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0( 9)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1( 9)
+#endif
+ return
+ end subroutine xcastr
+
+ subroutine xceget(aelem, a, ia,ja)
+ implicit none
+c
+ real, intent(out) :: aelem
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: ia,ja
+c
+c**********
+c*
+c 1) find the value of a(ia,ja) on the non-tiled 2-D grid.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aelem real output required element
+c a real input source array
+c ia integer input 1st index into a
+c ja integer input 2nd index into a
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0( 2)
+#endif
+c
+c single node version - trivial indexing.
+c
+ aelem = a(ia,ja)
+#if defined(TIMER)
+c
+ call xctmr1( 2)
+#endif
+ return
+ end subroutine xceget
+
+ subroutine xceput(aelem, a, ia,ja)
+ implicit none
+c
+ integer, intent(in) :: ia,ja
+ real, intent(in) :: aelem
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) fill a single element in the non-tiled 2-D grid.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aelem real input element value
+c a real in/out target array
+c ia integer input 1st index into a
+c ja integer input 2nd index into a
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0( 4)
+#endif
+c
+c single node version - trivial indexing.
+c
+ a(ia,ja) = aelem
+#if defined(TIMER)
+c
+ call xctmr1( 4)
+#endif
+ return
+ end subroutine xceput
+
+ subroutine xchalt(cerror)
+ implicit none
+c
+ character*(*), intent(in) :: cerror
+c
+c**********
+c*
+c 1) stop all processes.
+c
+c 2) only one processes need call this routine, i.e. it is for
+c emergency stops. use 'xcstop' for ordinary stops called
+c by all processes.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c cerror char*(*) input error message
+c*
+c**********
+c
+c shared memory version, just stop.
+c
+ if (cerror.ne.' ') then
+ write(lp,*) '**************************************************'
+ write(lp,*) cerror
+ write(lp,*) '**************************************************'
+ call flush(lp)
+ endif
+ stop '(xchalt)'
+ end subroutine xchalt
+
+ subroutine xclget(aline,nl, a, i1,j1,iinc,jinc, mnflg)
+ implicit none
+c
+ integer, intent(in) :: nl,i1,j1,iinc,jinc,mnflg
+ real, intent(out) :: aline(nl)
+ real, intent(in) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) extract a line of elements from the non-tiled 2-D grid.
+c
+c 2) aline(i) = a(i1+iinc*(i-1),j1+jinc*(i-1)), for i=1...nl.
+c iinc and jinc can each be -1, 0, or +1.
+c
+c if jinc=0, j1 can be between jtdm+1 and jtdm+nbdy to return
+c values from the top halo. This is for debugging the arctic
+c patch halo exchange only.
+c
+c 3) mnflg selects which nodes must return the line
+c =-n; node number n (mnproc=n), nl,i1,j1 only on node n
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c normally all integer arguments must be identical on all nodes,
+c but a negative mnflg indicates that only the target node is
+c providing the nl,i1,j1 values. These are broadcast to all other
+c nodes, and returned in nl,i1,j1 by all of them.
+c
+c mnflg is ignored here (only have a single node).
+c
+c 4) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aline real output required line of elements
+c nl integer in/out dimension of aline
+c a real input source array
+c i1 integer in/out 1st index into a
+c j1 integer in/out 2nd index into a
+c iinc integer input 1st index increment
+c jinc integer input 2nd index increment
+c mnflg integer input node return flag
+c
+c nl,i1,j1 are input only unless mnflg is negative.
+c*
+c**********
+c
+ integer i
+#if defined(TIMER)
+c
+ call xctmr0( 3)
+#endif
+c
+c single node version - trivial indexing and no error checking.
+c
+ if (jinc.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1+iinc*(i-1),j1)
+ enddo
+ elseif (iinc.eq.0) then
+ do i= 1,nl
+ aline(i) = a(i1,j1+jinc*(i-1))
+ enddo
+ else
+ do i= 1,nl
+ aline(i) = a(i1+iinc*(i-1),j1+jinc*(i-1))
+ enddo
+ endif
+#if defined(TIMER)
+c
+ call xctmr1( 3)
+#endif
+ return
+ end subroutine xclget
+
+ subroutine xclput(aline,nl, a, i1,j1,iinc,jinc)
+ implicit none
+c
+ integer, intent(in) :: nl,i1,j1,iinc,jinc
+ real, intent(in) :: aline(nl)
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) fill a line of elements in the non-tiled 2-D grid.
+c
+c 2) aline(i) = a(i1+i1*(i-1),j1+j1*(i-1)), for i=1...nl.
+c one of iinc and jinc must be 0, and the other must be 1.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c aline real input line of element values
+c nl integer input dimension of aline
+c a real in/out target array
+c i1 integer input 1st index into a
+c j1 integer input 2nd index into a
+c iinc integer input 1st index increment
+c jinc integer input 2nd index increment
+c*
+c**********
+c
+ integer i
+#if defined(TIMER)
+c
+ call xctmr0( 4)
+#endif
+c
+c single node version - trivial indexing.
+c
+ if (jinc.eq.0) then
+ do i= 1,nl
+ a(i1+i-1,j1) = aline(i)
+ enddo
+ elseif (iinc.eq.0) then
+ do i= 1,nl
+ a(i1,j1+i-1) = aline(i)
+ enddo
+ endif
+#if defined(TIMER)
+c
+ call xctmr1( 4)
+#endif
+ return
+ end subroutine xclput
+
+ subroutine xcmaxr_0(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise maximum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcmaxr_0
+
+ subroutine xcmaxr_1(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace array a with its element-wise maximum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcmaxr_1
+
+ subroutine xcmaxr_0o(a)
+ implicit none
+c
+ real, intent(inout) :: a
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise maximum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcmaxr_0o
+
+ subroutine xcmaxr_1o(a)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+c
+c**********
+c*
+c 1) replace array a with its element-wise maximum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcmaxr_1o
+
+ subroutine xcminr_0(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise minimum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcminr_0
+
+ subroutine xcminr_1(a, mnflg)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+ integer, intent(in) :: mnflg
+c
+c**********
+c*
+c 1) replace array a with its element-wise minimum over all tiles.
+c
+c 2) mnflg selects which nodes must return the minimum
+c = 0; all nodes
+c = n; node number n (mnproc=n)
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c mnflg integer input node return flag
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcminr_1
+
+ subroutine xcminr_0o(a)
+ implicit none
+c
+ real, intent(inout) :: a
+c
+c**********
+c*
+c 1) replace scalar a with its element-wise minimum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target variable
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcminr_0o
+
+ subroutine xcminr_1o(a)
+ implicit none
+c
+ real, intent(inout) :: a(:)
+c
+c**********
+c*
+c 1) replace array a with its element-wise minimum over all tiles.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(10)
+#endif
+c
+c single node version - do nothing.
+#if defined(TIMER)
+c
+ call xctmr1(10)
+#endif
+ return
+ end subroutine xcminr_1o
+
+ subroutine xcspmd
+ implicit none
+c
+c**********
+c*
+c 1) initialize data structures that identify the tiles.
+c
+c 2) data structures:
+c ipr - 1st 2-D node dimension
+c jpr - 2nd 2-D node dimension
+c ijpr - 1-D node dimension (ipr*jpr)
+c mproc - 1st 2-D node index
+c nproc - 2nd 2-D node index
+c mnproc - 1-D node index
+c i0 - 1st dimension tile offset
+c ii - 1st dimension tile extent
+c j0 - 2nd dimension tile offset
+c jj - 2nd dimension tile extent
+c margin - how much of the halo is currently valid
+c nreg - region type
+c vland - fill value for land (standard value 0.0)
+c
+c 3) ipr,jpr,ijpr are global (tile independent) values.
+c all other values depend on the processor number,
+c but in this case there is only one processor.
+c*
+c**********
+c
+c shared memory version, mproc=nproc=1.
+c
+ if (iqr.ne.1 .or. jqr.ne.1 .or. ijqr.ne.1) then
+ call xcstop('Error in xcspmd: must have iqr=jqr=ijqr=1')
+ stop '(xcspmd)'
+ endif
+c
+ ipr = 1
+ jpr = 1
+ ijpr = 1
+ mnproc = 1
+ mproc = 1
+ nproc = 1
+c
+ i0 = 0
+ ii = itdm
+ j0 = 0
+ jj = jtdm
+c
+ margin = 0
+c
+ nreg = -1 ! unknown region type
+c
+ vland = 0.0
+ vland4 = 0.0
+c
+c initialize timers.
+c
+ call xctmri
+#if defined(TIMER)
+ call xctmrn( 1,'xcaget')
+ call xctmrn( 2,'xceget')
+ call xctmrn( 3,'xclget')
+ call xctmrn( 4,'xcXput')
+ call xctmrn( 5,'xcsum ')
+ call xctmrn( 6,'xcrang')
+ call xctmrn( 9,'xcastr')
+ call xctmrn(10,'xcmaxr')
+ call xctmrn(12,'xctilr')
+* call xctmrn(13,'xcshft')
+#endif
+ return
+ end subroutine xcspmd
+
+ subroutine xcstop(cerror)
+ implicit none
+c
+ character*(*), intent(in) :: cerror
+c
+c**********
+c*
+c 1) stop all processes.
+c
+c 2) all processes must call this routine.
+c use 'xchalt' for emergency stops.
+c
+c 3) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c cerror char*(*) input error message
+c*
+c**********
+c
+c print active timers.
+c
+ call xctmrp
+c
+c shared memory version, just stop.
+c
+ if (cerror.ne.' ') then
+ write(lp,*) '**************************************************'
+ write(lp,*) cerror
+ write(lp,*) '**************************************************'
+ call flush(lp)
+ endif
+ stop '(xcstop)'
+ end subroutine xcstop
+
+ subroutine xcsum(sum, a,mask)
+ implicit none
+c
+ real*8, intent(out) :: sum
+ real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) sum a 2-d array, where mask==1
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sum real*8 output sum of a
+c a real input source array
+c mask integer input mask array
+c
+c 3) sum is bit for bit reproducable for the same halo size, nbdy.
+c*
+c**********
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8,sum8p,sum8j(jdm)
+ integer i,i1,j
+#if defined(TIMER)
+c
+ call xctmr0( 5)
+#endif
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jdm
+ sum8 = zero8
+ do i1=1,idm,2*nbdy+1
+ sum8p = zero8
+ do i= i1,min(i1+2*nbdy,idm)
+ if (mask(i,j).eq.1) then
+ sum8p = sum8p + a(i,j)
+ endif
+ enddo
+ sum8 = sum8 + sum8p
+ enddo
+ sum8j(j) = sum8 ! use of sum8 minimizes false sharing of sum8j
+ enddo
+!$OMP END PARALLEL DO
+c
+c serial sum of rwo-sum loop.
+c
+ sum8 = sum8j(1)
+ do j=2,jdm
+ sum8 = sum8 + sum8j(j)
+ enddo
+ sum = sum8
+#if defined(TIMER)
+c
+ call xctmr1( 5)
+#endif
+ return
+ end subroutine xcsum
+
+ subroutine xcsumj(sumj, a,mask)
+ implicit none
+c
+ real*8, intent(out) :: sumj(jtdm)
+ real, intent(inout) :: a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+ integer, intent(in) :: mask(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c**********
+c*
+c 1) rwo-sum of a 2-d array, where mask==1, on first processor only
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c sumj real*8 output row-sum of a
+c a real input source array
+c mask integer input mask array
+c
+c 3) sum is bit for bit reproducable for the same halo size, nbdy.
+c*
+c**********
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ real*8 sum8,sum8p
+ integer i,i1,j
+#if defined(TIMER)
+c
+ call xctmr0( 5)
+#endif
+c
+c row sums in 2*nbdy+1 wide strips.
+c
+!$OMP PARALLEL DO PRIVATE(j,i1,i,sum8,sum8p)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jdm
+ sum8 = zero8
+ do i1=1,idm,2*nbdy+1
+ sum8p = zero8
+ do i= i1,min(i1+2*nbdy,idm)
+ if (mask(i,j).eq.1) then
+ sum8p = sum8p + a(i,j)
+ endif
+ enddo
+ sum8 = sum8 + sum8p
+ enddo
+ sumj(j) = sum8 ! use of sum8 minimizes false sharing of sumj
+ enddo
+!$OMP END PARALLEL DO
+#if defined(TIMER)
+c
+ call xctmr1( 5)
+#endif
+ return
+ end subroutine xcsumj
+
+ subroutine xcsync(lflush)
+ implicit none
+c
+ logical, intent(in) :: lflush
+c
+c**********
+c*
+c 1) barrier, no processor exits until all arrive (and flush stdout).
+c
+c 2) some MPI implementations only flush stdout as a collective
+c operation, and hence the lflush=.true. option to flush stdout.
+c
+c 3) Only one processor, so the barrier is a no-op in this case.
+c*
+c**********
+c
+ if (lflush) then
+ call flush(lp)
+ endif
+ return
+ end subroutine xcsync
+
+#if defined(ARCTIC)
+ subroutine xctilr(a,l1,ld,mh,nh,itype)
+ implicit none
+c
+ integer, intent(in) :: l1,ld,mh,nh,itype
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+c
+c**********
+c*
+c 1) update the tile overlap halo of a real array.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c l1 integer input 3rd dim. start index
+c ld integer input 3rd dimension of a
+c mh integer input 1st (EW) update halo size
+c nh integer input 2nd (NS) update halo size
+c itype integer input grid and field type
+c
+c 3) itype selects both the grid and field type
+c itype= 1; p-grid, scalar field
+c itype= 2; q-grid, scalar field
+c itype= 3; u-grid, scalar field
+c itype= 4; v-grid, scalar field
+c itype=11; p-grid, vector field
+c itype=12; q-grid, vector field
+c itype=13; u-grid, vector field
+c itype=14; v-grid, vector field
+c
+c 4) this version for a global grid that includes the arctic ocean
+c*
+c**********
+c
+ integer i,io,j,k,mhl,nhl
+#if defined(TIMER)
+c
+ call xctmr0(12)
+#endif
+c
+ mhl = max(0,min(mh,nbdy))
+ nhl = max(0,min(nh,nbdy))
+c
+ if (nhl.gt.0) then
+ do k= l1,ld
+c
+c southern boundary is closed.
+c
+ do j= 1,nhl
+ do i= 1,ii
+ a(i,1-j,k) = vland
+ enddo
+ enddo
+c
+ if (itype.lt.10) then
+c
+c scalar field
+c
+ if (itype.eq. 1) then
+c
+c p-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ a(i,jj+j,k) = a(io,jj-1-j,k)
+ enddo
+ enddo
+ elseif (itype.eq. 2) then
+c
+c q-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ a(i,jj+j,k) = a(io,jj-j,k)
+ enddo
+ enddo
+ elseif (itype.eq. 3) then
+c
+c u-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ a(i,jj+j,k) = a(io,jj-1-j,k)
+ enddo
+ enddo
+ else
+c
+c v-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ a(i,jj+j,k) = a(io,jj-j,k)
+ enddo
+ enddo
+ endif
+ else
+c
+c vector field, swap sign
+c
+ if (itype.eq.11) then
+c
+c p-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ a(i,jj+j,k) = -a(io,jj-1-j,k)
+ enddo
+ enddo
+ elseif (itype.eq.12) then
+c
+c q-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ a(i,jj+j,k) = -a(io,jj-j,k)
+ enddo
+ enddo
+ elseif (itype.eq.13) then
+c
+c u-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = mod(ii-(i-1),ii)+1
+ a(i,jj+j,k) = -a(io,jj-1-j,k)
+ enddo
+ enddo
+ else
+c
+c v-grid
+c
+ do j= 1,nhl
+ do i= 1,ii
+ io = ii-mod(i-1,ii)
+ a(i,jj+j,k) = -a(io,jj-j,k)
+ enddo
+ enddo
+ endif
+ endif
+ enddo
+ endif
+c
+ if (mhl.gt.0) then
+ do k= 1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = a(ii+1-i,j,k)
+ a(ii+i,j,k) = a( i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(12)
+#endif
+ return
+ end subroutine xctilr
+#else /* !ARCTIC */
+ subroutine xctilr(a,l1,ld,mh,nh,itype)
+ implicit none
+c
+ integer, intent(in) :: l1,ld,mh,nh,itype
+ real, intent(inout) :: a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,ld)
+c
+c**********
+c*
+c 1) update the tile overlap halo of a real array.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c a real in/out target array
+c l1 integer input 3rd dim. start index
+c ld integer input 3rd dimension of a
+c mh integer input 1st (EW) update halo size
+c nh integer input 2nd (NS) update halo size
+c itype integer input grid and field type
+c
+c 3) itype selects both the grid and field type
+c itype= 1; p-grid, scalar field
+c itype= 2; q-grid, scalar field
+c itype= 3; u-grid, scalar field
+c itype= 4; v-grid, scalar field
+c itype=11; p-grid, vector field
+c itype=12; q-grid, vector field
+c itype=13; u-grid, vector field
+c itype=14; v-grid, vector field
+c it is ignored here because all types are the same unless
+c the grid includes the arctic ocean
+c*
+c**********
+c
+ integer i,j,k,mhl,nhl
+#if defined(TIMER)
+c
+ call xctmr0(12)
+#endif
+c
+ mhl = max(0,min(mh,nbdy))
+ nhl = max(0,min(nh,nbdy))
+c
+ if (nhl.gt.0) then
+ if (nreg.le.2) then ! closed in latitude
+ do k= l1,ld
+ do j= 1,nhl
+ do i= 1,ii
+ a(i, 1-j,k) = vland
+ a(i,jj+j,k) = vland
+ enddo
+ enddo
+ enddo
+ else ! periodic (f-plane) in latitude
+ do k= l1,ld
+ do j= 1,nhl
+ do i= 1,ii
+ a(i, 1-j,k) = a(i,jj+1-j,k)
+ a(i,jj+j,k) = a(i, j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+c
+ if (mhl.gt.0) then
+ if (nreg.eq.0 .or. nreg.eq.4) then ! closed in longitude
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = vland
+ a(ii+i,j,k) = vland
+ enddo
+ enddo
+ enddo
+ else ! periodic in longitude
+ do k= l1,ld
+ do j= 1-nhl,jj+nhl
+ do i= 1,mhl
+ a( 1-i,j,k) = a(ii+1-i,j,k)
+ a(ii+i,j,k) = a( i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(12)
+#endif
+ return
+ end subroutine xctilr
+#endif /* ARCTIC:else */
+
+ subroutine xctmri
+ implicit none
+c
+c**********
+c*
+c 1) initialize timers.
+c
+c 2) timers 1:32 are for message passing routines,
+c timers 33:80 are for general hycom routines,
+c timers 81:96 are for user selected routines.
+c timer 97 is the total time.
+c
+c 3) call xctmri to initialize timers (called in xcspmd),
+c call xctmr0(n) to start timer n,
+c call xctmr1(n) to stop timer n and add event to timer sum,
+c call xctnrn(n,cname) to register a name for timer n,
+c call xctmrp to printout timer statistics (called by xcstop).
+c*
+c**********
+c
+ integer i
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+ do 110 i= 1,97
+ cc(i) = ' '
+ nc(i) = 0
+ tc(i) = zero8
+ 110 continue
+c
+ call xctmrn(97,'total ')
+ call xctmr0(97)
+ return
+ end subroutine xctmri
+
+ subroutine xctmr0(n)
+ implicit none
+c
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) start timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c
+c 3) time every 50-th event above 1,000.
+c*
+c**********
+c
+ real*8 wtime
+c
+#if defined(DEBUG_TIMER)
+ if (n.gt.24 .and. cc(n).ne.' ') then
+ write(lp,*) 'call ',cc(n)
+ call flush(lp)
+ endif
+#endif
+ if (timer_on) then
+ if (mod(nc(n),50).eq.0 .or. nc(n).le.1000) then
+ t0(n) = wtime()
+ endif
+ endif !timer_on
+ return
+ end subroutine xctmr0
+
+ subroutine xctmr1(n)
+ implicit none
+c
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) add time since call to xctim0 to timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c
+c 3) time every 50-th event above 1,000.
+c*
+c**********
+c
+ real*8 wtime
+c
+ if (timer_on) then
+ if (nc(n).gt.1000) then
+ if (mod(nc(n),50).eq.0) then
+ tc(n) = tc(n) + 50.0*(wtime() - t0(n))
+ endif
+ else
+ tc(n) = tc(n) + (wtime() - t0(n))
+ endif
+ nc(n) = nc(n) + 1
+ endif !timer_on
+#if defined(DEBUG_TIMER)
+ if (n.gt.24 .and. cc(n).ne.' ') then
+ write(lp,*) 'exit ',cc(n)
+ call flush(lp)
+ endif
+#endif
+ return
+ end subroutine xctmr1
+
+ subroutine xctmrn(n,cname)
+ implicit none
+c
+ character*6, intent(in) :: cname
+ integer, intent(in) :: n
+c
+c**********
+c*
+c 1) register name of timer n.
+c
+c 2) parameters:
+c name type usage description
+c ---------- ---------- ------- ----------------------------
+c n integer input timer number
+c cname char*(8) input timer name
+c*
+c**********
+c
+ cc(n) = cname
+ return
+ end subroutine xctmrn
+
+ subroutine xctmrp
+ implicit none
+c
+c**********
+c*
+c 1) print all active timers.
+c
+c 2) on exit all timers are reset to zero.
+c*
+c**********
+c
+ integer i
+c
+ real*8 zero8
+ parameter (zero8=0.0)
+c
+c get total time.
+c
+ call xctmr1(97)
+c
+c print timers.
+c
+ write(lp,6000)
+ do i= 1,97
+ if (nc(i).ne.0) then
+ if (cc(i).ne.' ') then
+ write(lp,6100) cc(i),nc(i),tc(i),tc(i)/nc(i)
+ else
+ write(lp,6150) i, nc(i),tc(i),tc(i)/nc(i)
+ endif
+ endif
+ enddo
+ write(lp,6200)
+ call flush(lp)
+c
+c reset timers to zero.
+c
+ do i= 1,97
+ nc(i) = 0
+ tc(i) = zero8
+ enddo
+c
+c start a new total time measurement.
+c
+ call xctmr0(97)
+ return
+c
+ 6000 format(/ /
+ + 4x,' timer statistics ' /
+ + 4x,'------------------' /)
+ 6100 format(5x,a6,
+ + ' calls =',i9,
+ + ' time =',f11.5,
+ + ' time/call =',f14.8)
+ 6150 format(5x,' #',i2,
+ + ' calls =',i9,
+ + ' time =',f11.5,
+ + ' time/call =',f14.8)
+ 6200 format(/ /)
+ end subroutine xctmrp
diff --git a/src_2.2.18_3_one/mod_za.F b/src_2.2.18_3_one/mod_za.F
new file mode 100755
index 0000000..d7808c5
--- /dev/null
+++ b/src_2.2.18_3_one/mod_za.F
@@ -0,0 +1,67 @@
+ module mod_za
+ use mod_xc ! HYCOM communication API
+c
+ implicit none
+c
+c --- HYCOM I/O interface.
+c
+c --- See README.src.mod_za for more details.
+c
+#if defined(MPI) && ! defined(SERIAL_IO)
+ integer, save, private ::
+ & file_info_zaiord,file_count_zaiord,
+ & file_info_zaiowr,file_count_zaiowr
+#else
+ private zaiordd,zaiowrd
+#endif
+ private ztiowrd
+c
+ integer, private, parameter :: uaoff = 1000 + uoff !array I/O unit offset
+c
+ contains
+#if ! defined(MPI) && ! defined(SHMEM)
+# include "mod_za_sm.h"
+#elif defined(SERIAL_IO)
+# include "mod_za_mp1.h"
+#else
+# include "mod_za_mp.h"
+#endif
+# include "mod_za_zt.h"
+ end module mod_za
+
+#if defined(ENDIAN_IO_F90) /* see mach_i.c for new C version */
+ subroutine zaio_endian(a,n)
+ implicit none
+c
+ integer, intent(in) :: n
+ integer(kind=4), intent(inout) :: a(n) ! 4-bytes
+c
+c**********
+c*
+c 1) swap the endian-ness of the array.
+c
+c 2) assumes integer(kind=1) and integer(kind=4) ocupy one and four
+c bytes respectively.
+c*
+c**********
+c
+ integer k
+c
+ integer(kind=4) ii4, io4 ! 4-bytes
+ common/czioxe/ ii4, io4 ! helps prevent unwanted optimization
+ save /czioxe/
+c
+ integer(kind=1) ii1(4),io1(4) ! 1-byte
+ equivalence (ii4,ii1(1)), (io4,io1(1)) ! non-standard f90
+c
+ do k= 1,n
+ ii4 = a(k)
+ io1(1) = ii1(4)
+ io1(2) = ii1(3)
+ io1(3) = ii1(2)
+ io1(4) = ii1(1)
+ a(k) = io4
+ enddo
+ return
+ end subroutine zaio_endian
+#endif /* ENDIAN_IO_F90 */
diff --git a/src_2.2.18_3_one/mod_za_mp.h b/src_2.2.18_3_one/mod_za_mp.h
new file mode 100755
index 0000000..15d4743
--- /dev/null
+++ b/src_2.2.18_3_one/mod_za_mp.h
@@ -0,0 +1,1422 @@
+
+#if defined(NOMPIR8) /* LAM does not support mpi_real[48] */
+# define MTYPE4 mpi_real
+#else /* most MPI's allow mpi_real[48] */
+# define MTYPE4 mpi_real4
+#endif
+
+c
+c-----------------------------------------------------------------------
+c
+c machine dependent I/O routines.
+c MPI-2 I/O version, with I/O from first processor in each row.
+c contained in module mod_za.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine zagetc(cline,ios, iunit)
+ implicit none
+c
+ character*80, intent(out) :: cline
+ integer, intent(out) :: ios
+ integer, intent(in) :: iunit
+c
+c**********
+c*
+c 1) machine specific routine for reading one text line from a file.
+c
+c 2) The read is performed on the first processor only.
+c*
+c**********
+c
+ integer iline,ibuf
+ common/czgetc/ iline(81,0:1),ibuf
+ save /czgetc/
+c
+ integer i
+c
+c --- I/O from first processor only
+c
+ ibuf = mod(ibuf+1,2)
+c
+ if (mnproc.eq.1) then
+ read(iunit,'(a)',iostat=ios) cline
+ do i= 1,80
+ iline(i,ibuf) = ichar(cline(i:i))
+ enddo
+ iline(81,ibuf) = ios
+ endif
+c
+c broadcast to all other processors
+c
+ call xcgetc(iline(:,ibuf))
+ do i= 1,80
+ cline(i:i) = char(iline(i,ibuf))
+ enddo
+ ios = iline(81,ibuf) ! iostat value
+ return
+ end subroutine zagetc
+
+ subroutine zaiopn(cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cstat
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopn.
+c see also 'zaiope' and 'zaiopf'.
+c
+c 2) the filename is taken from the environment variable FORxxxA,
+c where xxx = iaunit, with default fort.xxxa.
+c
+c array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer(kind=mpi_offset_kind) disp
+ integer iamode,iahint
+ character cfile*256,cenv*7
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiopn)')
+ stop '(zaiopn)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor in each row.
+c
+ if (mproc.eq.mp_1st) then
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiopn - iaunit = ',iaunit
+* call flush(lp)
+* endif
+c
+c get filename.
+c
+ write(cenv,"('FOR',i3.3,'A')") iaunit
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(cfile,"('fort.',i3.3,'a')") iaunit
+ endif
+c
+c open file.
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ iamode = MPI_MODE_RDONLY +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiord !see zaiost
+ file_count_zaiord = file_count_zaiord + 1
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ iamode = MPI_MODE_WRONLY +
+ & MPI_MODE_CREATE +
+ & MPI_MODE_EXCL +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ else !scratch file
+ iamode = MPI_MODE_RDWR +
+ & MPI_MODE_DELETE_ON_CLOSE +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ endif
+ call mpi_file_open(group_1st_in_row,
+ & trim(cfile),
+ & iamode,
+ & iahint,
+ & iahand(iaunit),
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit
+ write(lp,*) 'mpi_file_open - mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiopn)')
+ stop '(zaiopn)'
+ endif !mpierr
+ disp = 0
+ call mpi_file_set_view(iahand(iaunit),
+ & disp,
+ & MTYPE4,
+ & MTYPE4,
+ & "native", !1st convert to big-endian if necessary
+ & iahint,
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit
+ write(lp,*) 'mpi_file_set_view - mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiopn)')
+ stop '(zaiopn)'
+ endif !mpierr
+c
+ endif ! I/O from first processor in each row
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopn - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+ 9100 format(/ /10x,'error in zaiopn - can''t open unit ',i3,
+ & ', for array I/O.'/ /)
+ end subroutine zaiopn
+
+ subroutine zaiope(cenv,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cenv,cstat
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiope.
+c see also 'zaiopn' and 'zaiopf'.
+c
+c 2) the filename is taken from environment variable 'cenv'.
+c
+c array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer(kind=mpi_offset_kind) disp
+ integer iamode,iahint
+ character cfile*256
+c
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiope)')
+ stop '(zaiope)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor in each row.
+c
+ if (mproc.eq.mp_1st) then
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiope - iaunit = ',iaunit
+* call flush(lp)
+* endif
+c
+c get filename.
+c
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(lp,9300) trim(cenv)
+ write(lp,*) 'iaunit = ',iaunit
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif
+c
+c open file.
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ iamode = MPI_MODE_RDONLY +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiord !see zaiost
+ file_count_zaiord = file_count_zaiord + 1
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ iamode = MPI_MODE_WRONLY +
+ & MPI_MODE_CREATE +
+ & MPI_MODE_EXCL +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ else !scratch file
+ iamode = MPI_MODE_RDWR +
+ & MPI_MODE_DELETE_ON_CLOSE +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ endif
+ call mpi_file_open(group_1st_in_row,
+ & trim(cfile),
+ & iamode,
+ & iahint,
+ & iahand(iaunit),
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'mpi_file_open - mpierr = ',mpierr
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif !mpierr
+ disp = 0
+ call mpi_file_set_view(iahand(iaunit),
+ & disp,
+ & MTYPE4,
+ & MTYPE4,
+ & "native", !1st convert to big-endian if necessary
+ & iahint,
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'mpi_file_set_view - mpierr = ',mpierr
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif !mpierr
+c
+ endif ! I/O from first processor in each row
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiope - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+ 9100 format(/ /10x,'error in zaiope - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ 9300 format(/ /10x,'error in zaiope - environment variable ',a,
+ & ' not defined'/ /)
+ end subroutine zaiope
+
+ subroutine zaiopf(cfile,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cfile,cstat
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopf.
+c see also 'zaiopn' and 'zaiope'.
+c
+c 2) the filename is taken from 'cfile'.
+c
+c array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer(kind=mpi_offset_kind) disp
+ integer iamode,iahint
+ logical lphint
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiopf)')
+ stop '(zaiopf)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor in each row.
+c
+ if (mproc.eq.mp_1st) then
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiopf - iaunit = ',iaunit
+* call flush(lp)
+* endif
+c
+c open file.
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ iamode = MPI_MODE_RDONLY +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiord !see zaiost
+ file_count_zaiord = file_count_zaiord + 1
+ lphint = file_count_zaiord .eq. 1
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ iamode = MPI_MODE_WRONLY +
+ & MPI_MODE_CREATE +
+ & MPI_MODE_EXCL +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ lphint = file_count_zaiowr .eq. 1
+ else !scratch file
+ iamode = MPI_MODE_RDWR +
+ & MPI_MODE_DELETE_ON_CLOSE +
+ & MPI_MODE_UNIQUE_OPEN
+ iahint = file_info_zaiowr !see zaiost
+ file_count_zaiowr = file_count_zaiowr + 1
+ lphint = .true.
+ endif
+ call mpi_file_open(group_1st_in_row,
+ & trim(cfile),
+ & iamode,
+ & iahint,
+ & iahand(iaunit),
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'mpi_file_open - mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiopf)')
+ stop '(zaiopf)'
+ endif !mpierr
+ disp = 0
+ call mpi_file_set_view(iahand(iaunit),
+ & disp,
+ & MTYPE4,
+ & MTYPE4,
+ & "native", !1st convert to big-endian if necessary
+ & iahint,
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'mpi_file_set_view - mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiopf)')
+ stop '(zaiopf)'
+ endif !mpierr
+ if (lphint .and. mnproc.eq.1) then
+ call zaio_hints(iahand(iaunit))
+ endif
+c
+ endif ! I/O from first processor in each row
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopf - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+ 9100 format(/ /10x,'error in zaiopf - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ end subroutine zaiopf
+
+ subroutine zaio_hints(file_handle)
+ implicit none
+c
+ integer, intent(in) :: file_handle
+c
+c**********
+c*
+c 1) prints current hints.
+c*
+c**********
+c
+ logical flag
+ integer hints,i,mpierr,nkeys
+ character*256 key,value
+c
+ call MPI_File_get_info(file_handle, hints, mpierr)
+ call MPI_Info_get_nkeys(hints, nkeys, mpierr)
+c
+ write(6,"(/a)") 'zaio_hints:'
+ do i= 0,nkeys-1
+ call MPI_Info_get_nthkey(hints, i, key, mpierr)
+ call MPI_Info_get(hints, key, 256, value, flag, mpierr)
+ write(6,"(4a)")
+ & ' key=',trim(key),
+ & ' value=',trim(value)
+ enddo
+ write(6,*)
+ return
+ end subroutine zaio_hints
+
+ subroutine zaiopi(lopen, iaunit)
+ implicit none
+c
+ logical, intent(out) :: lopen
+ integer, intent(in) :: iaunit
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) is an array i/o unit open?
+c
+c 2) must call zaiost before first call to zaiopi.
+c*
+c**********
+c
+ lopen = iarec(iaunit).ne.-1
+ return
+ end subroutine zaiopi
+
+ subroutine zaiost
+ implicit none
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for initializing array i/o.
+c
+c 2) see also zaiopn, zaiord, zaiowr, and zaiocl.
+c*
+c**********
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ integer i
+ character*256 value
+c
+c mpi-2 hints for array i/o
+c
+ file_count_zaiord = 0
+ file_count_zaiowr = 0
+ call mpi_info_create(file_info_zaiord,
+ & mpierr)
+ call mpi_info_create(file_info_zaiowr,
+ & mpierr)
+#if defined(AIX)
+ call mpi_info_set(file_info_zaiord,
+ & 'IBM_largeblock_io', !read on calling task
+ & 'true',
+ & mpierr)
+ write(value,'(i10)') (((itdm*jtdm+4095)/4096)*4096)*4
+ call mpi_info_set(file_info_zaiowr,
+ & 'IBM_io_buffer_size',
+ & trim(value), !write from a single task
+ & mpierr)
+#else
+ call mpi_info_free(file_info_zaiord, !set to mpi_info_null
+ & mpierr)
+ call mpi_info_free(file_info_zaiowr, !set to mpi_info_null
+ & mpierr)
+#endif
+c
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'zaiost - Array I/O is MPI-2 I/O from one task per row'
+ endif
+c
+ do i= 1,999
+ iarec(i) = -1
+ enddo
+#if defined(TIMER)
+c
+c initialize timers.
+c
+ call xctmrn(16,'zaio**')
+ call xctmrn(17,'zaiord')
+ call xctmrn(18,'zaiowr')
+#endif
+ return
+ end subroutine zaiost
+
+ subroutine zaiocl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file closing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is mpi-2 i/o.
+c*
+c**********
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiocl)')
+ stop '(zaiocl)'
+ endif
+c
+ iarec(iaunit) = -1
+c
+c --- I/O from first processor in each row
+c
+ if (mproc.eq.mp_1st) then
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiocl - iaunit = ',iaunit
+* call flush(lp)
+* endif
+c
+ call mpi_file_close(iahand(iaunit),mpierr)
+c
+ endif ! I/O from first processor in each row
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiocl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiocl
+
+ subroutine zaiofl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o buffer flushing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is mpi-2 i/o.
+c*
+c**********
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiofl)')
+ stop '(zaiofl)'
+ endif
+c
+c --- I/O from first processor in each row
+c
+ if (mproc.eq.mp_1st) then
+ call mpi_file_sync(iahand(iaunit),mpierr)
+ endif ! I/O from first processor in each row
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiofl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiofl
+
+ subroutine zaioiq(iaunit, irec)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ integer, intent(out) :: irec
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o inquiry.
+c
+c 2) returns the number of records processed, or -1 for a closed file.
+c*
+c**********
+c
+ irec = iarec(iaunit)
+ return
+ end subroutine zaioiq
+
+ subroutine zaiorw(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file rewinding.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is mpi-2 i/o.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiorw)')
+ stop '(zaiorw)'
+ endif
+c
+ iarec(iaunit) = 0
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiorw - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+* endif
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiorw - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiorw
+
+ subroutine zaiord3(h, l, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c*
+c**********
+c
+c this version just calls zaiord l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiord(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit)
+ enddo
+c
+ return
+ end subroutine zaiord3
+
+ subroutine zaiord(h, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#endif
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ real*4 awtmp(itdm,jtdm)
+ equivalence (w(1),awtmp(1,1)) !saves a data copy
+c
+ real*4 htmp
+ common/czioxr/ htmp(idm*jdm)
+ save /czioxr/
+c
+ integer(kind=mpi_offset_kind) disp
+ integer i,j
+ real*4 wmin,wmax
+ real rmin(1),rmax(1)
+#if defined(TIMER)
+c
+ call xctmr0(17)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiord)')
+ stop '(zaiord)'
+ endif
+c
+ iarec(iaunit) = iarec(iaunit) + 1
+c
+ wmin = spval
+ wmax = -spval
+c
+c --- I/O from first processor in each row
+c
+ if (mproc.eq.mp_1st) then
+*
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiord - iaunit,rec = ',iaunit,iarec(iaunit)
+* write(lp,*) 'zaiord - mask.1,1 = ',amsk(1,1)
+* write(lp,*) 'zaiord - h.1,1 = ',atmp(1,1)
+* call flush(lp)
+* endif
+c
+ disp = n2drec
+ disp = (iarec(iaunit)-1)*disp + itdm*j0
+ call mpi_file_read_at(iahand(iaunit),
+ & disp,
+ & w(1+j0*itdm),
+ & itdm*jj,
+ & MTYPE4,
+ & mpistat(1,1),
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ write(lp,*) 'mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiord)')
+ stop '(zaiord)'
+ endif !mpierr
+ if (.not.lmask) then
+c Get min and max of input array section.
+c must be done here because tiles need not cover the full domain.
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= j0+1,j0+jj
+#if defined(ENDIAN_IO)
+ call zaio_endian(w(1+(j-1)*itdm),itdm) !swap to big-endian
+#endif
+ wminy(j) = spval
+ wmaxy(j) = -spval
+ do i= 1,itdm
+ if (w(i+(j-1)*itdm).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+ enddo !i
+ enddo !j
+ wmin = minval(wminy(j0+1:j0+jj))
+ wmax = maxval(wmaxy(j0+1:j0+jj))
+ endif !Not Lmask
+c
+ endif !I/O from first processor in each row
+c
+c --- put field from 1st in row to all tiles
+ call xcaput4(awtmp,htmp, -1)
+c
+c --- Each processor loads h from htmp (where mask = 1)
+c --- Each processor does local min max if lmask is true
+c
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ wminy(j) = spval
+ wmaxy(j) = -spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ h(i,j) = htmp(i+(j-1)*ii)
+ wminy(j) = min( wminy(j), htmp(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), htmp(i+(j-1)*ii) )
+ endif
+ enddo !i
+ enddo !j
+ wmin = minval(wminy(1:jj))
+ wmax = maxval(wmaxy(1:jj))
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ h(i,j) = htmp(i+(j-1)*ii)
+ enddo !i
+ enddo !j
+ endif !lmask:else
+c
+c --- Min/Max broadcast/gather
+c
+ rmin(1) = wmin
+ rmax(1) = wmax
+ call xcminr(rmin)
+ call xcmaxr(rmax)
+ hmin = rmin(1)
+ hmax = rmax(1)
+c
+ if (lmask .and. hmax.eq.spval) then
+ if (mnproc.eq.1) then
+ write(lp,9200) iarec(iaunit),iaunit
+ call flush(lp)
+* cfile = ' '
+* inquire(unit=iaunit+uaoff,name=cfile)
+* write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+* call flush(lp)
+ endif !master
+ call xcstop('(zaiord)')
+ stop '(zaiord)'
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(17)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiord - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiord - can''t read record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ 9200 format(/ /10x,'error in zaiord - record',
+ & i4,' on array I/O unit ',i3,
+ & ' has 2.0**100 outside masked region.'/ /)
+ end subroutine zaiord
+
+ subroutine zaiosk(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for skipping an array read.
+c
+c must call zaiopn for this array unit before calling zaiosk.
+c
+c 2) array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiosk)')
+ stop '(zaiosk)'
+ endif
+c
+ iarec(iaunit) = iarec(iaunit) + 1
+c
+* if (mnproc.eq.1) then
+* write(lp,*) 'zaiosk - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+* endif
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiosk - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiosk
+
+ subroutine zaiowr3(h, l, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c this version just calls zaiowr l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiowr(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit, lreal4)
+ enddo
+ return
+ end subroutine zaiowr3
+
+ subroutine zaiowr(h, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#endif
+c
+ integer iarec,iahand
+ common/czioxx/ iarec(999),iahand(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is mpi-2 i/o.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ include 'mpif.h'
+ integer mpierr,mpireq,mpistat
+ common/xcmpii/ mpierr,mpireq(4),
+ & mpistat(mpi_status_size,4*iqr)
+ save /xcmpii/
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ real*4 awtmp(itdm,jtdm)
+ equivalence (w(1),awtmp(1,1)) !saves a data copy
+c
+ real*4 htmp
+ common/czioxr/ htmp(idm*jdm)
+ save /czioxr/
+c
+ integer(kind=mpi_offset_kind) disp
+ integer i,j,lrec
+ real rmin(1),rmax(1)
+ real*4 data_void(1),vsave4
+#if defined(TIMER)
+c
+ call xctmr0(18)
+#endif
+c
+ if (iarec(iaunit).lt.0) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiowr)')
+ stop '(zaiowr)'
+ endif
+c
+ iarec(iaunit) = iarec(iaunit) + 1
+c
+ data_void(1) = spval
+#if defined(ENDIAN_IO)
+ call zaio_endian(data_void,1) !swap to big-endian
+#endif
+c
+c --- Copy into real*4 buffer, and find Min,Max
+c
+ if (lreal4) then
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ htmp(i+(j-1)*ii) = h(i,j)
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ else
+ htmp(i+(j-1)*ii) = spval
+ endif
+#if defined(REAL4)
+! --- h(i,j) = htmp(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = htmp(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ else !.not.lmask
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ htmp(i+(j-1)*ii) = h(i,j)
+ if (htmp(i+(j-1)*ii).ne.spval) then
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ endif
+#if defined(REAL4)
+! --- h(i,j) = htmp(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = htmp(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ endif !lmask:else
+ else !.not.lreal4
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ htmp(i+(j-1)*ii) = h(i,j)
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ else
+ htmp(i+(j-1)*ii) = spval
+ endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ else !.not.lmask
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ htmp(i+(j-1)*ii) = h(i,j)
+ if (htmp(i+(j-1)*ii).ne.spval) then
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ endif !lmask:else
+ endif !lreal4:else
+c
+ rmin(1) = minval(wminy(1:jj))
+ rmax(1) = maxval(wmaxy(1:jj))
+ call xcminr(rmin)
+ call xcmaxr(rmax)
+ hmin = rmin(1)
+ hmax = rmax(1)
+c
+c --- I/O from first processor in each row.
+#if defined(ENDIAN_IO)
+c --- htmp and data_void are already big-endian
+#endif
+c
+ vsave4 = vland4
+ vland4 = data_void(1)
+ call xcaget4(awtmp,htmp, -1) !htmp to w (awtmp) for each row.
+ vland4 = vsave4
+c
+ if (mproc.eq.mp_1st) then
+ if (nproc.eq.jpr) then
+ do i= itdm*jtdm+1,n2drec
+ w(i) = data_void(1)
+ enddo
+ lrec = n2drec - itdm*j0
+ else
+ lrec = itdm*jj
+ endif
+c
+ disp = n2drec
+ disp = (iarec(iaunit)-1)*disp + itdm*j0
+* call mpi_file_write_at(iahand(iaunit),
+ call mpi_file_write_at_all(iahand(iaunit),
+ & disp,
+ & w(1+itdm*j0),
+ & lrec,
+ & MTYPE4,
+ & mpistat(1,1),
+ & mpierr)
+ if (mpierr.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ write(lp,*) 'mpierr = ',mpierr
+ call flush(lp)
+ call xchalt('(zaiowr)')
+ stop '(zaiowr)'
+ endif !mpierr
+ endif !I/O from first processor in each row
+c
+#if defined(TIMER)
+c
+ call xctmr1(18)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiowr - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiowr - can''t write record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ end subroutine zaiowr
diff --git a/src_2.2.18_3_one/mod_za_mp1.h b/src_2.2.18_3_one/mod_za_mp1.h
new file mode 100755
index 0000000..1d9b5db
--- /dev/null
+++ b/src_2.2.18_3_one/mod_za_mp1.h
@@ -0,0 +1,1443 @@
+c
+c-----------------------------------------------------------------------
+c
+c machine dependent I/O routines.
+c message passing version, with all I/O from first processor.
+c contained in module mod_za.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine zagetc(cline,ios, iunit)
+ implicit none
+c
+ character*80, intent(out) :: cline
+ integer, intent(out) :: ios
+ integer, intent(in) :: iunit
+c
+c**********
+c*
+c 1) machine specific routine for reading one text line from a file.
+c
+c 2) The read is performed on the first processor only.
+c*
+c**********
+c
+ integer iline,ibuf
+ common/czgetc/ iline(81,0:1),ibuf
+ save /czgetc/
+c
+ integer i
+c
+c --- I/O from first processor only
+c
+ ibuf = mod(ibuf+1,2)
+c
+ if (mnproc.eq.1) then
+ read(iunit,'(a)',iostat=ios) cline
+ do i= 1,80
+ iline(i,ibuf) = ichar(cline(i:i))
+ enddo
+ iline(81,ibuf) = ios
+ endif
+c
+c broadcast to all other processors
+c
+ call xcgetc(iline(:,ibuf))
+ do i= 1,80
+ cline(i:i) = char(iline(i,ibuf))
+ enddo
+ ios = iline(81,ibuf) ! iostat value
+ return
+ end subroutine zagetc
+
+ subroutine zaiopn(cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopn.
+c see also 'zaiope' and 'zaiopf'.
+c
+c 2) the filename is taken from the environment variable FORxxxA,
+c where xxx = iaunit, with default fort.xxxa.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cfile*256,cenv*7
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiopn)')
+ stop '(zaiopn)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiopn - iaunit = ',iaunit
+* call flush(lp)
+c
+c get filename.
+c
+ write(cenv,"('FOR',i3.3,'A')") iaunit
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(cfile,"('fort.',i3.3,'a')") iaunit
+ endif
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+ call xcsync(no_flush)
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(zaiopn)')
+ stop '(zaiopn)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(zaiopn)')
+ stop '(zaiopn)'
+ endif !ios
+#endif
+ if (cstat.eq.'scratch' .or.
+ & cstat.eq.'SCRATCH' ) then
+ open(unit=iaunit+uaoff,
+ & form='unformatted', status='scratch',
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ else
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9100) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ if (cstat.eq.'scratch' .or.
+ & cstat.eq.'SCRATCH' ) then
+ write(6,'(a)') "status='SCRATCH'"
+ else
+ write(6,'(3a)') 'FILENAME="',trim(cfile),'"'
+ endif
+ call flush(lp)
+ call xchalt('(zaiopn)')
+ stop '(zaiopn)'
+ endif !ios
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopn - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiopn - can''t asnunit ',i3,
+ & ', for array I/O.'/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiopn - can''t open unit ',i3,
+ & ', for array I/O.'/ /)
+ end subroutine zaiopn
+
+ subroutine zaiope(cenv,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cenv,cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiope.
+c see also 'zaiopn' and 'zaiopf'.
+c
+c 2) the filename is taken from environment variable 'cenv'.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cfile*256
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiope)')
+ stop '(zaiope)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiope - iaunit = ',iaunit
+* call flush(lp)
+c
+c get filename.
+c
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(lp,9300) trim(cenv)
+ write(lp,*) 'iaunit = ',iaunit
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+ call xcsync(no_flush)
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+c
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif !ios
+#endif
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ if (ios.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ call xchalt('(zaiope)')
+ stop '(zaiope)'
+ endif !ios
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiope - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiope - can''t asnunit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiope - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ 9300 format(/ /10x,'error in zaiope - environment variable ',a,
+ & ' not defined'/ /)
+ end subroutine zaiope
+
+ subroutine zaiopf(cfile,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cfile,cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopf.
+c see also 'zaiopn' and 'zaiope'.
+c
+c 2) the filename is taken from 'cfile'.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiopf)')
+ stop '(zaiopf)'
+ endif
+c
+ iarec(iaunit) = 0
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiopf - iaunit = ',iaunit
+* call flush(lp)
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+ call xcsync(no_flush)
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+c
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(zaiopf)')
+ stop '(zaiopf)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(zaiopf)')
+ stop '(zaiopf)'
+ endif !ios
+#endif
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ if (ios.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(zaiopf)')
+ stop '(zaiopf)'
+ endif !ios
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopf - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiopf - can''t asnunit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiopf - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ end subroutine zaiopf
+
+ subroutine zaiopi(lopen, iaunit)
+ implicit none
+c
+ logical, intent(out) :: lopen
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) is an array i/o unit open?
+c
+c 2) must call zaiost before first call to zaiopi.
+c*
+c**********
+c
+ lopen = iarec(iaunit).ne.-1
+ return
+ end subroutine zaiopi
+
+ subroutine zaiost
+ implicit none
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for initializing array i/o.
+c
+c 2) see also zaiopn, zaiord, zaiowr, and zaiocl.
+c*
+c**********
+c
+ integer i
+c
+ if (mnproc.eq.1) then
+ write(lp,'(/a/)')
+ & 'zaiost - Array I/O is Fortran DA I/O from the 1st task'
+ endif
+c
+ do i= 1,999
+ iarec(i) = -1
+ enddo
+#if defined(TIMER)
+c
+c initialize timers.
+c
+ call xctmrn(16,'zaio**')
+ call xctmrn(17,'zaiord')
+ call xctmrn(18,'zaiowr')
+ call xctmrn(19,'zaioIO')
+#endif
+ return
+ end subroutine zaiost
+
+ subroutine zaiocl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file closing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+c
+ integer ios
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiocl)')
+ stop '(zaiocl)'
+ endif
+c
+ iarec(iaunit) = -1
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiocl - iaunit = ',iaunit
+* call flush(lp)
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ close(unit=iaunit+uaoff, status='keep')
+#if defined(T3E) || defined(YMP) || defined(X1)
+ call asnunit(iaunit+uaoff,'-R',ios)
+#endif
+ endif
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiocl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiocl
+
+ subroutine zaiofl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o buffer flushing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+c
+ integer irlen
+ character cfile*256
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiofl)')
+ stop '(zaiofl)'
+ endif
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ inquire(unit=iaunit+uaoff, name=cfile, recl=irlen)
+ close( unit=iaunit+uaoff, status='keep')
+ open( unit=iaunit+uaoff, file=cfile, form='unformatted',
+ & access='direct', recl=irlen)
+ endif
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiofl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiofl
+
+ subroutine zaioiq(iaunit, irec)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ integer, intent(out) :: irec
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o inquiry.
+c
+c 2) returns the number of records processed, or -1 for a closed file.
+c*
+c**********
+c
+ irec = iarec(iaunit)
+ return
+ end subroutine zaioiq
+
+ subroutine zaiorw(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file rewinding.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiorw)')
+ stop '(zaiorw)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = 0
+ endif
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiorw - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiorw - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiorw
+
+ subroutine zaiord3(h, l, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c*
+c**********
+c
+c this version just calls zaiord l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiord(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit)
+ enddo
+c
+ return
+ end subroutine zaiord3
+
+ subroutine zaiord(h, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#endif
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c
+c 5) Optimized by Dan Moore, Planning Systems Inc., August 2005.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ real*4 awtmp(itdm,jtdm)
+ equivalence (w(1),awtmp(1,1)) !saves a data copy
+c
+ real*4 htmp
+ common/czioxr/ htmp(idm*jdm)
+ save /czioxr/
+c
+ character cfile*256
+ integer ios, i,j
+ real*4 wmin,wmax
+ real rmin(1),rmax(1)
+#if defined(TIMER)
+c
+ call xctmr0(17)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiord)')
+ stop '(zaiord)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ endif
+c
+ wmin = spval
+ wmax = -spval
+c
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*)'In initial proc 1 section'
+* write(lp,*) 'zaiord - iaunit,rec = ',iaunit,iarec(iaunit)
+* write(lp,*) 'zaiord - mask.1,1 = ',amsk(1,1)
+* write(lp,*) 'zaiord - h.1,1 = ',atmp(1,1)
+* call flush(lp)
+c
+ if (iarec(iaunit).eq.-99) then !dummy I/O
+ w(1:n2drec) = 0.0
+ else !standard I/O
+ call zaiordd(w,n2drec, iaunit+uaoff,iarec(iaunit),ios)
+ if (ios.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ call xchalt('(zaiord)')
+ stop '(zaiord)'
+ endif !ios
+ endif ! dummy I/O
+* write(lp,*)'I/O on proc 1 finished?'
+* write(lp,*)'lmask = ',lmask
+c
+ if (.not.lmask)then
+c Get global min and max on first processor.
+c must be done here because tiles need not cover the full domain.
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+#if defined(ENDIAN_IO)
+ call zaio_endian(w(1+(j-1)*itdm),itdm) !swap to big-endian
+#endif
+ wminy(j) = spval
+ wmaxy(j) = -spval
+ do i= 1,itdm
+ if (w(i+(j-1)*itdm).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+ enddo !i
+ enddo !j
+ wmin = minval(wminy(1:jtdm))
+ wmax = maxval(wmaxy(1:jtdm))
+ endif !Not Lmask (global min,max on processor #1)
+c
+ endif !end I/O from first processor only
+c
+c --- put field from 1st processor to all tiles
+ call xcaput4(awtmp,htmp, 1)
+c
+c --- Each processor loads h from htmp (where mask = 1)
+c --- Each processor does local min max if lmask is true
+c
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ wminy(j) = spval
+ wmaxy(j) = -spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ h(i,j) = htmp(i+(j-1)*ii)
+ wminy(j) = min( wminy(j), htmp(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), htmp(i+(j-1)*ii) )
+ endif
+ enddo !i
+ enddo !j
+ wmin = minval(wminy(1:jj))
+ wmax = maxval(wmaxy(1:jj))
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ do i= 1,ii
+ h(i,j) = htmp(i+(j-1)*ii)
+ enddo !i
+ enddo !j
+ endif !lmask:else
+c
+c --- Min/Max broadcast/gather
+c
+ rmin(1) = wmin
+ rmax(1) = wmax
+ call xcminr(rmin)
+ call xcmaxr(rmax)
+ hmin = rmin(1)
+ hmax = rmax(1)
+c
+ if (lmask .and. hmax.eq.spval) then
+ if (mnproc.eq.1) then
+ write(lp,9200) iarec(iaunit),iaunit
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ endif !master
+ call xcstop('(zaiord)')
+ stop '(zaiord)'
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(17)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiord - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiord - can''t read record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ 9200 format(/ /10x,'error in zaiord - record',
+ & i4,' on array I/O unit ',i3,
+ & ' has 2.0**100 outside masked region.'/ /)
+ end subroutine zaiord
+
+ subroutine zaiordd(a,n, iunit,irec,ios)
+ implicit none
+c
+ integer, intent(in) :: n,iunit,irec
+ integer, intent(out) :: ios
+ real*4, intent(out) :: a(n)
+c
+c**********
+c*
+c 1) direct access read a single record.
+#if defined(ENDIAN_IO)
+c on exit, a is still little-endian
+#endif
+c
+c 2) expressed as a subroutine because i/o with
+c implied do loops can be slow on some machines.
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(19)
+#endif
+ read(unit=iunit, rec=irec, iostat=ios) a
+#if defined(TIMER)
+c
+ call xctmr1(19)
+#endif
+ return
+ end subroutine zaiordd
+
+ subroutine zaiosk(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for skipping an array read.
+c
+c must call zaiopn for this array unit before calling zaiosk.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiosk)')
+ stop '(zaiosk)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ endif
+c
+c --- I/O from first processor only
+c
+ if (mnproc.eq.1) then
+*
+* write(lp,*) 'zaiosk - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+c
+ endif ! I/O from first processor only
+ call xcsync(no_flush)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiosk - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiosk
+
+ subroutine zaiowr3(h, l, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c this version just calls zaiowr l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiowr(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit, lreal4)
+ enddo
+ return
+ end subroutine zaiowr3
+
+ subroutine zaiowr(h, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#endif
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c
+c 6) Optimized by Dan Moore, Planning Systems Inc., August 2005.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ real*4 awtmp(itdm,jtdm)
+ equivalence (w(1),awtmp(1,1)) !saves a data copy
+c
+ real*4 htmp
+ common/czioxr/ htmp(idm*jdm)
+ save /czioxr/
+c
+ character cfile*256
+ integer ios, i,j
+ real rmin(1),rmax(1)
+ real*4 data_void(1),vsave4
+#if defined(TIMER)
+c
+ call xctmr0(18)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call xcstop('(zaiowr)')
+ stop '(zaiowr)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ endif
+c
+ data_void(1) = spval
+#if defined(ENDIAN_IO)
+ call zaio_endian(data_void,1) !swap to big-endian
+#endif
+c
+c --- Copy into real*4 buffer, and find Min,Max
+c
+ if (lreal4) then
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ htmp(i+(j-1)*ii) = h(i,j)
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ else
+ htmp(i+(j-1)*ii) = spval
+ endif
+#if defined(REAL4)
+! --- h(i,j) = htmp(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = htmp(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ else !.not.lmask
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ htmp(i+(j-1)*ii) = h(i,j)
+ if (htmp(i+(j-1)*ii).ne.spval) then
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ endif
+#if defined(REAL4)
+! --- h(i,j) = htmp(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = htmp(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ endif !lmask:else
+ else !.not.lreal4
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ htmp(i+(j-1)*ii) = h(i,j)
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ else
+ htmp(i+(j-1)*ii) = spval
+ endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ else !.not.lmask
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j)= spval
+ wmaxy(j)=-spval
+ do i= 1,ii
+ htmp(i+(j-1)*ii) = h(i,j)
+ if (htmp(i+(j-1)*ii).ne.spval) then
+ wminy(j)=min(wminy(j),htmp(i+(j-1)*ii))
+ wmaxy(j)=max(wmaxy(j),htmp(i+(j-1)*ii))
+ endif
+ enddo !i
+#if defined(ENDIAN_IO)
+ call zaio_endian(htmp(1+(j-1)*ii),ii) !swap to big-endian
+#endif
+ enddo !j
+ endif !lmask:else
+ endif !lreal4:else
+c
+ rmin(1) = minval(wminy(1:jj))
+ rmax(1) = maxval(wmaxy(1:jj))
+ call xcminr(rmin)
+ call xcmaxr(rmax)
+ hmin = rmin(1)
+ hmax = rmax(1)
+c
+c --- I/O from first processor only
+#if defined(ENDIAN_IO)
+c --- htmp and data_void are already big-endian
+#endif
+c
+ vsave4 = vland4
+ vland4 = data_void(1)
+ call xcaget4(awtmp,htmp, 1) !htmp to w (awtmp) on 1st processor
+ vland4 = vsave4
+c
+ if (mnproc.eq.1) then
+ do i= itdm*jtdm+1,n2drec
+ w(i) = data_void(1)
+ enddo
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ call zaiowrd(w,n2drec, iaunit+uaoff,iarec(iaunit),ios)
+ if (ios.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ call xchalt('(zaiowr)')
+ stop '(zaiowr)'
+ endif !ios
+ endif !standard I/O
+ endif !I/O from first processor only
+c
+#if defined(TIMER)
+c
+ call xctmr1(18)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiowr - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiowr - can''t write record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ end subroutine zaiowr
+
+ subroutine zaiowrd(a,n, iunit,irec,ios)
+ implicit none
+c
+ integer, intent(in) :: n,iunit,irec
+ integer, intent(out) :: ios
+ real*4, intent(in) :: a(n)
+c
+c**********
+c*
+c 1) direct access write a single record.
+#if defined(ENDIAN_IO)
+c a is already big-endian.
+#endif
+c
+c 2) expressed as a subroutine because i/o with
+c implied do loops can be slow on some machines.
+c*
+c**********
+c
+#if defined(TIMER)
+c
+ call xctmr0(19)
+#endif
+ write(unit=iunit, rec=irec, iostat=ios) a
+#if defined(TIMER)
+c
+ call xctmr1(19)
+#endif
+ return
+ end subroutine zaiowrd
diff --git a/src_2.2.18_3_one/mod_za_sm.h b/src_2.2.18_3_one/mod_za_sm.h
new file mode 100755
index 0000000..76953ba
--- /dev/null
+++ b/src_2.2.18_3_one/mod_za_sm.h
@@ -0,0 +1,1203 @@
+c
+c-----------------------------------------------------------------------
+c
+c machine dependent I/O routines.
+c single processor version, contained in mod_za.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine zagetc(cline,ios, iunit)
+ implicit none
+c
+ character*80, intent(out) :: cline
+ integer, intent(out) :: ios
+ integer, intent(in) :: iunit
+c
+c**********
+c*
+c 1) machine specific routine for reading one text line from a file.
+c*
+c**********
+c
+ read(iunit,'(a)',iostat=ios) cline
+ return
+ end subroutine zagetc
+
+ subroutine zaiopn(cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopn.
+c see also 'zaiope' and 'zaiopf'.
+c
+c 2) the filename is taken from the environment variable FORxxxA,
+c where xxx = iaunit, with default fort.xxxa.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cfile*256,cenv*7
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiopn)'
+ endif
+c
+c get filename.
+c
+ write(cenv,"('FOR',i3.3,'A')") iaunit
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(cfile,"('fort.',i3.3,'a')") iaunit
+ endif
+* write(lp,*) 'zaiopn - iaunit = ',iaunit
+* call flush(lp)
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ stop '(zaiopn)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ stop '(zaiopn)'
+ endif !ios
+#endif
+ if (cstat.eq.'scratch' .or.
+ & cstat.eq.'SCRATCH' ) then
+ open(unit=iaunit+uaoff,
+ & form='unformatted', status='scratch',
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ else
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9100) iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ if (cstat.eq.'scratch' .or.
+ & cstat.eq.'SCRATCH' ) then
+ write(lp,'(a)') "status='SCRATCH'"
+ else
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ endif
+ call flush(lp)
+ stop '(zaiopn)'
+ endif !ios
+ iarec(iaunit) = 0
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopn - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiopn - can''t asnunit ',i3,
+ & ', for array I/O.'/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiopn - can''t open unit ',i3,
+ & ', for array I/O.'/ /)
+ end subroutine zaiopn
+
+ subroutine zaiope(cenv,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cenv,cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiope.
+c see also 'zaiopn' and 'zaiopf'.
+c
+c 2) the filename is taken from environment variable 'cenv'.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cfile*256
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiope)'
+ endif
+c
+c get filename.
+c
+ cfile = ' '
+ call getenv(cenv,cfile)
+ if (cfile.eq.' ') then
+ write(lp,9300) trim(cenv)
+ write(lp,*) 'iaunit = ',iaunit
+ call flush(lp)
+ stop '(zaiope)'
+ endif
+* write(lp,*) 'zaiope - iaunit = ',iaunit
+* call flush(lp)
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+c
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ stop '(zaiope)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ stop '(zaiope)'
+ endif !ios
+#endif
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ if (ios.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ write(lp,*) 'cenv = ',trim(cenv)
+ call flush(lp)
+ stop '(zaiope)'
+ endif !ios
+ iarec(iaunit) = 0
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiope - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiope - can''t asnunit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiope - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ 9300 format(/ /10x,'error in zaiope - environment variable ',a,
+ & ' not defined'/ /)
+ end subroutine zaiope
+
+ subroutine zaiopf(cfile,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cfile,cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to zaiopf.
+c see also 'zaiopn' and 'zaiope'.
+c
+c 2) the filename is taken from 'cfile'.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by zaiord and zaiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using zaiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiopf)'
+ endif
+* write(lp,*) 'zaiopf - iaunit = ',iaunit
+* call flush(lp)
+c
+c dummy I/O?
+c
+ if (cfile.eq.'/dev/null' .or.
+ & cfile.eq.'/dev/zero' ) then
+ iarec(iaunit) = -99
+#if defined(TIMER)
+ call xctmr1(16)
+#endif
+ return
+ endif
+c
+c open file.
+c
+ inquire(iolength=nrecl) w
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+c
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ stop '(zaiopf)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ stop '(zaiopf)'
+ endif !ios
+#endif
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ if (ios.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ stop '(zaiopf)'
+ endif !ios
+ iarec(iaunit) = 0
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiopf - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in zaiopf - can''t asnunit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+#endif
+ 9100 format(/ /10x,'error in zaiopf - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ end subroutine zaiopf
+
+ subroutine zaiopi(lopen, iaunit)
+ implicit none
+c
+ logical, intent(out) :: lopen
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) is an array i/o unit open?
+c
+c 2) must call zaiost before first call to zaiopi.
+c*
+c**********
+c
+ lopen = iarec(iaunit).ne.-1
+ return
+ end subroutine zaiopi
+
+ subroutine zaiost
+ implicit none
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for initializing array i/o.
+c
+c 2) see also zaiopn, zaiord, zaiowr, and zaiocl.
+c*
+c**********
+c
+ integer i
+c
+ write(lp,'(/a/)')
+ & 'zaiost - Array I/O is Fortran DA I/O'
+c
+ do i= 1,999
+ iarec(i) = -1
+ enddo
+#if defined(TIMER)
+c
+c initialize timers.
+c
+ call xctmrn(16,'zaio**')
+ call xctmrn(17,'zaiord')
+ call xctmrn(18,'zaiowr')
+#endif
+ return
+ end subroutine zaiost
+
+ subroutine zaiocl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file closing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+c
+ integer ios
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+* write(lp,*) 'zaiocl - iaunit = ',iaunit
+* call flush(lp)
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiocl)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ close(unit=iaunit+uaoff, status='keep')
+#if defined(T3E) || defined(YMP) || defined(X1)
+ call asnunit(iaunit+uaoff,'-R',ios)
+#endif
+ endif
+ iarec(iaunit) = -1
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiocl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiocl
+
+ subroutine zaiofl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o buffer flushing.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+c
+ integer irlen
+ character cfile*256
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiofl)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ inquire(unit=iaunit+uaoff, name=cfile, recl=irlen)
+ close( unit=iaunit+uaoff, status='keep')
+ open( unit=iaunit+uaoff, file=cfile, form='unformatted',
+ & access='direct', recl=irlen)
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiofl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiofl
+
+ subroutine zaioiq(iaunit, irec)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ integer, intent(out) :: irec
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o inquiry.
+c
+c 2) returns the number of records processed, or -1 for a closed file.
+c*
+c**********
+c
+ irec = iarec(iaunit)
+ return
+ end subroutine zaioiq
+
+ subroutine zaiorw(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file rewinding.
+c
+c must call zaiopn for this array unit before calling zaiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiorw)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = 0
+ endif
+* write(lp,*) 'zaiorw - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiorw - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiorw
+
+ subroutine zaiord3(h, l, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(out) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c*
+c**********
+c
+c this version just calls zaiord l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiord(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit)
+ enddo
+c
+ return
+ end subroutine zaiord3
+
+ subroutine zaiord(h, mask,lmask, hmin,hmax, iaunit)
+ implicit none
+c
+ logical, intent(in) :: lmask
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(out) :: h
+#endif
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array reading.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the
+c array, ignoring array elements set to 2.0**100.
+c if lmask==.true. the range is calculated only where mask.ne.0,
+c with all other values unchanged in h on exit. It is then an
+c error if mask.ne.0 anywhere the input is 2.0**100.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ character cfile*256
+ integer ios, i,j
+#if defined(TIMER)
+c
+ call xctmr0(17)
+#endif
+c
+* write(lp,*) 'zaiord - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiord)'
+ endif
+c
+ if (iarec(iaunit).eq.-99) then !dummy I/O
+ w(1:n2drec) = 0.0
+ else !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ call zaiordd(w,n2drec, iaunit+uaoff,iarec(iaunit),ios)
+ if (ios.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ stop '(zaiord)'
+ endif !ios
+ endif
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ if (mask(i,j).ne.0) then
+ h(i,j) = w(i+(j-1)*itdm)
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ h(i,j) = w(i+(j-1)*itdm)
+ if (w(i+(j-1)*itdm).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+ enddo
+ enddo
+ endif
+ hmin = minval(wminy(1:jtdm))
+ hmax = maxval(wmaxy(1:jtdm))
+c
+ if (lmask .and. hmax.eq.spval) then
+ write(lp,9200) iarec(iaunit),iaunit
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ stop '(zaiord)'
+ endif
+c
+#if defined(TIMER)
+c
+ call xctmr1(17)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiord - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiord - can''t read record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ 9200 format(/ /10x,'error in zaiord - record',
+ & i4,' on array I/O unit ',i3,
+ & ' has 2.0**100 outside masked region.'/ /)
+ end subroutine zaiord
+
+ subroutine zaiordd(a,n, iunit,irec,ios)
+ implicit none
+c
+ integer, intent(in) :: n,iunit,irec
+ integer, intent(out) :: ios
+ real*4, intent(out) :: a(n)
+c
+c**********
+c*
+c 1) direct access read a single record.
+c
+c 2) expressed as a subroutine because i/o with
+c implied do loops can be slow on some machines.
+c*
+c**********
+c
+ read(unit=iunit, rec=irec, iostat=ios) a
+#if defined(ENDIAN_IO)
+ call zaio_endian(a,n)
+#endif
+ return
+ end subroutine zaiordd
+
+ subroutine zaiosk(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for skipping an array read.
+c
+c must call zaiopn for this array unit before calling zaiosk.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c*
+c**********
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+* write(lp,*) 'zaiosk - iaunit,rec = ',iaunit,iarec(iaunit)
+* call flush(lp)
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiosk)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiosk - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine zaiosk
+
+ subroutine zaiowr3(h, l, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c this version just calls zaiowr l times.
+c
+ integer k
+c
+ do k= 1,l
+ call zaiowr(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit, lreal4)
+ enddo
+ return
+ end subroutine zaiowr3
+
+ subroutine zaiowr(h, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#endif
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array writing.
+c
+c must call zaiopn for this array unit before calling zaiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to zaiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ character cfile*256
+ integer ios, i,j
+#if defined(TIMER)
+c
+ call xctmr0(18)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ stop '(zaiowr)'
+ endif
+c
+ if (lreal4) then
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ if (mask(i,j).ne.0) then
+ w(i+(j-1)*itdm) = h(i,j)
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ else
+ w(i+(j-1)*itdm) = spval
+ endif
+#if defined(REAL4)
+! --- h(i,j) = w(i+(j-1)*itdm) ! h is already real*4
+#else
+ h(i,j) = w(i+(j-1)*itdm) ! h is not real*4, so update it
+#endif
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ w(i+(j-1)*itdm) = h(i,j)
+ if (w(i+(j-1)*itdm).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+#if defined(REAL4)
+! --- h(i,j) = w(i+(j-1)*itdm) ! h is already real*4
+#else
+ h(i,j) = w(i+(j-1)*itdm) ! h is not real*4, so update it
+#endif
+ enddo
+ enddo
+ endif
+ else
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ if (mask(i,j).ne.0) then
+ w(i+(j-1)*itdm) = h(i,j)
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ else
+ w(i+(j-1)*itdm) = spval
+ endif
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jtdm
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,itdm
+ w(i+(j-1)*itdm) = h(i,j)
+ if (w(i+(j-1)*itdm).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*itdm) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*itdm) )
+ endif
+ enddo
+ enddo
+ endif
+ endif
+ do i= itdm*jtdm+1,n2drec
+ w(i) = spval
+ enddo
+ hmin = minval(wminy(1:jtdm))
+ hmax = maxval(wmaxy(1:jtdm))
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ iarec(iaunit) = iarec(iaunit) + 1
+ call zaiowrd(w,n2drec, iaunit+uaoff,iarec(iaunit),ios)
+ if (ios.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ stop '(zaiowr)'
+ endif !ios
+ endif
+#if defined(TIMER)
+c
+ call xctmr1(18)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in zaiowr - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in zaiowr - can''t write record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ end subroutine zaiowr
+ subroutine zaiowrd(a,n, iunit,irec,ios)
+ implicit none
+c
+ integer, intent(in) :: n,iunit,irec
+ integer, intent(out) :: ios
+ real*4, intent(in) :: a(n)
+c
+c**********
+c*
+c 1) direct access write a single record.
+c
+c 2) expressed as a subroutine because i/o with
+c implied do loops can be slow on some machines.
+c*
+c**********
+c
+#if defined(ENDIAN_IO)
+ call zaio_endian(a,n) ! overwrites a
+#endif
+ write(unit=iunit, rec=irec, iostat=ios) a
+ return
+ end subroutine zaiowrd
diff --git a/src_2.2.18_3_one/mod_za_zt.h b/src_2.2.18_3_one/mod_za_zt.h
new file mode 100755
index 0000000..31bed62
--- /dev/null
+++ b/src_2.2.18_3_one/mod_za_zt.h
@@ -0,0 +1,434 @@
+c
+c-----------------------------------------------------------------------
+c
+c machine dependent I/O routines.
+c per tile version, contained in mod_za.
+c
+c author: Alan J. Wallcraft, NRL.
+c
+c-----------------------------------------------------------------------
+c
+ subroutine ztiopf(cfile,cstat, iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+ character*(*), intent(in) :: cfile,cstat
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for opening a file for array i/o.
+c
+c must call zaiost before first call to ztiopf.
+c see also 'ztiopn' and 'ztiope'.
+c
+c 2) the filename is taken from 'cfile'.
+c
+c array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c cstat indicates the file type, it can be 'scratch', 'old', or
+c 'new'.
+c all i/o to iaunit must be performed by ztiowr.
+c arrays passed to these routines must conform to 'h'.
+c the file should be closed using ztiocl.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ integer ios,nrecl
+ character cact*9
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+c test file state.
+c
+ if (iarec(iaunit).ne.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ call xchalt('(ztiopf)')
+ stop '(ztiopf)'
+ endif
+* write(lp,*) 'ztiopf - iaunit = ',iaunit
+* call flush(lp)
+c
+c open file.
+c
+ inquire(iolength=nrecl) w(1:ii*jj)
+c
+ if (cstat.eq.'OLD' .or.
+ & cstat.eq.'old' ) then
+ cact = 'READ'
+ elseif (cstat.eq.'NEW' .or.
+ & cstat.eq.'new' ) then
+ cact = 'WRITE'
+ else
+ cact = 'READWRITE'
+ endif
+c
+#if defined(X1)
+ call asnunit(iaunit+uaoff,'-F event,cachea:4096:4:2 -B on',ios)
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(ztiopf)')
+ stop '(ztiopf)'
+ endif !ios
+#endif
+#if defined(YMP)
+ if (mod(nrecl,16384).eq.0 .and. nrecl.gt.16384*4) then
+ call asnunit(iaunit+uaoff,'-F syscall -N ieee',ios)
+ else
+ call asnunit(iaunit+uaoff,'-F cachea:8:16:2 -N ieee',ios)
+ endif
+ if (ios.ne.0) then
+ write(lp,9050) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(ztiopf)')
+ stop '(ztiopf)'
+ endif !ios
+#endif
+ open(unit=iaunit+uaoff, file=cfile,
+ & form='unformatted', status=cstat,
+ & access='direct', recl=nrecl, action=cact, iostat=ios)
+ if (ios.ne.0) then
+ write(lp,9100) iaunit,trim(cfile)
+ write(lp,*) 'ios = ',ios
+ call flush(lp)
+ call xchalt('(ztiopf)')
+ stop '(ztiopf)'
+ endif !ios
+ iarec(iaunit) = 0
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in ztiopf - array I/O unit ',
+ & i3,' is not marked as available.'/ /)
+#if defined(YMP) || defined(X1)
+ 9050 format(/ /10x,'error in ztiopf - can''t asnunit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+#endif
+ 9100 format(/ /10x,'error in ztiopf - can''t open unit ',i3,
+ & ', for array I/O.' /
+ & 10x,'cfile = ',a/ /)
+ end subroutine ztiopf
+
+ subroutine ztiocl(iaunit)
+ implicit none
+c
+ integer, intent(in) :: iaunit
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array i/o file closing.
+c
+c must call ztiopn for this array unit before calling ztiocl.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c*
+c**********
+c
+ integer ios
+#if defined(TIMER)
+c
+ call xctmr0(16)
+#endif
+c
+* write(lp,*) 'ztiocl - iaunit = ',iaunit
+* call flush(lp)
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ call xchalt('(ztiocl)')
+ stop '(ztiocl)'
+ endif
+c
+ if (iarec(iaunit).ne.-99) then !standard I/O
+ close(unit=iaunit+uaoff, status='keep')
+#if defined(T3E) || defined(YMP) || defined(X1)
+ call asnunit(iaunit+uaoff,'-R',ios)
+#endif
+ endif
+ iarec(iaunit) = -1
+#if defined(TIMER)
+c
+ call xctmr1(16)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in ztiocl - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ end subroutine ztiocl
+
+ subroutine ztiowr3(h, l, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: l,iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin(l),hmax(l)
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin(l),hmax(l)
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l),
+ & intent(inout) :: h
+#endif
+c
+c**********
+c*
+c 1) machine specific routine for 3-d array writing.
+c
+c must call ztiopn for this array unit before calling ztiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to ztiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c this version just calls ztiowr l times.
+c
+ integer k
+c
+ do k= 1,l
+ call ztiowr(h(1-nbdy,1-nbdy,k), mask,lmask,
+ & hmin(k),hmax(k), iaunit, lreal4)
+ enddo
+ return
+ end subroutine ztiowr3
+
+ subroutine ztiowr(h, mask,lmask, hmin,hmax, iaunit, lreal4)
+ implicit none
+c
+ logical, intent(in) :: lmask,lreal4
+ integer, intent(in) :: iaunit
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: mask
+#if defined(REAL4)
+ real*4, intent(out) :: hmin,hmax
+ real*4, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#else
+ real, intent(out) :: hmin,hmax
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: h
+#endif
+c
+ integer iarec
+ common/czioxx/ iarec(999)
+ save /czioxx/
+c
+c**********
+c*
+c 1) machine specific routine for array writing.
+c
+c must call ztiopn for this array unit before calling ztiord.
+c
+c 2) array i/o is fortran real*4 direct access i/o to unit iaunit+uaoff.
+c
+c 3) iaunit+uaoff is the i/o unit used for arrays. array i/o might not
+c use fortran i/o units, but, for compatability, assume that
+c iaunit+uaoff refers to a fortran i/o unit anyway.
+c the array, 'h', must conform to that passed in the associated
+c call to ztiopn.
+c
+c 4) hmin,hmax are returned as the minimum and maximum value in the array.
+c if lmask==.true. the range is only where mask.ne.0, with all other
+c values output as 2.0**100.
+c
+c 5) If lreal4==.true. then h is overwritten on exit with real*4 version
+c of the same array. This is typically used for reproducability on
+c restart.
+c*
+c**********
+c
+c --- spval = data void marker, 2^100 or about 1.2676506e30
+c --- n2drec = size of output 2-d array, multiple of 4096
+ real*4 spval
+ parameter (spval=2.0**100)
+ integer n2drec
+ parameter (n2drec=((itdm*jtdm+4095)/4096)*4096)
+c
+ real*4 w,wminy,wmaxy
+ common/czioxw/ w(n2drec),wminy(jtdm),wmaxy(jtdm)
+ save /czioxw/
+c
+ character cfile*256
+ integer ios, i,j
+#if defined(TIMER)
+c
+ call xctmr0(18)
+#endif
+c
+ if (iarec(iaunit).eq.-1) then
+ write(lp,9000) iaunit
+ call flush(lp)
+ call xchalt('(ztiowr)')
+ stop '(ztiowr)'
+ endif
+c
+ if (lreal4) then
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ w(i+(j-1)*ii) = h(i,j)
+ wminy(j) = min( wminy(j), w(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*ii) )
+ else
+ w(i+(j-1)*ii) = spval
+ endif
+#if defined(REAL4)
+! --- h(i,j) = w(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = w(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,ii
+ w(i+(j-1)*ii) = h(i,j)
+ if (w(i+(j-1)*ii).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*ii) )
+ endif
+#if defined(REAL4)
+! --- h(i,j) = w(i+(j-1)*ii) ! h is already real*4
+#else
+ h(i,j) = w(i+(j-1)*ii) ! h is not real*4, so update it
+#endif
+ enddo
+ enddo
+ endif
+ else
+ if (lmask) then
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,ii
+ if (mask(i,j).ne.0) then
+ w(i+(j-1)*ii) = h(i,j)
+ wminy(j) = min( wminy(j), w(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*ii) )
+ else
+ w(i+(j-1)*ii) = spval
+ endif
+ enddo
+ enddo
+ else
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j= 1,jj
+ wminy(j) = spval !simplifies OpenMP parallelization
+ wmaxy(j) = -spval !simplifies OpenMP parallelization
+ do i= 1,ii
+ w(i+(j-1)*ii) = h(i,j)
+ if (w(i+(j-1)*ii).ne.spval) then
+ wminy(j) = min( wminy(j), w(i+(j-1)*ii) )
+ wmaxy(j) = max( wmaxy(j), w(i+(j-1)*ii) )
+ endif
+ enddo
+ enddo
+ endif
+ endif
+ hmin = minval(wminy(1:jj))
+ hmax = maxval(wmaxy(1:jj))
+ iarec(iaunit) = iarec(iaunit) + 1
+ call ztiowrd(w,ii*jj, iaunit+uaoff,iarec(iaunit),ios)
+ if (ios.ne.0) then
+ write(lp,9100) iarec(iaunit),iaunit
+ call flush(lp)
+ cfile = ' '
+ inquire(unit=iaunit+uaoff,name=cfile)
+ write(lp,'(3a)') 'FILENAME="',trim(cfile),'"'
+ call flush(lp)
+ call xchalt('(ztiowr)')
+ stop '(ztiowr)'
+ endif !ios
+#if defined(TIMER)
+c
+ call xctmr1(18)
+#endif
+ return
+c
+ 9000 format(/ /10x,'error in ztiowr - array I/O unit ',
+ & i3,' is not marked as open.'/ /)
+ 9100 format(/ /10x,'error in ztiowr - can''t write record',
+ & i4,' on array I/O unit ',i3,'.'/ /)
+ end subroutine ztiowr
+
+ subroutine ztiowrd(a,n, iunit,irec,ios)
+ implicit none
+c
+ integer, intent(in) :: n,iunit,irec
+ integer, intent(out) :: ios
+ real*4, intent(in) :: a(n)
+c
+c**********
+c*
+c 1) direct access write a single record.
+c
+c 2) expressed as a subroutine because i/o with
+c implied do loops can be slow on some machines.
+c*
+c**********
+c
+#if defined(ENDIAN_IO)
+ call zaio_endian(a,n) ! overwrites a
+#endif
+ write(unit=iunit, rec=irec, iostat=ios) a
+ return
+ end subroutine ztiowrd
diff --git a/src_2.2.18_3_one/momtum.f b/src_2.2.18_3_one/momtum.f
new file mode 100755
index 0000000..1aa0f7e
--- /dev/null
+++ b/src_2.2.18_3_one/momtum.f
@@ -0,0 +1,3551 @@
+ subroutine momtum_hs(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ use mod_tides ! HYCOM tides
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- -----------------------------------------
+c --- hydrostatic equation (and surface stress)
+c --- -----------------------------------------
+c
+ logical, parameter :: lpipe_momtum=.false. !usually .false.
+ real, parameter :: dragw_rho=0.00536*1026.0 !ice-ocean drag from CICE
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & stress,stresx,stresy,dpmx,thkbop,oneta,
+ & vis2u,vis4u,vis2v,vis4v,vort,
+ & wgtia,wgtib,wgtja,wgtjb,
+ & dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib,
+ & tclmn,tclpn !see momtum4
+ common/momtumr4/ stress,stresx,stresy,dpmx,thkbop,oneta,
+ & vis2u,vis4u,vis2v,vis4v,vort,
+ & wgtia,wgtib,wgtja,wgtjb,
+ & dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib,
+ & tclmn,tclpn !see momtum4
+ save /momtumr4/
+c
+ real dpdn,dpup,q,simo,uimo,vimo,dpsur,psur,usur,vsur,
+ & sumdp,sumth
+ integer i,j,k,l,mbdy,hlstep
+c
+* real*8 wtime
+* external wtime
+* real*8 wtime1(10),wtime2(20,kdm),wtimes
+c
+ include 'stmt_fns.h'
+c
+ mbdy = 6
+c
+ call xctilr(pu( 1-nbdy,1-nbdy,2 ),1, kk, 6,6, halo_us)
+ call xctilr(pv( 1-nbdy,1-nbdy,2 ),1, kk, 6,6, halo_vs)
+ call xctilr(dpmixl(1-nbdy,1-nbdy, m),1, 1, 6,6, halo_ps)
+ call xctilr(dp( 1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_ps)
+ call xctilr(dpu( 1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_us)
+ call xctilr(dpv( 1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vs)
+ call xctilr(pbavg( 1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_ps)
+ call xctilr(dpoldm(1-nbdy,1-nbdy,1 ),1, kk, 6,6, halo_ps)
+ call xctilr(saln( 1-nbdy,1-nbdy,1,m),1, kk, 6,6, halo_ps)
+ call xctilr(temp( 1-nbdy,1-nbdy,1,m),1, kk, 6,6, halo_ps)
+ call xctilr(th3d( 1-nbdy,1-nbdy,1,m),1, kk, 6,6, halo_ps)
+c
+c --- tidal forcing
+c
+ if(tidflg.eq.2) then
+ hlstep=0
+ call tides_force(hlstep)
+ endif
+c
+c --- hydrostatic equation (and surface stress)
+c
+* wtime1( 1) = wtime()
+c
+c --- rhs: th3d.m, temp.m, saln.m, p, pbavg.m
+c --- lhs: thstar, p, oneta, montg
+c
+ margin = mbdy
+c
+!$OMP PARALLEL DO PRIVATE(j,l,k,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ sumdp = 0.0
+ sumth = 0.0
+ do k=1,kk
+ if (kapref.ne.0) then !thermobaric
+c
+c --- sigma-star is virtual potential density, as defined in
+c --- Sun et.al. (1999), 'Inclusion of thermobaricity in
+c --- isopycnic-coordinate ocean models', JPO 29 pp 2719-2729.
+c
+c --- use upper interface pressure in converting sigma to sigma-star.
+c --- to avoid density variations in layers intersected by bottom
+c
+ if (kapref.gt.0) then
+ thstar(i,j,k,1)=th3d(i,j,k,m)
+ & +kappaf(temp(i,j,k,m),
+ & saln(i,j,k,m),
+ & th3d(i,j,k,m)+thbase,
+ & p(i,j,k),
+ & kapref)
+ else
+ thstar(i,j,k,1)=th3d(i,j,k,m)
+ & +kappaf(temp(i,j,k,m),
+ & saln(i,j,k,m),
+ & th3d(i,j,k,m)+thbase,
+ & p(i,j,k),
+ & 2)
+ thstar(i,j,k,2)=th3d(i,j,k,m)
+ & +kappaf(temp(i,j,k,m),
+ & saln(i,j,k,m),
+ & th3d(i,j,k,m)+thbase,
+ & p(i,j,k),
+ & kapi(i,j))
+ endif !kapref
+ else !non-thermobaric
+ thstar(i,j,k,1)=th3d(i,j,k,m)
+ endif !thermobaric:else
+c
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,m)
+c
+ if (sshflg.ne.0) then
+ sumth = sumth + dp(i,j,k,m)*th3d(i,j,k,m)
+ sumdp = sumdp + dp(i,j,k,m)
+ endif !sshflg
+ enddo !k
+c
+ if (sshflg.ne.0) then
+ sumth = sumth / max( sumdp, onemm ) !vertical mean of th3d
+ sumdp = sumdp*qonem * g !depth(m) * g
+ steric(i,j) = sshgmn(i,j) +
+ & (sshgmn(i,j) + sumdp) *
+ & (thmean(i,j) - sumth) /
+ & (1000.0+thbase+sumth)
+ endif !sshflg
+c
+c --- store (1+eta) (= p_total/p_prime) in -oneta-
+ oneta(i,j)=1.+pbavg(i,j,m)/p(i,j,kk+1)
+c
+c --- m_prime in lowest layer:
+ montg(i,j,kk,1)=psikk(i,j,1)+
+ & ( p(i,j,kk+1)*(thkk(i,j,1)-thstar(i,j,kk,1))
+ & -pbavg(i,j,m)*(thstar(i,j,kk,1)+thbase) )*thref**2
+ if (kapref.eq.-1) then
+ montg(i,j,kk,2)=psikk(i,j,2)+
+ & ( p(i,j,kk+1)*(thkk(i,j,2)-thstar(i,j,kk,2))
+ & -pbavg(i,j,m)*(thstar(i,j,kk,2)+thbase) )*thref**2
+ endif !kapref.eq.-1
+c
+c --- m_prime in remaining layers:
+ do k=kk-1,1,-1
+ montg(i,j,k,1)=montg(i,j,k+1,1)+p(i,j,k+1)*oneta(i,j)
+ & *(thstar(i,j,k+1,1)-thstar(i,j,k,1))*thref**2
+ if (kapref.eq.-1) then
+ montg(i,j,k,2)=montg(i,j,k+1,2)+p(i,j,k+1)*oneta(i,j)
+ & *(thstar(i,j,k+1,2)-thstar(i,j,k,2))*thref**2
+ endif !kapref.eq.-1
+ enddo !k
+c
+c --- srfhgt (used diagnostically, in mxmyaij and for tidal SAL).
+ if (kapref.ne.-1) then
+ montg1(i,j) = montg(i,j,1,1)
+ else
+ montg1(i,j) = skap(i,j) *montg(i,j,1,1) +
+ & (1.0-skap(i,j))*montg(i,j,1,2)
+ endif !kapref
+ srfhgt(i,j) = montg1(i,j) + thref*pbavg(i,j,m)
+c
+cdiag if (sshflg.ne.0) then
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag write (lp,'(i9,2i5,3x,a,2f12.6,f12.2)')
+cdiag& nstep,itest+i0,jtest+j0,
+cdiag& 'sssh =',
+cdiag& steric(i,j),sshgmn(i,j),sumdp
+cdiag write (lp,'(i9,2i5,3x,a,3f12.6)')
+cdiag& nstep,itest+i0,jtest+j0,
+cdiag& 'thmn =',
+cdiag& sumth,thmean(i,j),1000.0+thbase+sumth
+cdiag write (lp,'(i9,2i5,3x,a,3f12.6)')
+cdiag& nstep,itest+i0,jtest+j0,
+cdiag& 'ssh =',
+cdiag& srfhgt(i,j),steric(i,j),srfhgt(i,j)-steric(i,j)
+cdiag endif !test
+cdiag endif !sshflg
+c
+c --- tidal corrections, note that these are not part of montg
+c --- but are included here to simplify the pressure gradient
+ if (tidflg.gt.0 .and. sshflg.eq.0) then !tides
+ do k=1,kk
+ montg(i,j,k,1)=montg(i,j,k,1)
+ & -g*etide(i,j)-tidsal*srfhgt(i,j)
+ if (kapref.eq.-1) then
+ montg(i,j,k,2)=montg(i,j,k,2)
+ & -g*etide(i,j)-tidsal*srfhgt(i,j)
+ endif !kapref.eq.-1
+ enddo !k
+ elseif (tidflg.gt.0 .and. sshflg.ne.0) then !tides
+ do k=1,kk
+ montg(i,j,k,1)=montg(i,j,k,1)
+ & -g*etide(i,j)
+ & -tidsal*(srfhgt(i,j)-steric(i,j))
+ if (kapref.eq.-1) then
+ montg(i,j,k,2)=montg(i,j,k,2)
+ & -g*etide(i,j)
+ & -tidsal*(srfhgt(i,j)-steric(i,j))
+ endif !kapref.eq.-1
+ enddo !k
+ endif !tides (sshflg)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+* wtime1( 2) = wtime()
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,m),
+ & dpv(1-nbdy,1-nbdy,1,m),
+ & p,depthu,depthv, max(0,margin-1))
+* wtime1( 3) = wtime()
+c
+c --- account for temporal smoothing of mid-time dpmixl. calculate the vertical
+c --- excursions of the coordinates immediately above and below the mixed
+c --- layer base, then vertically interpolate this motion to dpmixl(i,j,m)
+c
+ if(hybrid .and. mxlkta) then
+c
+c --- rhs: dpoldm, dpmixl.m
+c --- lhs: util1, util2
+c
+ margin = mbdy
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,dpup,dpdn,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ util1(i,j)=0.
+ util2(i,j)=0.
+ enddo !i
+ do k=1,kk
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ util1(i,j)=util2(i,j)
+ util2(i,j)=util2(i,j)+dpoldm(i,j,k)
+ if (util2(i,j).ge.dpmixl(i,j,m).and.
+ & util1(i,j).lt.dpmixl(i,j,m) ) then
+ dpup=p(i,j,k )-util1(i,j)
+ dpdn=p(i,j,k+1)-util2(i,j)
+ q=(util2(i,j)-dpmixl(i,j,m))/max(onemm,dpoldm(i,j,k))
+ dpmixl(i,j,m)=dpmixl(i,j,m)+(dpdn+q*(dpup-dpdn))
+ endif
+ enddo !i
+ enddo !k
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ endif
+c
+c --- --------------
+c --- surface stress
+c --- --------------
+c
+ if (windf) then
+ margin = 0
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,dpsur,psur,usur,vsur,uimo,vimo,simo)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (wndflg.eq.2) then ! tau on p grid
+ surtx(i,j)=( taux(i,j,l0)*w0+taux(i,j,l1)*w1
+ & +taux(i,j,l2)*w2+taux(i,j,l3)*w3)
+ surty(i,j)=( tauy(i,j,l0)*w0+tauy(i,j,l1)*w1
+ & +tauy(i,j,l2)*w2+tauy(i,j,l3)*w3)
+ else ! tau on u&v grids - NOT RECOMMEDED
+ surtx(i,j)=( (taux(i,j,l0)+taux(i+1,j,l0))*w0
+ & +(taux(i,j,l1)+taux(i+1,j,l1))*w1
+ & +(taux(i,j,l2)+taux(i+1,j,l2))*w2
+ & +(taux(i,j,l3)+taux(i+1,j,l3))*w3)*0.5
+ surty(i,j)=( (tauy(i,j,l0)+tauy(i,j+1,l0))*w0
+ & +(tauy(i,j,l1)+tauy(i,j+1,l1))*w1
+ & +(tauy(i,j,l2)+tauy(i,j+1,l2))*w2
+ & +(tauy(i,j,l3)+tauy(i,j+1,l3))*w3)*0.5
+ endif
+ if (iceflg.eq.2 .and. si_c(i,j).gt.0.0) then
+c --- average currents over top 10m
+ usur = 0.0
+ vsur = 0.0
+ psur = 0.0
+ do k= 1,kk
+ dpsur = min( dp(i,j,k,n), max( 0.0, tenm - psur ) )
+ usur = usur + dpsur*(u(i,j,k,n)+u(i+1,j,k,n))
+ vsur = vsur + dpsur*(v(i,j,k,n)+v(i,j+1,k,n))
+ psur = psur + dpsur
+ if (dpsur.eq.0.0) then
+ exit
+ endif
+ enddo !k
+ usur = 0.5*( usur/psur + ubavg(i, j,n) +
+ & ubavg(i+1,j,n) )
+ vsur = 0.5*( vsur/psur + vbavg(i,j, n) +
+ & vbavg(i,j+1,n) )
+c allow for ice-ocean stress
+ uimo = si_u(i,j) - usur
+ vimo = si_v(i,j) - vsur
+ simo = sqrt( uimo**2 + vimo**2 )
+ surtx(i,j)=(1.0-si_c(i,j))*surtx(i,j) +
+ & si_c(i,j) *dragw_rho*simo*uimo
+ surty(i,j)=(1.0-si_c(i,j))*surty(i,j) +
+ & si_c(i,j) *dragw_rho*simo*vimo
+ endif !ice-ocean stress
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ call xctilr(surtx,1,1, 6,6, halo_ps)
+ call xctilr(surty,1,1, 6,6, halo_ps)
+ endif !windf
+c
+ return
+ end
+c
+ subroutine momtum(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ use mod_tides ! HYCOM tides
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ------------------------------------------------------
+c --- momentum equations (2nd order version)
+c
+c --- Enstrophy conserving advection scheme (Sadourney, 1975)
+c
+c --- diffusion is Laplacian and/or biharmonic, both with
+c --- "constant" and deformation dependent coefficients.
+c
+c --- hydrostatic equation and surface stress via momtum_hs
+c --- ------------------------------------------------------
+c
+ logical, parameter :: lpipe_momtum=.false. !usually .false.
+c
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & stress,stresx,stresy,dpmx,thkbop,oneta,
+ & vis2u,vis4u,vis2v,vis4v,vort,
+ & wgtia,wgtib,wgtja,wgtjb,
+ & dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib,
+ & tclmn,tclpn !see momtum4
+ common/momtumr4/ stress,stresx,stresy,dpmx,thkbop,oneta,
+ & vis2u,vis4u,vis2v,vis4v,vort,
+ & wgtia,wgtib,wgtja,wgtjb,
+ & dl2u,dl2uja,dl2ujb,dl2v,dl2via,dl2vib,
+ & tclmn,tclpn !see momtum4
+ save /momtumr4/
+c
+ integer ifirst
+ save ifirst
+c
+ real dpia,dpib,dpja,dpjb,vis2a,vis4a,vis2b,vis4b,
+ & scuya,scuyb,scvxa,scvxb,vmag,dall,adrlim,
+ & dpxy,ptopl,pbotl,cutoff,qcutoff,h1,q,deform,aspy2,aspx2,
+ & dt1inv,phi,plo,pbop,pthkbl,ubot,vbot,pstres,
+ & dmontg,dthstr,dragu,dragv,qdpu,qdpv,dpthin
+ integer i,ia,ib,j,ja,jb,k,ka,l,mbdy
+c
+* real*8 wtime
+* external wtime
+* real*8 wtime1(10),wtime2(20,kdm),wtimes
+c
+ character text*12
+ integer, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & mask
+c
+ real hfharm,a,b
+ include 'stmt_fns.h'
+c
+c --- harmonic mean divided by 2
+ hfharm(a,b)=a*b/(a+b)
+c
+ data ifirst / 0 /
+c
+ mbdy = 6
+c
+ call xctilr(u( 1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,1),1,2*kk, 6,6, halo_vv)
+ call xctilr(ubavg(1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_uv)
+ call xctilr(vbavg(1-nbdy,1-nbdy,1 ),1, 3, 6,6, halo_vv)
+ call xctilr(uflx( 1-nbdy,1-nbdy,1 ),1, kk, 6,6, halo_uv)
+ call xctilr(vflx( 1-nbdy,1-nbdy,1 ),1, kk, 6,6, halo_vv)
+c
+ if (ifirst.eq.0) then
+ ifirst=1
+c --- setup zero fill.
+ margin = mbdy
+c
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+ vis2u(i,j)=0.0
+ vis4u(i,j)=0.0
+ vis2v(i,j)=0.0
+ vis4v(i,j)=0.0
+ dl2u( i,j)=0.0
+ dl2v( i,j)=0.0
+ enddo !i
+ enddo !j
+ endif
+c
+c --- ---------------------------------------
+c --- hydrostatic equation and surface stress
+c --- ---------------------------------------
+c
+ call momtum_hs(m,n)
+c
+c +++ ++++++++++++++++++
+c +++ momentum equations
+c +++ ++++++++++++++++++
+c
+* wtime1( 4) = wtime()
+c
+c --- rhs: p, u.n+, v.n+, ubavg.n+, vbavg.n+, depthv+, pvtrop+
+c --- rhs: dpmixl.m+, taux+, dpu, depthu+, dpv, tauy+
+c --- lhs: util1, util2, drag, ubrhs, stresx, vbrhs, stresy
+c
+ if (drglim.gt.0.0) then
+ adrlim = drglim
+ else
+ adrlim = 0.125
+ endif
+ dt1inv = 1./delt1
+c
+ margin = mbdy - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,
+!$OMP& phi,plo,pbop,ubot,vbot,vmag,dall,pstres)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- bottom drag (standard bulk formula)
+c --- bottom stress is applied over thickness dp00 for the kpp bottom
+c --- b.l. just as for the surface b.l. otherwise, bottom stress is
+c --- applied over thickness thkbot
+c
+ if (mxlkpp .and. bblkpp) then
+ thkbop(i,j)=dp00 !bottom stress applied over this thknss
+ else
+ thkbop(i,j)=thkbot*onem !bottom stress applied over this thknss
+ endif
+c
+c --- the bottom stress term is estimated using velocity averaged over the
+c --- bottom boundary layer. this thickness is dpbbl for the kpp boundary
+c --- layer; otherwise, it is thkbop
+ ubot=0.0
+ vbot=0.0
+ if (mxlkpp .and. bblkpp) then
+ pthkbl=max(dpbbl(i,j),thkbop(i,j)) !thknss of bot. b.l.
+ else
+ pthkbl=thkbop(i,j) !thknss of bot. b.l.
+ endif
+ pbop=p(i,j,kk+1)-pthkbl !top of bot. b.l.
+ phi =max(p(i,j,1),pbop)
+ do k=1,kk
+ plo =phi ! max(p(i,j,k),pbop)
+ phi =max(p(i,j,k+1),pbop)
+ ubot=ubot + (u(i,j,k,n)+u(i+1,j,k,n))*(phi-plo)
+ vbot=vbot + (v(i,j,k,n)+v(i,j+1,k,n))*(phi-plo)
+ enddo !k
+ ubot=ubot/min(pthkbl,p(i,j,kk+1))
+ & + (ubavg(i,j,n)+ubavg(i+1,j,n))
+ vbot=vbot/min(pthkbl,p(i,j,kk+1))
+ & + (vbavg(i,j,n)+vbavg(i,j+1,n))
+ vmag=0.5*sqrt(ubot**2+vbot**2)
+!!Alex add linear bottom drag cbar2
+! dall=cb*(vmag+cbar) !no tidal drag
+ dall=cb*(vmag+cbar) + cbar2
+
+ drag(i,j)=dall/min(thkbop(i,j)*qonem,depths(i,j))
+ if (mxlkpp .and. bblkpp) then
+ ustarb(i,j)=sqrt(dall*vmag)
+ endif
+c
+c --- tidal bottom drag
+c
+ util6(i,j)=thkdrg*onem !bottom stress applied over this thknss
+ util5(i,j)=dragrh(i,j)/min(util6(i,j)*qonem,depths(i,j))
+ enddo !i
+ enddo !l
+c
+c --- store r.h.s. of barotropic u/v eqn. in -ubrhs,vbrhs-
+c --- time-interpolate wind stress
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ ubrhs(i,j)=
+ & (vbavg(i ,j, m)*depthv(i ,j)
+ & +vbavg(i ,j+1,m)*depthv(i ,j+1)
+ & +vbavg(i-1,j, m)*depthv(i-1,j)
+ & +vbavg(i-1,j+1,m)*depthv(i-1,j+1))
+ & *(pvtrop(i,j)+pvtrop(i,j+1))*.125
+c
+ if (windf) then
+ if(hybrid .and. mxlkrt) then
+ pstres=0.5*(dpmixl(i,j,m)+dpmixl(i-1,j,m))
+!!Alex add the use of pstrsi if BB86 config
+ else if (pstrsi .gt. 0.) then
+ pstres=pstrsi*onem
+ else
+ pstres=dpu(i,j,1,m)
+ endif
+c --- units of surtx are N/m^2 (i.e. Pa)
+ stresx(i,j)=(surtx(i,j)+surtx(i-1,j))*0.5*g
+ & /(pstres*thref)
+ else ! no taux
+ stresx(i,j)=0.
+ endif !windf:else
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vbrhs(i,j)=
+ & -(ubavg(i, j ,m)*depthu(i,j )
+ & +ubavg(i+1,j ,m)*depthu(i+1,j )
+ & +ubavg(i, j-1,m)*depthu(i,j-1)
+ & +ubavg(i+1,j-1,m)*depthu(i+1,j-1))
+ & *(pvtrop(i,j)+pvtrop(i+1,j))*.125
+c
+ if (windf) then
+ if(hybrid .and. mxlkrt) then
+ pstres=0.5*(dpmixl(i,j,m)+dpmixl(i,j-1,m))
+!!Alex add the use of pstrsi if BB86 config
+ else if (pstrsi .gt. 0.) then
+ pstres=pstrsi*onem
+ else
+ pstres=dpv(i,j,1,m)
+ endif
+c --- units of surty are N/m^2 (i.e. Pa)
+ stresy(i,j)=(surty(i,j)+surty(i,j-1))*0.5*g
+ & /(pstres*thref)
+ else ! no tauy
+ stresy(i,j)=0.
+ endif !windf:else
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_momtum) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'uba.n n=',n
+ call pipe_compare(ubavg(1-nbdy,1-nbdy,n),iu,text)
+ write (text,'(a9,i3)') 'vba.n n=',n
+ call pipe_compare(vbavg(1-nbdy,1-nbdy,n),iv,text)
+ write (text,'(a9,i3)') 'drag k=',0
+ call pipe_compare(drag,ip,text)
+ endif
+c
+c --- the old momeq2.f starts here
+c
+ dpthin = 0.001*onemm
+ h1 = tenm !used in lateral weighting of hor.pres.grad.
+ cutoff = 0.5*onem
+ qcutoff = 1.0/cutoff
+c
+* wtime1( 5) = wtime()
+c
+c --- rhs: 0.0
+c --- lhs: util1, util2
+c
+* margin = mbdy - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+c --- spatial weighting function for pressure gradient calculation:
+ util1(i,j)=0.
+ util2(i,j)=0.
+ enddo !i
+ enddo !j
+c
+ do 9 k=1,kk
+c
+c --- store total (barotropic plus baroclinic) flow at old and mid time in
+c --- -utotn,vtotn- and -utotm,vtotm- respectively. store minimum thickness
+c --- values for use in pot.vort. calculation in -dpmx-.
+c
+* wtime2( 1,k) = wtime()
+c
+c --- rhs: dpmx, dp.m+
+c --- lhs: dpmx
+c
+* margin = mbdy - 2
+c
+ do i=1-margin,ii+margin
+ dpmx(i,1)=2.*cutoff
+ enddo !i
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+ dpmx(i,j+1)=2.*cutoff
+ enddo !i
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ dpmx(i,j+1)=max(dpmx(i,j+1),dp(i,j,k,m)+dp(i-1,j,k,m))
+ enddo !i
+ enddo !l
+ enddo !j
+c
+* wtime2( 2,k) = wtime()
+c
+c --- rhs: ubavg.m, ubavg.n, dp.m+, dpu
+c --- lhs: utotm, utotn, uflux, dpmx, pu
+c
+* margin = mbdy - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+c
+ i=ifu(j,l)-1
+ if (i.ge.1-margin) then
+ if (iuopn(i,j).ne.0) then
+ utotm(i,j)=u(i+1,j,k,m)+ubavg(i,j,m)
+ utotn(i,j)=u(i+1,j,k,n)+ubavg(i,j,n)
+ uflux(i,j)=utotm(i,j)*max(dp(i,j,k,m),cutoff)
+ endif
+ endif
+ i=ilu(j,l)+1
+ if (i.le.ii+margin) then
+ if (iuopn(i,j).ne.0) then
+ utotm(i,j)=u(i-1,j,k,m)+ubavg(i,j,m)
+ utotn(i,j)=u(i-1,j,k,n)+ubavg(i,j,n)
+ uflux(i,j)=utotm(i,j)*max(dp(i-1,j,k,m),cutoff)
+ endif
+ endif
+c
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ dpmx(i,j)=max(dpmx(i,j),dp(i,j,k,m)+dp(i-1,j,k,m))
+ utotm(i,j)=u(i,j,k,m)+ubavg(i,j,m)
+ utotn(i,j)=u(i,j,k,n)+ubavg(i,j,n)
+ uflux(i,j)=utotm(i,j)*max(dpu(i,j,k,m),cutoff)
+ pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,m)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+* wtime2( 3,k) = wtime()
+c
+c --- rhs: vbavg.m, vbavg.n, dp.m+, dpv
+c --- lhs: vtotm, vtotn, vflux, dpmx, pv
+c
+* margin = mbdy - 2
+c
+ do i=1-margin,ii+margin
+ do l=1,jsv(i)
+ j=jfv(i,l)-1
+ if (j.ge.1-margin) then
+ if (ivopn(i,j).ne.0) then
+ vtotm(i,j)=v(i,j+1,k,m)+vbavg(i,j,m)
+ vtotn(i,j)=v(i,j+1,k,n)+vbavg(i,j,n)
+ vflux(i,j)=vtotm(i,j)*max(dp(i,j,k,m),cutoff)
+ endif
+ endif
+ j=jlv(i,l)+1
+ if (j.le.jj+margin) then
+ if (ivopn(i,j).ne.0) then
+ vtotm(i,j)=v(i,j-1,k,m)+vbavg(i,j,m)
+ vtotn(i,j)=v(i,j-1,k,n)+vbavg(i,j,n)
+ vflux(i,j)=vtotm(i,j)*max(dp(i,j-1,k,m),cutoff)
+ endif
+ endif
+ enddo !l
+ enddo !i
+c
+* wtime2( 4,k) = wtime()
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ dpmx(i ,j)=max(dpmx(i ,j),dp(i,j,k,m)+dp(i,j-1,k,m))
+ dpmx(i+1,j)=max(dpmx(i+1,j),dp(i,j,k,m)+dp(i,j-1,k,m))
+ vtotm(i,j)=v(i,j,k,m)+vbavg(i,j,m)
+ vtotn(i,j)=v(i,j,k,n)+vbavg(i,j,n)
+ vflux(i,j)=vtotm(i,j)*max(dpv(i,j,k,m),cutoff)
+ pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,m)
+ enddo !i
+ enddo !l
+ enddo !j
+c
+c --- define auxiliary velocity fields (via,vib,uja,ujb) to implement
+c --- sidewall friction along near-vertical bottom slopes. wgtja,wgtjb,wgtia,
+c --- wgtib indicate the extent to which a sidewall is present.
+c
+* wtime2( 5,k) = wtime()
+c
+c --- rhs: pu, depthu+, utotn+, wgtja
+c --- lhs: wgtja, wgtjb, uja, ujb, dl2u
+c --- rhs: pv, depthv+, vtotn+, wgtia
+c --- lhs: wgtia, wgtib, via, vib, dl2v
+c --- rhs: vtotm, vort+, corio+, dp.m+, dpmx+, vtotn
+c --- lhs: vort, potvor, defor2
+c
+* margin = mbdy - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,ja,jb,l,i,ia,ib,aspy2,aspx2)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c --- assume margin to properly commute pressure torque from layer to layer
+c> Jul. 2000 - loop reordering and logic changes for OpenMP
+c> Aug. 2000 - loop 117 executed only when hybrid vertical coordinate is used
+c> Oct. 2001 - replaced biharm with veldf[24] and visco[24]
+c> Sep. 2004 - kapref selects one of three thermobaric reference states
+c> Jun. 2006 - split out momtum_hs, for initial ssh calculation
+c> Nov. 2006 - inserted volume-force for tide
+c> Apr. 2007 - added drglim, implicit or CFL-limited explicit bottom drag
+c> Apr. 2007 - added dragrh, linear tidal drag based on bottom roughness
+c> Apr. 2007 - btrlfr: moved [uvp]bavg assignment to barotp
+c> Jun. 2007 - added momtum4
+c> Mar 2009 - more accurate kappaf, with potential density
diff --git a/src_2.2.18_3_one/mxkprf.f b/src_2.2.18_3_one/mxkprf.f
new file mode 100755
index 0000000..57da22a
--- /dev/null
+++ b/src_2.2.18_3_one/mxkprf.f
@@ -0,0 +1,3632 @@
+ subroutine mxkprf(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c ---------------------------------------------------------
+c --- k-profile vertical mixing models
+c --- a) large, mc williams, doney kpp vertical diffusion
+c --- b) mellor-yamada 2.5 vertical diffusion
+c --- c) giss vertical diffusion
+c ---------------------------------------------------------
+c
+ logical, parameter :: lpipe_mxkprf =.false.
+ logical, parameter :: ldebug_dpmixl=.false.
+c
+ real delp,dpmx,hblmax,sigmlj,thsur,thtop,alfadt,betads,zintf,
+ & thjmp(kdm),thloc(kdm)
+ integer i,j,k,l
+ character text*12
+c
+ include 'stmt_fns.h'
+c
+ if (mxlmy) then
+ call xctilr(u( 1-nbdy,1-nbdy,1,m),1,kk, 1,1, halo_uv)
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,m),1,kk, 1,1, halo_vv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(p( 1-nbdy,1-nbdy,2 ),1,kk, 1,1, halo_ps)
+ call xctilr(ubavg( 1-nbdy,1-nbdy, m),1, 1, 1,1, halo_uv)
+ call xctilr(vbavg( 1-nbdy,1-nbdy, m),1, 1, 1,1, halo_vv)
+ else
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(p( 1-nbdy,1-nbdy,2 ),1,kk, 1,1, halo_ps)
+ endif
+c
+ margin = 0 ! no horizontal derivatives
+c
+c --- except for KPP, surface boundary layer is the mixed layer
+ if (mxlgiss .or. mxlmy) then
+ hblmax = bldmax*onem
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpbl(i,j) = 0.5*(dpmixl(i,j,n)+
+ & dpmixl(i,j,m) ) !reduce time splitting
+ dpbl(i,j) = min( dpbl(i,j), hblmax ) !may not be needed
+ enddo !i
+ enddo !l
+ enddo !j
+ endif !mxlgiss,mxlmy
+c
+c --- diffisuvity/viscosity calculation
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkprfaj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- optional spatial smoothing of viscosity and diffusivities on interior
+c --- interfaces.
+c
+ if (difsmo.gt.0) then
+ util6(1:ii,1:jj) = klist(1:ii,1:jj)
+ call xctilr(util6, 1, 1, 2,2, halo_ps)
+c --- update halo on all layers for simplicity
+ call xctilr(dift(1-nbdy,1-nbdy,2),1,kk-1, 2,2, halo_ps)
+ call xctilr(difs(1-nbdy,1-nbdy,2),1,kk-1, 2,2, halo_ps)
+ call xctilr(vcty(1-nbdy,1-nbdy,2),1,kk-1, 2,2, halo_ps)
+ margin = 2
+ do k=2,min(difsmo+1,kk)
+ call psmooth_dif(dift(1-nbdy,1-nbdy,k),util6,k, 0)
+ call psmooth_dif(difs(1-nbdy,1-nbdy,k),util6,k, 0)
+ call psmooth_dif(vcty(1-nbdy,1-nbdy,k),util6,k, 1)
+ enddo
+ margin = 0
+ call xctilr(vcty(1-nbdy,1-nbdy,kk+1),1, 1, 1,1, halo_ps)
+ else
+ call xctilr(vcty(1-nbdy,1-nbdy, 2),1,kk, 1,1, halo_ps)
+ endif
+c
+ if (lpipe .and. lpipe_mxkprf) then
+c --- compare two model runs.
+ util6(1:ii,1:jj) = klist(1:ii,1:jj)
+ write (text,'(a12)') 'klist '
+ call pipe_compare_sym1(util6,ip,text)
+ if (mxlmy) then
+ do k= 0,kk+1
+ write (text,'(a9,i3)') 'q2 k=',k
+ call pipe_compare_sym1(q2( 1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'q2l k=',k
+ call pipe_compare_sym1(q2l(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'difqmy k=',k
+ call pipe_compare_sym1(difqmy(1-nbdy,1-nbdy,k),ip,text)
+ write (text,'(a9,i3)') 'diftmy k=',k
+ call pipe_compare_sym1(diftmy(1-nbdy,1-nbdy,k),ip,text)
+ write (text,'(a9,i3)') 'vctymy k=',k
+ call pipe_compare_sym1(vctymy(1-nbdy,1-nbdy,k),ip,text)
+ enddo
+ endif
+ do k= 1,kk+1
+ write (text,'(a9,i3)') 'vcty k=',k
+ call pipe_compare_sym1(vcty(1-nbdy,1-nbdy,k),ip,text)
+ write (text,'(a9,i3)') 'dift k=',k
+ call pipe_compare_sym1(dift(1-nbdy,1-nbdy,k),ip,text)
+ write (text,'(a9,i3)') 'difs k=',k
+ call pipe_compare_sym1(difs(1-nbdy,1-nbdy,k),ip,text)
+ enddo
+ endif
+c
+c --- final mixing of variables at p points
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkprfbj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- final velocity mixing at u,v points
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkprfcj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- mixed layer diagnostics
+c
+ if (diagno .or. mxlgiss .or. mxlmy) then
+c
+c --- diagnose new mixed layer depth based on density jump criterion
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,
+!$OMP& sigmlj,thsur,thtop,alfadt,betads,zintf,
+!$OMP& thjmp,thloc)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+c
+c --- depth of mixed layer base set to interpolated depth where
+c --- the density jump is equivalent to a tmljmp temperature jump.
+c --- this may not vectorize, but is used infrequently.
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (locsig) then
+ sigmlj = -tmljmp*dsiglocdt(temp(i,j,1,n),
+ & saln(i,j,1,n),p(i,j,1))
+ else
+ sigmlj = -tmljmp*dsigdt(temp(i,j,1,n),saln(i,j,1,n))
+ endif
+ sigmlj = max(sigmlj,tmljmp*0.03) !cold-water fix
+*
+ if (ldebug_dpmixl .and. i.eq.itest.and.j.eq.jtest) then
+ write (lp,'(i9,2i5,i3,a,2f7.4)')
+ & nstep,i+i0,j+j0,k,
+ & ' sigmlj =',
+ & -tmljmp*dsigdt(temp(i,j,1,n),saln(i,j,1,n)),
+ & sigmlj
+ endif
+*
+ thloc(1)=th3d(i,j,1,n)
+ do k=2,klist(i,j)
+ if (locsig) then
+ alfadt=0.5*
+ & (dsiglocdt(temp(i,j,k-1,n),
+ & saln(i,j,k-1,n),p(i,j,k))+
+ & dsiglocdt(temp(i,j,k, n),
+ & saln(i,j,k, n),p(i,j,k)) )*
+ & (temp(i,j,k-1,n)-temp(i,j,k,n))
+ betads=0.5*
+ & (dsiglocds(temp(i,j,k-1,n),
+ & saln(i,j,k-1,n),p(i,j,k))+
+ & dsiglocds(temp(i,j,k, n),
+ & saln(i,j,k, n),p(i,j,k)) )*
+ & (saln(i,j,k-1,n)-saln(i,j,k,n))
+ thloc(k)=thloc(k-1)-alfadt-betads
+ else
+ thloc(k)=th3d(i,j,k,n)
+ endif
+ enddo !k
+ dpmixl(i,j,n) = -zgrid(i,j,klist(i,j)+1)*onem !bottom
+ thjmp(1) = 0.0
+ thsur = thloc(1)
+ do k=2,klist(i,j)
+ thsur = min(thloc(k),thsur) !ignore surface inversion
+ thjmp(k) = max(thloc(k)-thsur,
+ & thjmp(k-1)) !stable profile simplifies the code
+*
+ if (ldebug_dpmixl .and. i.eq.itest.and.j.eq.jtest) then
+ write (lp,'(i9,2i5,i3,a,2f7.3,f7.4,f9.2)')
+ & nstep,i+i0,j+j0,k,
+ & ' th,thsur,jmp,zc =',
+ & thloc(k),thsur,thjmp(k),-zgrid(i,j,k)
+ endif
+c
+ if (thjmp(k).ge.sigmlj) then
+c
+c --- find the density on the interface between layers
+c --- k-1 and k, using the same cubic polynominal as PQM
+c
+ if (k.eq.2) then
+c --- linear between cell centers
+ thtop = thjmp(1) + (thjmp(2)-thjmp(1))*
+ & dp(i,j,1,n)/
+ & max( dp(i,j,1,n)+
+ & dp(i,j,2,n) ,
+ & onemm )
+ elseif (k.eq.klist(i,j)) then
+c --- linear between cell centers
+ thtop = thjmp(k) + (thjmp(k-1)-thjmp(k))*
+ & dp(i,j,k,n)/
+ & max( dp(i,j,k, n)+
+ & dp(i,j,k-1,n) ,
+ & onemm )
+ else
+ thsur = min(thloc(k+1),thsur)
+ thjmp(k+1) = max(thloc(k+1)-thsur,
+ & thjmp(k))
+ zintf = zgrid(i,j,k-1) - 0.5*dp(i,j,k-1,n)*qonem
+ thtop = thjmp(k-2)*
+ & ((zintf -zgrid(i,j,k-1))*
+ & (zintf -zgrid(i,j,k ))*
+ & (zintf -zgrid(i,j,k+1)) )/
+ & ((zgrid(i,j,k-2)-zgrid(i,j,k-1))*
+ & (zgrid(i,j,k-2)-zgrid(i,j,k ))*
+ & (zgrid(i,j,k-2)-zgrid(i,j,k+1)) ) +
+ & thjmp(k-1)*
+ & ((zintf -zgrid(i,j,k-2))*
+ & (zintf -zgrid(i,j,k ))*
+ & (zintf -zgrid(i,j,k+1)) )/
+ & ((zgrid(i,j,k-1)-zgrid(i,j,k-2))*
+ & (zgrid(i,j,k-1)-zgrid(i,j,k ))*
+ & (zgrid(i,j,k-1)-zgrid(i,j,k+1)) ) +
+ & thjmp(k )*
+ & ((zintf -zgrid(i,j,k-2))*
+ & (zintf -zgrid(i,j,k-1))*
+ & (zintf -zgrid(i,j,k+1)) )/
+ & ((zgrid(i,j,k )-zgrid(i,j,k-2))*
+ & (zgrid(i,j,k )-zgrid(i,j,k-1))*
+ & (zgrid(i,j,k )-zgrid(i,j,k+1)) ) +
+ & thjmp(k+1)*
+ & ((zintf -zgrid(i,j,k-2))*
+ & (zintf -zgrid(i,j,k-1))*
+ & (zintf -zgrid(i,j,k )) )/
+ & ((zgrid(i,j,k+1)-zgrid(i,j,k-2))*
+ & (zgrid(i,j,k+1)-zgrid(i,j,k-1))*
+ & (zgrid(i,j,k+1)-zgrid(i,j,k )) )
+ thtop = max( thjmp(k-1), min( thjmp(k), thtop ) )
+*
+ if (ldebug_dpmixl .and.
+ & i.eq.itest.and.j.eq.jtest) then
+ write (lp,'(i9,2i5,i3,a,2f7.3,f7.4,f9.2)')
+ & nstep,i+i0,j+j0,k,
+ & ' thi,thsur,jmp,zi =',
+ & thtop,thsur,thjmp(k),-zintf
+ endif
+ endif !k.eq.2:k.eq.klist:else
+c
+ if (thtop.ge.sigmlj) then
+c
+c --- in bottom half of layer k-1
+c
+ dpmixl(i,j,n) =
+ & -zgrid(i,j,k-1)*onem +
+ & 0.5*dp(i,j,k-1,n)*
+ & (sigmlj+epsil-thjmp(k-1))/
+ & (thtop +epsil-thjmp(k-1))
+ else
+c
+c --- in top half of layer k
+c
+ dpmixl(i,j,n) =
+ & -zgrid(i,j,k)*onem -
+ & 0.5*dp(i,j,k,n)*
+ & (1.0-(sigmlj +epsil-thtop)/
+ & (thjmp(k)+epsil-thtop) )
+ endif !part of layer
+*
+ if (ldebug_dpmixl .and.
+ & i.eq.itest.and.j.eq.jtest) then
+ write (lp,'(i9,2i5,i3,a,f7.3,f7.4,f9.2)')
+ & nstep,i+i0,j+j0,k,
+ & ' thsur,top,dpmixl =',
+ & thsur,thtop,dpmixl(i,j,n)*qonem
+ endif
+*
+ exit !calculated dpmixl
+ endif !found dpmixl layer
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+c
+!$OMP END PARALLEL DO
+c
+c --- smooth the mixed layer (might end up below the bottom).
+ call psmooth(dpmixl(1-nbdy,1-nbdy,n), 0)
+*
+ if (ldebug_dpmixl) then
+ call xcsync(flush_lp)
+ endif
+*
+ endif !diagno .or. mxlgiss .or. mxlmy
+c
+ if (diagno) then
+c
+c --- calculate bulk mixed layer t, s, theta
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpmixl(i,j,n)=min(dpmixl(i,j,n),p(i,j,kk+1))
+ dpmixl(i,j,m)= dpmixl(i,j,n)
+ delp=min(p(i,j,2),dpmixl(i,j,n))
+ tmix(i,j)=delp*temp(i,j,1,n)
+ smix(i,j)=delp*saln(i,j,1,n)
+ do k=2,kk
+ delp=min(p(i,j,k+1),dpmixl(i,j,n))
+ & -min(p(i,j,k ),dpmixl(i,j,n))
+ tmix(i,j)=tmix(i,j)+delp*temp(i,j,k,n)
+ smix(i,j)=smix(i,j)+delp*saln(i,j,k,n)
+ enddo
+ tmix(i,j)=tmix(i,j)/dpmixl(i,j,n)
+ smix(i,j)=smix(i,j)/dpmixl(i,j,n)
+ thmix(i,j)=sig(tmix(i,j),smix(i,j))-thbase
+*
+ if (ldebug_dpmixl .and.
+ & i.eq.itest.and.j.eq.jtest) then
+ write (lp,'(i9,2i5,i3,a,f9.2)')
+ & nstep,i+i0,j+j0,k,
+ & ' dpmixl =',
+ & dpmixl(i,j,n)*qonem
+ endif
+*
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ call xctilr(p( 1-nbdy,1-nbdy,2),1,kk, 1,1, halo_ps)
+ call xctilr(dpmixl(1-nbdy,1-nbdy,n),1, 1, 1,1, halo_ps)
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp,dpmx)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+c --- calculate bulk mixed layer u
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ dpmx=dpmixl(i,j,n)+dpmixl(i-1,j,n)
+ delp=min(p(i,j,2)+p(i-1,j,2),dpmx)
+ umix(i,j)=delp*u(i,j,1,n)
+ do k=2,kk
+ delp= min(p(i,j,k+1)+p(i-1,j,k+1),dpmx)
+ & -min(p(i,j,k )+p(i-1,j,k ),dpmx)
+ umix(i,j)=umix(i,j)+delp*u(i,j,k,n)
+ enddo !k
+ umix(i,j)=umix(i,j)/dpmx
+ enddo !i
+ enddo !l
+c
+c --- calculate bulk mixed layer v
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ dpmx=dpmixl(i,j,n)+dpmixl(i,j-1,n)
+ delp=min(p(i,j,2)+p(i,j-1,2),dpmx)
+ vmix(i,j)=delp*v(i,j,1,n)
+ do k=2,kk
+ delp= min(p(i,j,k+1)+p(i,j-1,k+1),dpmx)
+ & -min(p(i,j,k )+p(i,j-1,k ),dpmx)
+ vmix(i,j)=vmix(i,j)+delp*v(i,j,k,n)
+ enddo !k
+ vmix(i,j)=vmix(i,j)/dpmx
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ endif ! diagno
+c
+ return
+ end
+ subroutine mxkprfaj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- calculate viscosity and diffusivity
+c
+ integer i,l
+c
+ if (mxlkpp) then
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ call mxkppaij(m,n, i,j)
+ enddo
+ enddo
+ else if (mxlmy) then
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ call mxmyaij(m,n, i,j)
+ enddo
+ enddo
+ else if (mxlgiss) then
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ call mxgissaij(m,n, i,j)
+ enddo
+ enddo
+ endif
+c
+ return
+ end
+ subroutine mxkprfbj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- final mixing at p points
+c
+ integer i,l
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ call mxkprfbij(m,n, i,j)
+ enddo
+ enddo
+c
+ return
+ end
+ subroutine mxkprfcj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- final velocity mixing at u,v points
+c
+ integer i,l
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ call mxkprfciju(m,n, i,j)
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ call mxkprfcijv(m,n, i,j)
+ enddo
+ enddo
+c
+ return
+ end
+ subroutine mxkppaij(m,n, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, i,j
+c
+c -------------------------------------------------------------
+c --- kpp vertical diffusion, single j-row (part A)
+c --- vertical coordinate is z negative below the ocean surface
+c
+c --- Large, W.C., J.C. McWilliams, and S.C. Doney, 1994: Oceanic
+c --- vertical mixing: a review and a model with a nonlocal
+c --- boundary layer paramterization. Rev. Geophys., 32, 363-403.
+c
+c --- quadratic interpolation and variable Cv from a presentation
+c --- at the March 2003 CCSM Ocean Model Working Group Meeting
+c --- on KPP Vertical Mixing by Gokhan Danabasoglu and Bill Large
+c --- http://www.ccsm.ucar.edu/working_groups/Ocean/agendas/030320.html
+c --- quadratic interpolation implemented here by 3-pt collocation,
+c --- which is slightly different to the Danabasoglu/Large approach.
+c -------------------------------------------------------------
+c
+ real, parameter :: difmax = 9999.0e-4 !maximum diffusion/viscosity
+ real, parameter :: dp0bbl = 20.0 !truncation dist. for bot. b.l.
+ real, parameter :: ricrb = 0.45 !critical bulk Ri for bot. b.l.
+ real, parameter :: cv_max = 2.1 !maximum cv
+ real, parameter :: cv_min = 1.7 !minimum cv
+ real, parameter :: cv_bfq = 200.0 !cv scale factor
+c
+c local variables for kpp mixing
+ real delta ! fraction hbl lies beteen zgrid neighbors
+ real zrefmn ! nearsurface reference z, minimum
+ real zref ! nearsurface reference z
+ real wref,qwref ! nearsurface reference width,inverse
+ real uref ! nearsurface reference u
+ real vref ! nearsurface reference v
+ real bref ! nearsurface reference buoyancy
+ real swfrac(kdm+1) ! fractional surface shortwave radiation flux
+ real shsq(kdm+1) ! velocity shear squared
+ real alfadt(kdm+1) ! t contribution to density jump
+ real betads(kdm+1) ! s contribution to density jump
+ real swfrml ! fractional surface sw rad flux at ml base
+ real ritop(kdm) ! numerator of bulk richardson number
+ real dbloc(kdm+1) ! buoyancy jump across interface
+ real dvsq(kdm) ! squared current shear for bulk richardson no.
+ real zgridb(kdm+1) ! zgrid for bottom boundary layer
+ real hwide(kdm) ! layer thicknesses in m (minimum 1mm)
+ real dpmm(kdm) ! max(onemm,dp(i,j,:,n))
+ real qdpmm(kdm) ! 1.0/max(onemm,dp(i,j,:,n))
+ real pij(kdm+1) ! local copy of p(i,j,:)
+ real case ! 1 in case A; =0 in case B
+ real hbl ! boundary layer depth
+ real hbbl ! bottom boundary layer depth
+ real rib(3) ! bulk richardson number
+ real rrho ! double diffusion parameter
+ real diffdd ! double diffusion diffusivity scale
+ real prandtl ! prandtl number
+ real rigr ! local richardson number
+ real fri ! function of Rig for KPP shear instability
+ real stable ! = 1 in stable forcing; =0 in unstable
+ real dkm1(3) ! boundary layer diffusions at nbl-1 level
+ real gat1(3) ! shape functions at dnorm=1
+ real dat1(3) ! derivative of shape functions at dnorm=1
+ real blmc(kdm+1,3) ! boundary layer mixing coefficients
+ real bblmc(kdm+1,3) ! boundary layer mixing coefficients
+ real wm ! momentum velocity scale
+ real ws ! scalar velocity scale
+ real dnorm ! normalized depth
+ real tmn ! time averaged SST
+ real smn ! time averaged SSS
+ real dsgdt ! dsigdt(tmn,smn)
+ real buoyfs ! salinity surface buoyancy (into atmos.)
+ real buoyfl ! total surface buoyancy (into atmos.)
+ real buoysw ! shortwave surface buoyancy (into atmos.)
+ real bfsfc ! surface buoyancy forcing (into atmos.)
+ real bfbot ! bottom buoyancy forcing
+ real hekmanb ! bottom ekman layer thickness
+ real cormn4 ! = 4 x min. coriolis magnitude (at 4N, 4S)
+ real dflsiw ! lat.dep. internal wave diffusivity
+ real dflmiw ! lat.dep. internal wave viscosity
+ real bfq ! buoyancy frequency
+ real cvk ! ratio of buoyancy frequencies
+ real ahbl,bhbl,chbl,dhbl ! coefficients for quadratic hbl calculation
+c
+ logical lhbl ! safe to use quadratic hbl calculation
+c
+ integer nbl ! layer containing boundary layer base
+ integer nbbl ! layer containing bottom boundary layer base
+ integer kup2,kdn2,kup,kdn! bulk richardson number indices
+c
+c --- local 1-d arrays for matrix solution
+ real u1do(kdm+1),u1dn(kdm+1),v1do(kdm+1),v1dn(kdm+1),t1do(kdm+1),
+ & t1dn(kdm+1),s1do(kdm+1),s1dn(kdm+1),
+ & diffm(kdm+1),difft(kdm+1),diffs(kdm+1),
+ & ghat(kdm+1),zm(kdm+1),hm(kdm),dzb(kdm)
+c
+c --- local 1-d arrays for iteration loops
+ real uold(kdm+1),vold (kdm+1),told (kdm+1),
+ & sold(kdm+1),thold(kdm+1)
+c
+c --- tridiagonal matrix solution arrays
+ real tri(kdm,0:1) ! dt/dz/dz factors in trid. matrix
+ real tcu(kdm), ! upper coeff for (k-1) on k line of trid.matrix
+ & tcc(kdm), ! central ... (k ) ..
+ & tcl(kdm), ! lower ..... (k-1) ..
+ & rhs(kdm) ! right-hand-side terms
+c
+ real dtemp,dsaln,wq,wt,ratio,q,ghatflux,
+ & dvdzup,dvdzdn,viscp,difsp,diftp,f1,sigg,aa1,aa2,aa3,gm,gs,gt,
+ & dkmp2,dstar,hblmin,hblmax,sflux1,vtsq,
+ & vctyh,difsh,difth,zrefo,qspcifh,hbblmin,hbblmax,
+ & beta_b,beta_r,frac_b,frac_r,swfbqp,
+ & x0,x1,x2,y0,y1,y2
+c
+ integer k,k1,ka,kb,nlayer,ksave,iter,jrlv
+c
+ integer iglobal,jglobal
+c
+ include 'stmt_fns.h'
+c
+ cormn4 = 4.0e-5 !4 x min. coriolis magnitude (at 4N, 4S)
+c
+ iglobal=i0+i !for debugging
+ jglobal=j0+j !for debugging
+ if (iglobal+jglobal.eq.-99) then
+ write(lp,*) iglobal,jglobal !prevent optimization
+ endif
+c
+ if (latdiw) then
+c --- spacially varying internal wave diffusion/viscosity
+ dflsiw = diwlat(i,j)
+ dflmiw = diwlat(i,j)*(difmiw/difsiw)
+ else
+c --- constant internal wave diffusion/viscosity
+ dflsiw = difsiw
+ dflmiw = difmiw
+ endif
+c
+c --- locate lowest substantial mass-containing layer.
+ pij(1)=p(i,j,1)
+ do k=1,kk
+ dpmm( k) =max(onemm,dp(i,j,k,n))
+ qdpmm(k) =1.0/dpmm(k)
+ pij( k+1)=pij(k)+dp(i,j,k,n)
+ p(i,j,k+1)=pij(k+1)
+ enddo
+ do k=kk,1,-1
+ if (dpmm(k).gt.tencm) then
+ exit
+ endif
+ enddo
+ klist(i,j)=max(k,2) !always consider at least 2 layers
+c
+c --- forcing of t,s by surface fluxes. flux positive into ocean.
+c --- shortwave flux penetration depends on kpar or jerlov water type.
+c
+ if (jerlv0.eq.0) then
+ beta_r = qonem*2.0
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ beta_b = max( betabl(1), beta_b) !time interp. beta_b can be -ve
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ frac_r = 1.0 - frac_b
+ else
+ jrlv = jerlov(i,j)
+ beta_r = betard(jrlv)
+ beta_b = betabl(jrlv)
+ frac_r = redfac(jrlv)
+ frac_b = 1.0 - frac_r
+ endif
+ qspcifh=1.0/spcifh
+c
+c --- evenly re-distribute the flux below the bottom
+ k = klist(i,j)
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfbqp=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfbqp=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfbqp=0.0
+ endif
+ swfbqp = swfbqp/pij(k+1)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,'(a,4f10.4)')
+cdiag& 'frac[rb],beta[rb] =',
+cdiag& frac_r,frac_b,onem*beta_r,onem*beta_b
+cdiag call flush(lp)
+cdiag endif
+c
+ do k=1,kk
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfrac(k+1)=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfrac(k+1)=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfrac(k+1)=0.0
+ endif
+ swfrac(k+1)=swfrac(k+1)-swfbqp*pij(k+1) !spread out bottom frac
+ if (k.eq.1) then
+ sflux1=surflx(i,j)-sswflx(i,j)
+ dtemp=(sflux1+(1.-swfrac(k+1))*sswflx(i,j))*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=salflx(i,j)*
+ & delt1*g* qdpmm(k)
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,101) nstep,i+i0,j+j0,k,
+cdiag& 1.0,swfrac(k+1),dtemp,dsaln
+cdiag call flush(lp)
+cdiag endif
+ elseif (k.le.klist(i,j)) then
+ dtemp=(swfrac(k)-swfrac(k+1))*sswflx(i,j)*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=0.0
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,101) nstep,i+i0,j+j0,k,
+cdiag& swfrac(k),swfrac(k+1),dtemp
+cdiag call flush(lp)
+cdiag endif
+ else !k.gt.klist(i,j)
+ dtemp=0.0
+ dsaln=0.0
+ endif
+ else !.not.thermo ...
+ dtemp=0.0
+ dsaln=0.0
+ endif !thermo.or.sstflg.gt.0.or.srelax:else
+c
+c --- modify t and s; set old value arrays at p points for initial iteration
+ if (k.le.klist(i,j)) then
+ temp(i,j,k,n)=temp(i,j,k,n)+dtemp
+ saln(i,j,k,n)=saln(i,j,k,n)+dsaln
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ told (k)=temp(i,j,k,n)
+ sold (k)=saln(i,j,k,n)
+ if (locsig) then
+ if (k.eq.1) then
+ thold(k)=th3d(i,j,k,n)
+ else
+ ka=k-1
+ alfadt(k)=0.5*
+ & (dsiglocdt(told(ka),sold(ka),p(i,j,k))+
+ & dsiglocdt(told(k ),sold(k ),p(i,j,k)))*
+ & (told(ka)-told(k))
+ betads(k)=0.5*
+ & (dsiglocds(told(ka),sold(ka),p(i,j,k))+
+ & dsiglocds(told(k ),sold(k ),p(i,j,k)))*
+ & (sold(ka)-sold(k))
+ thold(k)=thold(ka)-alfadt(k)-betads(k)
+ endif
+ else
+ thold(k)=th3d(i,j,k,n)
+ endif
+ uold (k)=.5*(u(i,j,k,n)+u(i+1,j ,k,n))
+ vold (k)=.5*(v(i,j,k,n)+v(i ,j+1,k,n))
+ endif
+ enddo
+c
+ k=klist(i,j)
+ ka=k+1
+ kb=min(ka,kk)
+ told (ka)=temp(i,j,kb,n)
+ sold (ka)=saln(i,j,kb,n)
+ if (locsig) then
+ alfadt(ka)=0.5*
+ & (dsiglocdt(told(k ),sold(k ),p(i,j,ka))+
+ & dsiglocdt(told(ka),sold(ka),p(i,j,ka)))*
+ & (told(k)-told(ka))
+ betads(ka)=0.5*
+ & (dsiglocds(told(k ),sold(k ),p(i,j,ka))+
+ & dsiglocds(told(ka),sold(ka),p(i,j,ka)))*
+ & (sold(k)-sold(ka))
+ thold(ka)=thold(k)-alfadt(ka)-betads(ka)
+ else
+ thold(ka)=th3d(i,j,kb,n)
+ endif
+ uold (ka)=.5*(u(i,j,k,n)+u(i+1,j ,k,n))
+ vold (ka)=.5*(v(i,j,k,n)+v(i ,j+1,k,n))
+c
+c --- calculate z at vertical grid levels - this array is the z values in m
+c --- at the mid-depth of each micom layer except for index klist+1, where it
+c --- is the z value of the bottom
+c
+c --- calculate layer thicknesses in m
+ do k=1,kk
+ if (k.eq.1) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=-.5*hwide(k)
+ else if (k.lt.klist(i,j)) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=zgrid(i,j,k-1)-.5*(hwide(k-1)+hwide(k))
+ else if (k.eq.klist(i,j)) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=zgrid(i,j,k-1)-.5*(hwide(k-1)+hwide(k))
+ zgrid(i,j,k+1)=zgrid(i,j,k)-.5*hwide(k)
+ else
+ hwide(k)=0.
+ endif
+ enddo
+c
+c --- perform niter iterations to execute the semi-implicit solution of the
+c --- diffusion equation. at least two iterations are recommended
+c
+ do iter=1,niter
+c
+c --- calculate layer variables required to estimate bulk richardson number
+c
+c --- calculate nearsurface reference variables,
+c --- averaged over -2*epsilon*zgrid, but no more than 8m.
+ zrefmn = -4.0
+ zrefo = 1.0 ! impossible value
+ do k=1,klist(i,j)
+ zref=max(epsilon*zgrid(i,j,k),zrefmn) ! nearest to zero
+ if (zref.ne.zrefo) then ! new zref
+ wref =-2.0*zref
+ qwref=1.0/wref
+ wq=min(hwide(1),wref)*qwref
+ uref=uold(1)*wq
+ vref=vold(1)*wq
+ bref=-g*thref*(thold(1)+thbase)*wq
+ wt=0.0
+ do ka=2,k
+ wt=wt+wq
+ if (wt.ge.1.0) then
+ exit
+ endif
+ wq=min(1.0-wt,hwide(ka)*qwref)
+ uref=uref+uold(ka)*wq
+ vref=vref+vold(ka)*wq
+ bref=bref-g*thref*(thold(ka)+thbase)*wq
+ enddo
+ endif
+ zrefo=zref
+c
+ ritop(k)=(zref-zgrid(i,j,k))*
+ & (bref+g*thref*(thold(k)+thbase))
+ dvsq(k)=(uref-uold(k))**2+(vref-vold(k))**2
+*
+* if (i.eq.itest.and.j.eq.jtest) then
+* if (k.eq.1) then
+* write(lp,'(3a)')
+* & ' k z zref',
+* & ' u uref v vref',
+* & ' b bref ritop dvsq'
+* endif
+* write(lp,'(i2,f9.2,f6.2,4f7.3,2f7.3,f9.4,f7.4)')
+* & k,zgrid(i,j,k),zref,
+* & uold(k),uref,vold(k),vref,
+* & -g*thref*(thold(k)+thbase),bref,
+* & ritop(k),dvsq(k)
+* call flush(lp)
+* endif
+c
+ if (zgrid(i,j,k)*onem*beta_r.gt.-10.0) then
+ swfrac(k)=frac_r*exp(zgrid(i,j,k)*onem*beta_r)+
+ & frac_b*exp(zgrid(i,j,k)*onem*beta_b)
+ elseif (zgrid(i,j,k)*onem*beta_b.gt.-10.0) then
+ swfrac(k)=frac_b*exp(zgrid(i,j,k)*onem*beta_b)
+ else
+ swfrac(k)=0.0
+ endif
+ swfrac(k)=swfrac(k)-swfbqp*zgrid(i,j,k)*onem !spread out bottom frac
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,'(i9,2i5,i3,a,f8.2,f8.3)')
+cdiag& nstep,i+i0,j+j0,k,
+cdiag& ' z,swfrac =',zgrid(i,j,k),swfrac(k)
+cdiag call flush(lp)
+cdiag endif
+ enddo !k=1,klist
+c
+c --- calculate interface variables required to estimate interior diffusivities
+ do k=1,klist(i,j)
+ k1=k+1
+ ka=min(k1,kk)
+ shsq (k1)=(uold(k)-uold(k1))**2+(vold(k)-vold(k1))**2
+ if (.not.locsig) then
+ alfadt(k1)=.5*(dsigdt(told(k ),sold(k ))+
+ & dsigdt(told(k1),sold(k1)))*
+ & (told(k)-told(k1))
+ betads(k1)=.5*(dsigds(told(k ),sold(k ))+
+ & dsigds(told(k1),sold(k1)))*
+ & (sold(k)-sold(k1))
+ dbloc(k1)=-g* thref*(thold(k)-thold(ka))
+ else
+ dbloc(k1)=-g*thref*(alfadt(k1)+betads(k1))
+ endif
+ enddo
+c
+c --- zero 1-d arrays for viscosity/diffusivity calculations
+c
+ do k=1,kk+1
+ vcty (i,j,k) =0.0
+ dift (i,j,k) =0.0
+ difs (i,j,k) =0.0
+ ghats(i,j,k) =0.0
+ blmc( k,1)=0.0
+ blmc( k,2)=0.0
+ blmc( k,3)=0.0
+ bblmc( k,1)=0.0
+ bblmc( k,2)=0.0
+ bblmc( k,3)=0.0
+ enddo
+c
+c --- determine interior diffusivity profiles throughout the water column
+c
+c --- shear instability plus background internal wave contributions
+ do k=2,klist(i,j)
+ if (shinst) then
+ q =zgrid(i,j,k-1)-zgrid(i,j,k) !0.5*(hwide(k-1)+hwide(k))
+ rigr=max(0.0,dbloc(k)*q/(shsq(k)+epsil))
+ ratio=min(rigr*qrinfy,1.0)
+ fri=(1.0-ratio*ratio)
+ fri=fri*fri*fri
+ vcty(i,j,k)=min(difm0*fri+dflmiw,difmax)
+ difs(i,j,k)=min(difs0*fri+dflsiw,difmax)
+ else
+ vcty(i,j,k)=dflmiw
+ difs(i,j,k)=dflsiw
+ endif
+ dift(i,j,k)=difs(i,j,k)
+ enddo
+c
+c --- double-diffusion (salt fingering and diffusive convection)
+ if (dbdiff) then
+ do k=2,klist(i,j)
+c
+c --- salt fingering case
+ if (-alfadt(k).gt.betads(k) .and. betads(k).gt.0.) then
+ rrho= min(-alfadt(k)/betads(k),rrho0)
+ diffdd=1.-((rrho-1.)/(rrho0-1.))**2
+ diffdd=dsfmax*diffdd*diffdd*diffdd
+ dift(i,j,k)=dift(i,j,k)+0.7*diffdd
+ difs(i,j,k)=difs(i,j,k)+diffdd
+c
+c --- diffusive convection case
+ else if ( alfadt(k).gt.0.0 .and. betads(k).lt.0.0
+ & .and. -alfadt(k).gt.betads(k)) then
+ rrho=-alfadt(k)/betads(k)
+ diffdd=1.5e-6*9.*.101*exp(4.6*exp(-.54*(1./rrho-1.)))
+ if (rrho.gt.0.5) then
+ prandtl=(1.85-.85/rrho)*rrho
+ else
+ prandtl=.15*rrho
+ endif
+ dift(i,j,k)=dift(i,j,k)+diffdd
+ difs(i,j,k)=difs(i,j,k)+prandtl*diffdd
+ endif
+ enddo
+ endif
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,102) (nstep,iter,i+i0,j+j0,k,
+cdiag& hwide(k),1.e4*vcty(i,j,k),1.e4*dift(i,j,k),1.e4*difs(i,j,k),
+cdiag& k=1,kk+1)
+cdiag call flush(lp)
+cdiag endif
+c
+c --- calculate boundary layer diffusivity profiles and match these to the
+c --- previously-calculated interior diffusivity profiles
+c
+c --- diffusivities within the surface boundary layer are parameterized
+c --- as a function of boundary layer thickness times a depth-dependent
+c --- turbulent velocity scale (proportional to ustar) times a third-order
+c --- polynomial shape function of depth. boundary layer diffusivities depend
+c --- on surface forcing (the magnitude of this forcing and whether it is
+c --- stabilizing or de-stabilizing) and the magnitude and gradient of interior
+c --- mixing at the boundary layer base. boundary layer diffusivity profiles
+c --- are smoothly matched to interior diffusivity profiles at the boundary
+c --- layer base (the profiles and their first derivatives are continuous
+c --- at z=-hbl). the turbulent boundary layer depth is diagnosed first, the
+c --- boundary layer diffusivity profiles are calculated, then the boundary
+c --- and interior diffusivity profiles are combined.
+c
+c --- minimum hbl is top mid-layer + 1 cm or bldmin,
+c --- maximum hbl is bottom mid-layer - 1 cm or bldmax.
+c
+ hblmin=max( hwide(1)+0.01,bldmin)
+ hblmax=min(-zgrid(i,j,klist(i,j))-0.01,bldmax)
+c
+c --- buoyfl = total buoyancy flux (m**2/sec**3) into atmos.
+c --- note: surface density increases (column is destabilized) if buoyfl > 0
+c --- buoysw = shortwave radiation buoyancy flux (m**2/sec**3) into atmos.
+c --- salflx, sswflx and surflx are positive into the ocean
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+ dsgdt= dsigdt(tmn,smn)
+ buoyfs=g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref)
+ buoyfl=buoyfs+
+ & g*thref*(dsgdt *surflx(i,j)*thref/spcifh)
+ buoysw=g*thref*(dsgdt *sswflx(i,j)*thref/spcifh)
+c
+c --- diagnose the new boundary layer depth as the depth where a bulk
+c --- richardson number exceeds ric
+c
+c --- initialize hbl and nbl to bottomed out values
+ kup2=1
+ kup =2
+ kdn =3
+ rib(kup2)=0.0
+ rib(kup) =0.0
+ nbl=klist(i,j)
+ hbl=hblmax
+c
+c --- diagnose hbl and nbl
+ do k=2,nbl
+ case=-zgrid(i,j,k)
+ bfsfc=buoyfl-swfrac(k)*buoysw
+ if (bfsfc.le.0.0) then
+ stable=1.0
+ dnorm =1.0
+ else
+ stable=0.0
+ dnorm =epsilon
+ endif
+c
+c --- compute turbulent velocity scales at dnorm, for
+c --- hbl = case = -zgrid(i,j,k)
+ call wscale(i,j,case,dnorm,bfsfc,wm,ws,1)
+c
+c --- compute the turbulent shear contribution to rib
+ if (max(dbloc(k),dbloc(k+1)).gt.0.0) then
+ bfq=0.5*(dbloc(k )/(zgrid(i,j,k-1)-zgrid(i,j,k ))+
+ & dbloc(k+1)/(zgrid(i,j,k )-zgrid(i,j,k+1)) )
+ if (bfq.gt.0.0) then
+ bfq=sqrt(bfq)
+ else
+ bfq=0.0 !neutral or unstable
+ endif
+ else
+ bfq=0.0 !neutral or unstable
+ endif
+ if (bfq.gt.0.0) then
+ if (cv.ne.0.0) then
+ cvk=cv
+ else !frequency dependent version
+ cvk=max(cv_max-cv_bfq*bfq,cv_min) !between cv_min and cv_max
+ endif
+ vtsq=-zgrid(i,j,k)*ws*bfq*vtc*cvk
+ else
+ vtsq=0.0
+ endif !bfq>0:else
+c
+c --- compute bulk richardson number at new level
+ rib(kdn)=ritop(k)/(dvsq(k)+vtsq+epsil)
+ if (nbl.eq.klist(i,j).and.rib(kdn).ge.ricr) then
+c --- interpolate to find hbl as the depth where rib = ricr
+ if (k.eq.2 .or. hblflg.eq.0) then !nearest interface
+ hbl = -zgrid(i,j,k-1)+0.5*hwide(k-1)
+ elseif (k.lt.4 .or. hblflg.eq.1) then !linear
+ hbl = -zgrid(i,j,k-1)+
+ & (zgrid(i,j,k-1)-zgrid(i,j,k))*
+ & (ricr-rib(kup))/(rib(kdn)-rib(kup)+epsil)
+ else !quadratic
+c
+c --- Determine the coefficients A,B,C of the polynomial
+c --- Y(X) = A * (X-X2)**2 + B * (X-X2) + C
+c --- which goes through the data: (X[012],Y[012])
+c
+ x0 = zgrid(i,j,k-2)
+ x1 = zgrid(i,j,k-1)
+ x2 = zgrid(i,j,k)
+ y0 = rib(kup2)
+ y1 = rib(kup)
+ y2 = rib(kdn)
+ ahbl = ( (y0-y2)*(x1-x2) -
+ & (y1-y2)*(x0-x2) )/
+ & ( (x0-x2)*(x1-x2)*(x0-x1) )
+ bhbl = ( (y1-y2)*(x0-x2)**2 -
+ & (y0-y2)*(x1-x2)**2 ) /
+ & ( (x0-x2)*(x1-x2)*(x0-x1) )
+ if (abs(bhbl).gt.epsil) then
+ lhbl = abs(ahbl)/abs(bhbl).gt.epsil
+ else
+ lhbl = .true.
+ endif
+ if (lhbl) then !quadratic
+c --- find root of Y(X)-RICR nearest to X2
+ chbl = y2 - ricr
+ dhbl = bhbl**2 - 4.0*ahbl*chbl
+ if (dhbl.lt.0.0) then !linear
+ hbl = -(x2 + (x1-x2)*(y2-ricr)/(y2-y1+epsil))
+ else
+ dhbl = sqrt(dhbl)
+ if (abs(bhbl+dhbl).ge.
+ & abs(bhbl-dhbl) ) then
+ hbl = -(x2 - 2.0*chbl/(bhbl+dhbl))
+ else
+ hbl = -(x2 - 2.0*chbl/(bhbl-dhbl))
+ endif !nearest root
+ endif !bhbl**2-4.0*ahbl*chbl.lt.0.0:else
+ else !linear
+ hbl = -(x2 + (x1-x2)*(y2-ricr)/(y2-y1+epsil))
+ endif !quadratic:linear
+ endif !linear:quadratic
+ nbl=k
+ if (hbl.lt.hblmin) then
+ hbl=hblmin
+ nbl=2
+ endif
+ if (hbl.gt.hblmax) then
+ hbl=hblmax
+ nbl=klist(i,j)
+ endif
+ exit !k-loop
+ endif
+c
+ ksave=kup2
+ kup2=kup
+ kup =kdn
+ kdn =ksave
+ enddo !k=1,nbl
+c
+c --- calculate swfrml, the fraction of solar radiation left at depth hbl
+ if (-hbl*onem*beta_r.gt.-10.0) then
+ swfrml=frac_r*exp(-hbl*onem*beta_r)+
+ & frac_b*exp(-hbl*onem*beta_b)
+ elseif (-hbl*onem*beta_b.gt.-10.0) then
+ swfrml=frac_b*exp(-hbl*onem*beta_b)
+ else
+ swfrml=0.0
+ endif
+ swfrml=swfrml-swfbqp*hbl*onem !spread out bottom frac
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,'(i9,2i5,i3,a,f8.2,f6.3)')
+cdiag& nstep,i+i0,j+j0,nbl,
+cdiag& ' hbl,swfrml =',hbl,swfrml
+cdiag call flush(lp)
+cdiag endif
+c
+c --- limit check on hbl for negative (stablizing) surface buoyancy forcing
+ bfsfc=buoyfl-swfrml*buoysw
+ if (bfsfc.le.0.0) then
+ bfsfc=bfsfc-epsil !insures bfsfc never=0
+ hmonob(i,j)=min(-cmonob*ustar(i,j)**3/(vonk*bfsfc), hblmax)
+ hbl=max(hblmin,
+ & min(hbl,
+ & hekman(i,j),
+ & hmonob(i,j)))
+ else
+ hmonob(i,j)=hblmax
+ endif
+c
+c --- find new nbl and re-calculate swfrml
+ nbl=klist(i,j)
+ do k=2,klist(i,j)
+ if (-zgrid(i,j,k).gt.hbl) then
+ nbl=k
+ exit
+ endif
+ enddo
+ if (-hbl*onem*beta_r.gt.-10.0) then
+ swfrml=frac_r*exp(-hbl*onem*beta_r)+
+ & frac_b*exp(-hbl*onem*beta_b)
+ elseif (-hbl*onem*beta_b.gt.-10.0) then
+ swfrml=frac_b*exp(-hbl*onem*beta_b)
+ else
+ swfrml=0.0
+ endif
+ swfrml=swfrml-swfbqp*hbl*onem !spread out bottom frac
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,'(i9,2i5,i3,a,f8.2,f6.3)')
+cdiag& nstep,i+i0,j+j0,nbl,
+cdiag& ' hbl,swfrml =',hbl,swfrml
+cdiag call flush(lp)
+cdiag endif
+c
+c --- find forcing stability and buoyancy forcing for final hbl values
+c --- determine case (for case=0., hbl lies between -zgrid(i,j,nbl)
+c --- and the interface above. for case=1., hbl lies between
+c --- -zgrid(i,j,nbl-1) and the interface below)
+c
+c --- velocity scales at hbl
+ bfsfc=buoyfl-swfrml*buoysw
+ if (bfsfc.le.0.0) then
+ bfsfc=bfsfc-epsil !insures bfsfc never=0
+ stable=1.0
+ dnorm =1.0
+ else
+ stable=0.0
+ dnorm =epsilon
+ endif
+ case=.5+sign(.5,-zgrid(i,j,nbl)-.5*hwide(nbl)-hbl)
+c
+ buoflx(i,j)=bfsfc !mixed layer buoyancy
+ bhtflx(i,j)=bfsfc-buoyfs !buoyancy from heat flux
+ mixflx(i,j)=surflx(i,j)-swfrml*sswflx(i,j) !mixed layer heat flux
+c
+ call wscale(i,j,hbl,dnorm,bfsfc,wm,ws,1)
+c
+c --- compute the boundary layer diffusivity profiles. first, find interior
+c --- viscosities and their vertical derivatives at hbl
+ ka=nint(case)*(nbl-1)+(1-nint(case))*nbl
+ q=(hbl*onem-p(i,j,ka))*qdpmm(ka)
+ vctyh=vcty(i,j,ka)+q*(vcty(i,j,ka+1)-vcty(i,j,ka))
+ difsh=difs(i,j,ka)+q*(difs(i,j,ka+1)-difs(i,j,ka))
+ difth=dift(i,j,ka)+q*(dift(i,j,ka+1)-dift(i,j,ka))
+c
+ q=(hbl+zgrid(i,j,nbl-1))/(zgrid(i,j,nbl-1)-zgrid(i,j,nbl))
+ dvdzup=(vcty(i,j,nbl-1)-vcty(i,j,nbl ))/hwide(nbl-1)
+ dvdzdn=(vcty(i,j,nbl )-vcty(i,j,nbl+1))/hwide(nbl )
+ viscp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+ dvdzup=(difs(i,j,nbl-1)-difs(i,j,nbl ))/hwide(nbl-1)
+ dvdzdn=(difs(i,j,nbl )-difs(i,j,nbl+1))/hwide(nbl )
+ difsp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+ dvdzup=(dift(i,j,nbl-1)-dift(i,j,nbl ))/hwide(nbl-1)
+ dvdzdn=(dift(i,j,nbl )-dift(i,j,nbl+1))/hwide(nbl )
+ diftp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+c
+ f1=-stable*c11*bfsfc/(ustar(i,j)**4+epsil)
+c
+ gat1(1)=vctyh/hbl/(wm+epsil)
+ dat1(1)=min(0.,-viscp/(wm+epsil)+f1*vctyh)
+c
+ gat1(2)=difsh/hbl/(ws+epsil)
+ dat1(2)=min(0.,-difsp/(ws+epsil)+f1*difsh)
+c
+ gat1(3)=difth/hbl/(ws+epsil)
+ dat1(3)=min(0.,-diftp/(ws+epsil)+f1*difth)
+c
+c --- compute turbulent velocity scales on the interfaces
+ do k=2,kk+1
+ if (k.le.min(nbl,klist(i,j))) then
+ sigg=p(i,j,k)/(hbl*onem)
+ dnorm=stable*sigg+(1.-stable)*min(sigg,epsilon)
+c
+ call wscale(i,j,hbl,dnorm,bfsfc,wm,ws,1)
+c
+c --- compute the dimensionless shape functions at the interfaces
+ aa1=sigg-2.
+ aa2=3.-2.*sigg
+ aa3=sigg-1.
+c
+ gm=aa1+aa2*gat1(1)+aa3*dat1(1)
+ gs=aa1+aa2*gat1(2)+aa3*dat1(2)
+ gt=aa1+aa2*gat1(3)+aa3*dat1(3)
+c
+c --- compute boundary layer diffusivities at the interfaces
+ blmc(k,1)=hbl*wm*sigg*(1.+sigg*gm)
+ blmc(k,2)=hbl*ws*sigg*(1.+sigg*gs)
+ blmc(k,3)=hbl*ws*sigg*(1.+sigg*gt)
+c
+c --- compute nonlocal transport forcing term = ghats * o
+ if (nonloc) then
+ ghats(i,j,k)=(1.-stable)*cg/(ws*hbl+epsil)
+ endif
+ endif !k.le.min(nbl,klist)
+ enddo !k
+c
+c --- enhance diffusivities on the interface closest to hbl
+c
+c --- first compute diffusivities at nbl-1 grid level
+ sigg=-zgrid(i,j,nbl-1)/hbl
+ dnorm=stable*sigg+(1.-stable)*min(sigg,epsilon)
+c
+ call wscale(i,j,hbl,dnorm,bfsfc,wm,ws,1)
+c
+ sigg=-zgrid(i,j,nbl-1)/hbl
+ aa1=sigg-2.
+ aa2=3.-2.*sigg
+ aa3=sigg-1.
+ gm=aa1+aa2*gat1(1)+aa3*dat1(1)
+ gs=aa1+aa2*gat1(2)+aa3*dat1(2)
+ gt=aa1+aa2*gat1(3)+aa3*dat1(3)
+ dkm1(1)=hbl*wm*sigg*(1.+sigg*gm)
+ dkm1(2)=hbl*ws*sigg*(1.+sigg*gs)
+ dkm1(3)=hbl*ws*sigg*(1 +sigg*gt)
+c
+c --- now enhance diffusivity at interface nbl
+c
+c --- this procedure was altered for hycom to reduce diffusivity enhancement
+c --- if the interface in question is located more than dp0enh below hbl.
+c --- this prevents enhanced boundary layer mixing from penetrating too far
+c --- below hbl when hbl is located in a very thick layer
+ k=nbl-1
+ ka=k+1
+ delta=(hbl+zgrid(i,j,k))/(zgrid(i,j,k)-zgrid(i,j,ka))
+c
+ dkmp2=case*vcty(i,j,ka)+(1.-case)*blmc(ka,1)
+ dstar=(1.-delta)**2*dkm1(1)+delta**2*dkmp2
+ blmc(ka,1)=(1.-delta)*vcty(i,j,ka)+delta*dstar
+c
+ dkmp2=case*difs(i,j,ka)+(1.-case)*blmc(ka,2)
+ dstar=(1.-delta)**2*dkm1(2)+delta**2*dkmp2
+ blmc(ka,2)=(1.-delta)*difs(i,j,ka)+delta*dstar
+c
+ dkmp2=case*dift(i,j,ka)+(1.-case)*blmc(ka,3)
+ dstar=(1.-delta)**2*dkm1(3)+delta**2*dkmp2
+ blmc(ka,3)=(1.-delta)*dift(i,j,ka)+delta*dstar
+c
+ if (case.eq.1.) then
+ q=1.-case*max(0.,min(1.,(p(i,j,ka)-hbl*onem-dp0enh)/dp0enh))
+ blmc(ka,1)=max(vcty(i,j,ka),q*blmc(ka,1))
+ blmc(ka,2)=max(difs(i,j,ka),q*blmc(ka,2))
+ blmc(ka,3)=max(dift(i,j,ka),q*blmc(ka,3))
+ endif
+c
+ if (nonloc) then
+ ghats(i,j,ka)=(1.-case)*ghats(i,j,ka)
+ endif
+c
+c --- combine interior and boundary layer coefficients and nonlocal term
+ if (.not.bblkpp) then
+ do k=2,nbl
+ vcty(i,j,k)=max(vcty(i,j,k),min(blmc(k,1),difmax))
+ difs(i,j,k)=max(difs(i,j,k),min(blmc(k,2),difmax))
+ dift(i,j,k)=max(dift(i,j,k),min(blmc(k,3),difmax))
+ enddo
+ do k=nbl+1,klist(i,j)
+ ghats(i,j,k)=0.0
+ enddo
+ do k=klist(i,j)+1,kk+1
+ vcty(i,j,k)=dflmiw
+ difs(i,j,k)=dflsiw
+ dift(i,j,k)=dflsiw
+ ghats(i,j,k)=0.0
+ enddo
+ endif !.not.bblkpp
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,103) (nstep,iter,i+i0,j+j0,k,
+cdiag& hwide(k),1.e4*vcty(i,j,k),1.e4*dift(i,j,k),1.e4*difs(i,j,k),
+cdiag& ghats(i,j,k),k=1,kk+1)
+cdiag call flush(lp)
+cdiag endif
+c
+c --- save array dpbl=onem*hbl for ice, output and diagnosis
+ dpbl(i,j)=onem*hbl
+c
+ if (bblkpp) then
+c
+c ------------------------------------------------
+c
+c --- begin bottom boundary layer parameterization
+c
+c ------------------------------------------------
+c
+c --- this bottom boundary algorithm follows the kpp algorithm included
+c --- in the rutgers roms model. it is essentially an adaptation of the
+c --- algorithm used for the surface boundary layer, involving diagnosis
+c --- of the bottom boundary layer thickness hbbl using a bulk
+c --- richardson number
+c
+c --- calculate zgridb
+ do k=klist(i,j)+1,1,-1
+ zgridb(k)=zgrid(i,j,k)-zgrid(i,j,klist(i,j)+1)
+ enddo
+c
+c --- calculate bottom boundary layer diffusivity profiles and match these
+c --- to the existing profiles
+c
+c --- minimum hbbl is 1 m, maximum is distance between bottom and one meter
+c --- below the base of model layer 1
+c
+ hbblmin=1.0
+ hbblmax=zgridb(2)
+* hbblmax=min(-hbl-zgrid(i,j,klist(i,j)+1),2.0*thkbot)
+c
+c --- buoyfl = buoyancy flux (m**2/sec**3) into bottom due to heating by
+c --- the penetrating shortwave radiation
+c --- note: bottom density increases (column is destabilized) if buoyfl < 0
+c --- buoysw = shortwave radiation buoyancy flux (m**2/sec**3) at the surface
+c
+c --- NOTE: the convention for the bottom bl in the roms model was to use the
+c --- surface net (turbulent plus radiative) heat flux to represent buoyfl
+c --- this convention is not used here - instead, bottom turbulent heat
+c --- flux arises entirely due to heating of the bottom by the penetrating
+c --- shortwave radiation. as a result, net heat flux (buoyfl) at the bottom
+c --- is zero since upward turbulent heat flux due to bottom heating is
+c --- opposed by the downward shortwave radiative heat flux (it is presently
+c --- assumed that no heat is absorbed by the bottom). Moving upward from
+c --- the bottom, penetrating shortwave radiation acts to stabilize the
+c --- water column.
+c
+ if (locsig) then
+ dsgdt=dsiglocdt(temp(i,j,klist(i,j),n),
+ & saln(i,j,klist(i,j),n),
+ & 0.5*(pij(klist(i,j))+pij(klist(i,j)+1)))
+ else
+ dsgdt=dsigdt(temp(i,j,klist(i,j),n),
+ & saln(i,j,klist(i,j),n))
+ endif
+ buoysw=-g*thref*dsgdt*sswflx(i,j)*thref/spcifh
+ buoyfl=-swfrac(klist(i,j)+1)*buoysw
+c
+c --- diagnose the new boundary layer depth as the depth where a bulk
+c --- richardson number exceeds ric
+c
+c --- initialize hbbl and nbbl to extreme values
+ kdn2=1
+ kdn =2
+ kup =3
+ rib(kdn2)=0.0
+ rib(kdn) =0.0
+ nbbl=2
+ hbbl=hbblmax
+c
+c --- nearbottom reference values of model variables are handled
+c --- differently from the surface layer because the surface
+c --- procedure does not work properly with the highly-uneven
+c --- layer thicknesses often present near the bottom.
+c --- reference values are chosen as the values present at the
+c --- bottom = hence, uref, vref are zero and not used while
+c --- bottom buoyancy is estimated assuming a linear vertical
+c --- profile across the bottom layer
+c
+ bref=g*thref*(0.5*(3.0*thold(klist(i,j))-
+ & thold(klist(i,j)-1))+thbase)
+c
+c --- diagnose hbbl and nbbl
+ do k=klist(i,j),nbbl,-1
+ ritop(k)=max(zgridb(k)*(bref-g*thref*(thold(k)+thbase)),
+ & epsil)
+ dvsq(k)=uold(k)**2+vold(k)**2
+c
+ case=zgridb(k)
+ bfbot=0.0
+ stable=1.0
+ dnorm =1.0
+c
+c --- compute turbulent velocity scales at dnorm, for
+c --- hbbl = case = zgridb(k)
+ call wscale(i,j,case,dnorm,bfbot,wm,ws,2)
+c
+c --- compute the turbulent shear contribution to rib
+ if (max(dbloc(k),dbloc(k+1)).gt.0.0) then
+ bfq=0.5*(dbloc(k )/(zgrid(i,j,k-1)-zgrid(i,j,k ))+
+ & dbloc(k+1)/(zgrid(i,j,k )-zgrid(i,j,k+1)) )
+ if (bfq.gt.0.0) then
+ bfq=sqrt(bfq)
+ else
+ bfq=0.0 !neutral or unstable
+ endif
+ else
+ bfq=0.0 !neutral or unstable
+ endif
+ if (bfq.gt.0.0) then
+ if (cv.ne.0.0) then
+ cvk=cv
+ else !frequency dependent version
+ cvk=max(cv_max-cv_bfq*bfq,cv_min) !between cv_min and cv_max
+ endif
+ vtsq=zgridb(k)*ws*bfq*vtc*cvk
+ else
+ vtsq=0.0
+ endif !bfq>0:else
+c
+c --- compute bulk richardson number at new level
+c --- interpolate to find hbbl as the depth where rib = ricrb
+c --- in stable or neutral conditions, hbbl can be no thicker than the
+c --- bottom ekman layer
+c --- ustarb is estimated in momtum.f
+c
+ rib(kup)=ritop(k)/(dvsq(k)+vtsq+epsil)
+ if (rib(kup).ge.ricrb) then
+ hekmanb=ustarb(i,j)*(cekman*4.0)/max( cormn4,
+ & abs(corio(i,j ))+abs(corio(i+1,j ))+
+ & abs(corio(i,j+1))+abs(corio(i+1,j+1)))
+ if (hblflg.eq.0) then !nearest intf.
+ hbbl = zgridb(k+1)-0.5*hwide(k+1)
+ elseif (k.gt.klist(i,j)-2 .or. hblflg.eq.1) then !linear
+ hbbl = zgridb(k+1)-
+ & (zgridb(k+1)-zgridb(k))*
+ & (ricrb-rib(kdn))/(rib(kup)-rib(kdn)+epsil)
+ else !quadratic
+c
+c --- Determine the coefficients A,B,C of the polynomial
+c --- Y(X) = A * (X-X2)**2 + B * (X-X2) + C
+c --- which goes through the data: (X[012],Y[012])
+c
+ x0 = -zgridb(k+2)
+ x1 = -zgridb(k+1)
+ x2 = -zgridb(k)
+ y0 = rib(kdn2)
+ y1 = rib(kdn)
+ y2 = rib(kup)
+ ahbl = ( (y0-y2)*(x1-x2) -
+ & (y1-y2)*(x0-x2) )/
+ & ( (x0-x2)*(x1-x2)*(x0-x1) )
+ bhbl = ( (y1-y2)*(x0-x2)**2 -
+ & (y0-y2)*(x1-x2)**2 ) /
+ & ( (x0-x2)*(x1-x2)*(x0-x1) )
+ if (abs(bhbl).gt.epsil) then
+ lhbl = abs(ahbl)/abs(bhbl).gt.epsil
+ else
+ lhbl = .true.
+ endif
+ if (lhbl) then !quadratic
+c --- find root of Y(X)-RICR nearest to X2
+ chbl = y2 - ricrb
+ dhbl = bhbl**2 - 4.0*ahbl*chbl
+ if (dhbl.lt.0.0) then !linear
+ hbbl = -(x2 + (x1-x2)*(y2-ricrb)/(y2-y1+epsil))
+ else
+ dhbl = sqrt(dhbl)
+ if (abs(bhbl+dhbl).ge.
+ & abs(bhbl-dhbl) ) then
+ hbbl = -(x2 - 2.0*chbl/(bhbl+dhbl))
+ else
+ hbbl = -(x2 - 2.0*chbl/(bhbl-dhbl))
+ endif !nearest root
+ endif !bhbl**2-4.0*ahbl*chbl.lt.0.0:else
+ else !linear
+ hbbl = -(x2 + (x1-x2)*(y2-ricrb)/(y2-y1+epsil))
+ endif !quadratic:linear
+ endif
+ hbbl=max(hbblmin,min(hekmanb,hbblmax,hbbl))
+ exit !k-loop
+ endif
+c
+ ksave=kdn2
+ kdn2=kdn
+ kdn =kup
+ kup =ksave
+ enddo !k=klist(i,j),nbbl,-1
+c
+c--- find new nbbl
+ nbbl=2
+ do k=klist(i,j),2,-1
+ if (zgridb(k).gt.hbbl) then
+ nbbl=k
+ exit
+ endif
+ enddo !k=klist(i,j),2,-1
+c
+c --- do not execute the remaining bottom boundary layer algorithm if
+c --- vertical resolution is not available in the boundary layer
+c
+* if (hbbl.lt.0.5*hwide(klist(i,j))) then
+ if (hbbl.lt.0.5* hwide(klist(i,j))+
+ & 0.5*min(hwide(klist(i,j) ),
+ & hwide(klist(i,j)-1) )) then
+ go to 201 !one grid point in bbl and probably not a "plume"
+ endif
+c
+c --- calculate swfrml, the fraction of solar radiation absorbed by depth hbbl
+ q=(zgridb(nbbl-1)-hbbl)/(zgridb(nbbl-1)-zgridb(nbbl))
+ swfrml=swfrac(nbbl-1)+q*(swfrac(nbbl)-swfrac(nbbl-1))
+c
+c --- find forcing stability and buoyancy forcing for final hbbl values
+c --- determine case (for case=0., hbbl lies between -zgridb(nbbl)
+c --- and the interface below. for case=1., hbbl lies between
+c --- -zgrid(nbbl+1) and the interface above)
+c
+c --- velocity scales at hbbl
+ bfbot=buoyfl+swfrml*buoysw
+ if (bfbot.ge.0.0) then
+ bfbot=bfbot+epsil !insures bfbot never=0
+ stable=1.0
+ dnorm =1.0
+ else
+ stable=0.0
+ dnorm =epsilon
+ endif
+ case=.5+sign(.5,zgridb(nbbl)-.5*hwide(nbbl)-hbbl)
+c
+ call wscale(i,j,hbbl,dnorm,bfbot,wm,ws,2)
+c
+c --- compute the boundary layer diffusivity profiles. first, find interior
+c --- viscosities and their vertical derivatives at hbbl
+ ka=nint(case)*(nbbl+1)+(1-nint(case))*nbbl
+ q=(pij(klist(i,j)+1)-pij(ka)-hbbl*onem)*qdpmm(ka)
+ vctyh=vcty(i,j,ka)+q*(vcty(i,j,ka+1)-vcty(i,j,ka))
+ difsh=difs(i,j,ka)+q*(difs(i,j,ka+1)-difs(i,j,ka))
+ difth=dift(i,j,ka)+q*(dift(i,j,ka+1)-dift(i,j,ka))
+c
+ q=(hbbl-zgridb(nbbl+1))/(zgridb(nbbl)-zgridb(nbbl+1))
+ dvdzup=-(vcty(i,j,nbbl )-vcty(i,j,nbbl+1))/hwide(nbbl )
+ dvdzdn=-(vcty(i,j,nbbl+1)-vcty(i,j,nbbl+2))/hwide(nbbl+1)
+ viscp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+ dvdzup=-(difs(i,j,nbbl )-difs(i,j,nbbl+1))/hwide(nbbl )
+ dvdzdn=-(difs(i,j,nbbl+1)-difs(i,j,nbbl+2))/hwide(nbbl+1)
+ difsp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+ dvdzup=-(dift(i,j,nbbl )-dift(i,j,nbbl+1))/hwide(nbbl)
+ dvdzdn=-(dift(i,j,nbbl+1)-dift(i,j,nbbl+2))/hwide(nbbl+1)
+ diftp=.5*((1.-q)*(dvdzup+abs(dvdzup))+q*(dvdzdn+abs(dvdzdn)))
+c
+ f1=stable*c11*bfbot/(ustarb(i,j)**4+epsil)
+c
+ gat1(1)=vctyh/hbbl/(wm+epsil)
+ dat1(1)=min(0.,-viscp/(wm+epsil)+f1*vctyh)
+c
+ gat1(2)=difsh/hbbl/(ws+epsil)
+ dat1(2)=min(0.,-difsp/(ws+epsil)+f1*difsh)
+c
+ gat1(3)=difth/hbbl/(ws+epsil)
+ dat1(3)=min(0.,-diftp/(ws+epsil)+f1*difth)
+c
+c --- compute turbulent velocity scales on the interfaces
+ do k=klist(i,j),nbbl+1,-1
+ sigg=(pij(klist(i,j)+1)-pij(k))/(hbbl*onem)
+ dnorm=stable*sigg+(1.-stable)*min(sigg,epsilon)
+c
+ call wscale(i,j,hbbl,dnorm,bfbot,wm,ws,2)
+c
+c --- compute the dimensionless shape functions at the interfaces
+ aa1=sigg-2.
+ aa2=3.-2.*sigg
+ aa3=sigg-1.
+c
+ gm=aa1+aa2*gat1(1)+aa3*dat1(1)
+ gs=aa1+aa2*gat1(2)+aa3*dat1(2)
+ gt=aa1+aa2*gat1(3)+aa3*dat1(3)
+c
+c --- compute boundary layer diffusivities at the interfaces
+ bblmc(k,1)=hbbl*wm*sigg*(1.+sigg*gm)
+ bblmc(k,2)=hbbl*ws*sigg*(1.+sigg*gs)
+ bblmc(k,3)=hbbl*ws*sigg*(1.+sigg*gt)
+ enddo !k=klist,nbbl+1,-1
+c
+c --- if the model interface nbbl+1 is located more than the distance
+c --- dp0bbl above hbbl, reduce diffusivity to prevent bottom mixing
+c --- from penetrating too far into the interior
+c
+ k=nbbl+1
+ delta=(pij(klist(i,j)+1)-pij(nbbl+1))*qonem-hbbl
+ if (delta.gt.dp0bbl) then
+ dstar=max(0.0,1.0+(dp0bbl-delta)/dp0bbl)
+ bblmc(k,1)=bblmc(k,1)*dstar
+ bblmc(k,2)=bblmc(k,2)*dstar
+ bblmc(k,3)=bblmc(k,3)*dstar
+ endif
+c
+ 201 continue ! skip bbl algorithm due to poor vertical resolution
+c
+c --- save array dpbbl=onem*hbbl for output and diagnosis, and for momtum.f
+ dpbbl(i,j)=onem*hbbl
+c
+c --- select maximum viscosity/diffusivity at all interfaces
+ do k=2,klist(i,j)
+ if (k.le.klist(i,j)) then
+ vcty(i,j,k)=min(difmax,
+ & max(vcty(i,j,k),blmc(k,1),bblmc(k,1)))
+ difs(i,j,k)=min(difmax,
+ & max(difs(i,j,k),blmc(k,2),bblmc(k,2)))
+ dift(i,j,k)=min(difmax,
+ & max(dift(i,j,k),blmc(k,3),bblmc(k,3)))
+ else
+ vcty(i,j,k)=dflmiw
+ difs(i,j,k)=dflsiw
+ dift(i,j,k)=dflsiw
+ endif
+ if (k.ge.nbl+1) then
+ ghats(i,j,k)=0.0
+ endif
+ enddo
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,103) (nstep,iter,i+i0,j+j0,k,
+cdiag& hwide(k),1.e4*vcty(i,j,k),1.e4*dift(i,j,k),1.e4*difs(i,j,k),
+cdiag& ghats(i,j,k),k=kk,1,-1)
+cdiag call flush(lp)
+cdiag endif
+cdiag if(i.eq.itest.and.j.eq.jtest.and.mod(nstep,20).eq.0) then
+cdiag print *,'nbbl,hbbl',nbbl,hbbl
+cdiag endif
+c
+ endif ! bblkpp
+c
+ if (iter.lt.niter) then
+c
+c --- perform the vertical mixing at p points
+c
+ do k=1,klist(i,j)
+ difft(k+1)=dift(i,j,k+1)
+ diffs(k+1)=difs(i,j,k+1)
+ diffm(k+1)=vcty(i,j,k+1)
+ ghat(k+1)=ghats(i,j,k+1)
+ t1do(k)=temp(i,j,k,n)
+ s1do(k)=saln(i,j,k,n)
+ u1do(k)=.5*(u(i,j,k,n)+u(i+1,j ,k,n))
+ v1do(k)=.5*(v(i,j,k,n)+v(i ,j+1,k,n))
+ hm(k)=hwide(k)
+ zm(k)=zgrid(i,j,k)
+ enddo
+c
+ nlayer=klist(i,j)
+ k=nlayer+1
+ ka=min(k,kk)
+ difft(k)=0.0
+ diffs(k)=0.0
+ diffm(k)=0.0
+ ghat(k)=0.0
+ t1do(k)=temp(i,j,ka,n)
+ s1do(k)=saln(i,j,ka,n)
+ u1do(k)=u1do(k-1)
+ v1do(k)=v1do(k-1)
+ zm(k)=zgrid(i,j,k)
+c
+c --- compute factors for coefficients of tridiagonal matrix elements.
+c tri(k=1:NZ,0) : dt/hwide(k)/ dzb(k-1)=z(k-1)-z(k)=dzabove)
+c tri(k=1:NZ,1) : dt/hwide(k)/(dzb(k )=z(k)-z(k+1)=dzbelow)
+c
+ do k=1,nlayer
+ dzb(k)=zm(k)-zm(k+1)
+ enddo
+c
+ tri(1,1)=delt1/(hm(1)*dzb(1))
+ tri(1,0)=0.
+ do k=2,nlayer
+ tri(k,1)=delt1/(hm(k)*dzb(k))
+ tri(k,0)=delt1/(hm(k)*dzb(k-1))
+ enddo
+c
+c --- solve the diffusion equation
+c --- salflx, sswflx and surflx are positive into the ocean
+c
+c --- t solution
+ ghatflux=-(surflx(i,j)-sswflx(i,j))*thref/spcifh
+ call tridcof(difft,tri,nlayer,tcu,tcc,tcl)
+ call tridrhs(hm,t1do,difft,ghat,ghatflux,tri,nlayer,rhs)
+ call tridmat(tcu,tcc,tcl,nlayer,hm,rhs,t1do,t1dn,difft, i,j)
+c
+c --- s solution
+ ghatflux=-salflx(i,j)*thref
+ call tridcof(diffs,tri,nlayer,tcu,tcc,tcl)
+ call tridrhs(hm,s1do,diffs,ghat,ghatflux,tri,nlayer,rhs)
+ call tridmat(tcu,tcc,tcl,nlayer,hm,rhs,s1do,s1dn,diffs, i,j)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,104) (nstep,iter,i+i0,j+j0,k,
+cdiag& hm(k),t1do(k),t1dn(k),s1do(k),s1dn(k),
+cdiag& 0.0,0.0,
+cdiag& k=1,nlayer)
+cdiag call flush(lp)
+cdiag endif
+c
+c --- u solution
+ call tridcof(diffm,tri,nlayer,tcu,tcc,tcl)
+ do k=1,nlayer
+ rhs(k)=u1do(k)
+ enddo
+ call tridmat(tcu,tcc,tcl,nlayer,hm,rhs,u1do,u1dn,diffm, i,j)
+c
+c --- v solution
+ do k=1,nlayer
+ rhs(k)=v1do(k)
+ enddo
+ call tridmat(tcu,tcc,tcl,nlayer,hm,rhs,v1do,v1dn,diffm, i,j)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,105) (nstep,iter,i+i0,j+j0,k,
+cdiag& hm(k),u1do(k),u1dn(k),v1do(k),v1dn(k),k=1,nlayer)
+cdiag call flush(lp)
+cdiag endif
+c
+c --- reset old variables in preparation for next iteration
+ do k=1,nlayer+1
+ told(k)=t1dn(k)
+ sold(k)=s1dn(k)
+ if (locsig) then
+ if (k.eq.1) then
+ thold(k)=sig(told(k),sold(k))-thbase
+ else
+ ka=k-1
+ alfadt(k)=0.5*
+ & (dsiglocdt(told(ka),sold(ka),p(i,j,k))+
+ & dsiglocdt(told(k ),sold(k ),p(i,j,k)))*
+ & (told(ka)-told(k))
+ betads(k)=0.5*
+ & (dsiglocds(told(ka),sold(ka),p(i,j,k))+
+ & dsiglocds(told(k ),sold(k ),p(i,j,k)))*
+ & (sold(ka)-sold(k))
+ thold(k)=thold(ka)-alfadt(k)-betads(k)
+ endif
+ else
+ thold(k)=sig(told(k),sold(k))-thbase
+ endif
+ if (iter.lt.niter) then
+ uold(k)=u1dn(k)
+ vold(k)=v1dn(k)
+ endif
+ enddo
+ endif ! iter < niter
+c
+ enddo ! iteration loop
+c
+ 101 format(i9,2i5,i3,'swfrac,dn,dtemp,dsaln ',2f8.3,2f12.6)
+ 102 format(25x,' thick viscty t diff s diff '
+ & /(i9,i2,2i5,i3,2x,4f10.2))
+ 103 format(25x,' thick viscty t diff s diff nonlocal'
+ & /(i9,i2,2i5,i3,2x,4f10.2,f11.6))
+ 104 format(25x,
+ & ' thick t old t new s old s new trc old trc new'
+ & /(i9,i2,2i5,i3,1x,f9.2,4f8.3,2f7.4))
+ 105 format(25x,' thick u old u new v old v new'
+ & /(i9,i2,2i5,i3,1x,f10.2,4f8.3))
+c
+ return
+ end
+ subroutine mxmyaij(m,n, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, i,j
+c
+c ---------------------------------------------------------------
+c --- mellor-yamada 2.5 vertical diffusion, single j-row (part A)
+c --- vertical coordinate is z negative below the ocean surface
+c ---------------------------------------------------------------
+c
+c --- arrays q2 and q2l are prognostic variables representing tke and
+c --- tke multiplied by the turbulent eddy length scale. these arrays
+c --- are calculated on interfaces in a special vertical grid where
+c --- interfaces are centered at the surface, bottom, and at mid-depths
+c --- of each hycom layer (kdm+2 interfaces). this enables the q2 and
+c --- q2l arrays to be advected and diffused in subroutine tsadvc.
+c
+ real, parameter :: difmax = 9999.0e-4 !maximum diffusion/viscosity
+c
+c --- local variables for my2.5 mixing
+c
+ real sm(kdm+2),sh(kdm+2),prod(kdm+2),stf(kdm+2)
+ real dtef(kdm+2),gh(kdm+2),ee(kdm+2),gg(kdm+2),turlen(kdm+2)
+ real z(kdm+2),zz(kdm+2),dz(kdm+2),dzz(kdm+2)
+ real th1d(kdm+1),u1d(kdm+1),v1d(kdm+1)
+ real alfadt(kdm+1),betads(kdm+1),delth(kdm+1)
+c
+ real dbloc(kdm+2) ! buoyancy jump across interface
+ real swfrac(kdm+1) ! fractional surface shortwave radiation flux
+ real dpmm(kdm) ! max(onemm,dp(i,j,:,[nm]))
+ real qdpmm(kdm) ! 1.0/max(onemm,dp(i,j,:,[nm]))
+ real pij(kdm+1) ! local copy of p(i,j,:)
+c
+ real dflsiw ! lat.dep. internal wave diffusivity
+ real dflmiw ! lat.dep. internal wave viscosity
+c
+ real dh,akn,coef1,coef2,coef3,dtemp,dsaln,sflux1,pmid,div
+ real wusurf,wvsurf,wubot,wvbot,delu,delv,ubav,vbav,qspcifh,q,
+ & beta_b,beta_r,frac_b,frac_r,swfbqp
+c
+ real buoyfl,buoyfs,buoysw,dsgdt,smn,tmn,swfrml
+c
+ integer k,ka,k1,khy1,khy2,kmy1,kmy2,jrlv
+c
+ integer iglobal,jglobal
+c
+ include 'stmt_fns.h'
+c
+ iglobal=i0+i !for debugging
+ jglobal=j0+j !for debugging
+ if (iglobal+jglobal.eq.-99) then
+ write(lp,*) iglobal,jglobal !prevent optimization
+ endif
+c
+ if (latdiw) then
+c --- spacially varying internal wave diffusion/viscosity
+ dflsiw = diwlat(i,j)
+ dflmiw = diwlat(i,j)*(difmiw/difsiw)
+ else
+c --- constant internal wave diffusion/viscosity
+ dflsiw = difsiw
+ dflmiw = difmiw
+ endif
+c
+c --- set mid-time pressure array
+c --- locate lowest substantial mass-containing layer.
+ pij(1)=p(i,j,1)
+ do k=1,kk
+ dpmm( k) =max(onemm,dp(i,j,k,m))
+ pij( k+1)=pij(k)+dp(i,j,k,m)
+ p(i,j,k+1)=pij(k+1)
+ enddo
+ do k=kk,1,-1
+ if (dpmm(k).gt.tencm) then
+ exit
+ endif
+ enddo
+ klist(i,j)=max(k,2) !always consider at least 2 layers
+c
+ dpbl(i,j)=min(dpbl(i,j),pij(kk+1))
+c
+ dh=depths(i,j)+srfhgt(i,j)/(thref*onem) !total depth, in m
+c
+c --- generate the scaled m-y vertical grid
+c --- calculate z (interface z), dz, zz (central layer z), dzz in m
+ khy1=klist(i,j)
+ khy2=khy1+1
+ kmy1=khy2
+ kmy2=kmy1+1
+c
+ z(1)=0.0
+ dz(1)=0.5*dpmm(1)/pij(khy2)
+ z(2)=-dz(1)
+ do k=3,kmy1
+ dz(k-1)=0.5*(dpmm(k-2)+dpmm(k-1))/pij(khy2)
+ z(k)=z(k-1)-dz(k-1)
+ enddo
+ dz(kmy1)=0.5*dpmm(khy1)/pij(khy2)
+ z(kmy2)=z(kmy1)-dz(kmy1)
+ dz(kmy2)=0.0
+c
+ do k=1,kmy1
+ zz(k)=0.5*(z(k)+z(k+1))
+ enddo
+ zz(kmy2)=2.0*z(kmy2)-zz(kmy1)
+c
+ do k=1,kmy1
+ dzz(k)=zz(k)-zz(k+1)
+ enddo
+ dzz(kmy2)=0.0
+c
+c --- calculate alfadt, betads if locally referenced potential density
+c --- is used to estimate buoyancy gradient
+ if (locsig) then
+ do k=2,khy1
+ ka=k-1
+ alfadt(k)=0.5*
+ & (dsiglocdt(temp(i,j,ka,m),saln(i,j,ka,m),p(i,j,k))+
+ & dsiglocdt(temp(i,j,k ,m),saln(i,j,k ,m),p(i,j,k)))*
+ & (temp(i,j,ka,m)-temp(i,j,k,m))
+ betads(k)=0.5*
+ & (dsiglocds(temp(i,j,ka,m),saln(i,j,ka,m),p(i,j,k))+
+ & dsiglocds(temp(i,j,k ,m),saln(i,j,k ,m),p(i,j,k)))*
+ & (saln(i,j,ka,m)-saln(i,j,k,m))
+ if (k.eq.2) then
+ alfadt(1)=alfadt(2)
+ betads(1)=betads(2)
+ endif
+ delth(k)=0.5*(alfadt(ka)+alfadt(k)+betads(ka)+betads(k))
+ if (p(i,j,k-1).gt.dpbl(i,j)) then
+ delth(k)=min(0.0,delth(k))
+ endif
+ if (k.eq.khy1) then
+ delth(k )=min(0.0,delth(k))
+ delth(k+1)= delth(k)
+ endif
+ enddo
+ endif
+c
+c --- calculate 1-d arrays on m-y vertical grid
+ if (.not.locsig) then
+ th1d(1)=th3d(i,j,1,m)
+ endif
+ ubav=0.5*(ubavg(i,j,m)+ubavg(i+1,j ,m))
+ vbav=0.5*(vbavg(i,j,m)+vbavg(i ,j+1,m))
+ u1d(1)=0.5*(u(i,j,1,m)+u(i+1,j ,1,m))+ubav
+ v1d(1)=0.5*(v(i,j,1,m)+v(i ,j+1,1,m))+vbav
+ do k=2,khy1
+ if (.not.locsig) then
+ th1d(k)=0.5*(th3d(i,j,k-1,m)+th3d(i,j,k,m))
+ endif
+ u1d(k)=0.25*(u(i ,j ,k-1,m)+u(i ,j ,k,m)
+ & +u(i+1,j ,k-1,m)+u(i+1,j ,k,m))+ubav
+ v1d(k)=0.25*(v(i ,j ,k-1,m)+v(i ,j ,k,m)
+ & +v(i ,j+1,k-1,m)+v(i ,j+1,k,m))+vbav
+ enddo
+ if (.not.locsig) then
+ th1d(kmy1)=th3d(i,j,khy1,m)
+ endif
+ u1d(kmy1)=0.5*(u(i,j,khy1,m)+u(i+1,j ,khy1,m))+ubav
+ v1d(kmy1)=0.5*(v(i,j,khy1,m)+v(i ,j+1,khy1,m))+vbav
+c
+c --- make sure background tke maintains minimum value
+ do k=0,kk+1
+ q2( i,j,k,m)=max(smll,q2( i,j,k,m))
+ q2l(i,j,k,m)=max(smll,q2l(i,j,k,m))
+ q2( i,j,k,n)=max(smll,q2( i,j,k,n))
+ q2l(i,j,k,n)=max(smll,q2l(i,j,k,n))
+ enddo
+c
+c --- calculate sm,sh coefficients
+ do k=2,kmy1
+ sm(k)=-delt1*0.5*(difqmy(i,j,k-1)+difqmy(i,j,k )+2.0*dflsiw)
+ & /(dzz(k-1)*dz(k )*dh*dh)
+ sh(k)=-delt1*0.5*(difqmy(i,j,k-2)+difqmy(i,j,k-1)+2.0*dflsiw)
+ & /(dzz(k-1)*dz(k-1)*dh*dh)
+ enddo
+c
+c ------------------------------------------------------------------
+c --- solve delt1*(difq*q2(n)')' - q2(n)*(2.*delt1*dtef+1.) = -q2(m)
+c --- for q2(n) (tke)
+c ------------------------------------------------------------------
+c
+c --- surface and bottom stress boundary conditions
+ if (windf) then
+ wusurf=thref*surtx(i,j)
+ wvsurf=thref*surty(i,j)
+ else
+ wusurf=0.0
+ wvsurf=0.0
+ endif
+ wubot=-0.5*thkbot*onem*u1d(kmy1)*drag(i,j)*thref/g
+ wvbot=-0.5*thkbot*onem*v1d(kmy1)*drag(i,j)*thref/g
+ ee(1)=0.0
+ gg(1)=const1*sqrt(wusurf*wusurf+wvsurf*wvsurf)
+ q2(i,j,kmy1,n)=const1*sqrt(wubot*wubot+wvbot*wvbot)
+c
+c --- calculate vertical buoyancy gradient at interfaces
+ dbloc(1)=0.0
+ do k=2,kmy1
+ ka=k-1
+ if (locsig) then
+ dbloc(k)=thref*g*delth(k)/(dzz(ka)*dh)
+ else
+ if (p(i,j,k-1).gt.dpbl(i,j)) then
+ dbloc(k)=thref*g*min(0.0,th1d(ka)-th1d(k))/(dzz(ka)*dh)
+ else
+ dbloc(k)=thref*g* ( th1d(ka)-th1d(k))/(dzz(ka)*dh)
+ endif
+ endif
+ enddo
+ dbloc(kmy2)=0.0
+c
+c --- calculate turbulent length scale and richardson number gh at interfaces
+c
+ turlen(1)=0.0
+ gh(1)=0.
+ do k=2,kmy1
+ turlen(k)=q2l(i,j,k-1,m)/q2(i,j,k-1,m)
+ gh(k)=min(0.028,turlen(k)**2/q2(i,j,k-1,m)*dbloc(k))
+ enddo
+ turlen(kmy2)=0.
+ gh(kmy2)=0.
+c
+c --- calculate tke production at interfaces
+ prod(1)=0.0
+ do k=2,kmy1
+ delu=u1d(k)-u1d(k-1)
+ delv=v1d(k)-v1d(k-1)
+ prod(k)=diftmy(i,j,k-1)*dbloc(k)+vctymy(i,j,k-1)*sef
+ & *(delu**2+delv**2)/(dzz(k-1)*dh)**2
+ enddo
+ prod(kmy2)=0.0
+c
+c --- solve the equation
+ do k=1,kmy2
+ stf(k)=1.0
+ if (gh(k).lt.0. ) stf(k)=1.0-0.9*(gh(k)/ghc)**1.5
+ if (gh(k).lt.ghc) stf(k)=0.1
+ dtef(k)=q2(i,j,k-1,m)**1.5/(b1my*q2l(i,j,k-1,m)+smll)*stf(k)
+ enddo
+ do k=2,kmy1
+ gg(k)=1.0/(sm(k)+sh(k)*(1.0-ee(k-1))-(2.0*delt1*dtef(k)+1.0))
+ ee(k)=sm(k)*gg(k)
+ gg(k)=(-2.0*delt1*prod(k)+sh(k)*gg(k-1)-q2(i,j,k-1,n))*gg(k)
+ enddo
+ do k=kmy1,1,-1
+ q2(i,j,k-1,n)=ee(k)*q2(i,j,k,n)+gg(k)
+ enddo
+c
+c ------------------------------------------------------------------
+c --- solve delt1*(difq*q2l(n)')' - q2l(n)*(delt1*dtef+1.) = -q2l(m)
+c --- for q2l(n) (tke times turbulent length scale)
+c ------------------------------------------------------------------
+c
+ !min(1,kkmy25+1) always 1 if this routine is called
+ q2(i,j,min(1,kkmy25+1),n)=max(smll,q2(i,j,min(1,kkmy25+1),n))
+ ee(2)=0.0
+ gg(2)=-vonk*z(2)*dh*q2(i,j,min(1,kkmy25+1),n)
+ q2l(i,j,kmy1,n)=0.0
+ do k=3,kmy1
+ dtef(k)=dtef(k)*(1.+e2my*((1.0/abs(z(k)-z(1))+
+ & 1.0/abs(z(k)-z(kmy2)))*turlen(k)/(dh*vonk))**2)
+ gg(k)=1.0/(sm(k)+sh(k)*(1.0-ee(k-1))-(delt1*dtef(k)+1.0))
+ ee(k)=sm(k)*gg(k)
+ gg(k)=(delt1*(-prod(k)*turlen(k)*e1my)+sh(k)*gg(k-1)
+ & -q2l(i,j,k-1,n))*gg(k)
+ enddo
+ do k=kmy1,2,-1
+ q2l(i,j,k-1,n)=ee(k)*q2l(i,j,k,n)+gg(k)
+ enddo
+ do k=0,kmy1
+ if (q2(i,j,k,n).lt.smll .or. q2l(i,j,k,n).lt.smll) then
+ q2 (i,j,k,n)=smll
+ q2l(i,j,k,n)=smll
+ endif
+ enddo
+c
+c ----------------------------------------------------
+c --- calculate the viscosity and diffusivity profiles
+c ----------------------------------------------------
+c
+c --- note that sm and sh limit to infinity when gh approaches 0.0288
+ do k=1,kmy2
+ coef1=a2my*(1.0-6.0*a1my/b1my*stf(k))
+ coef2=3.0*a2my*b2my/stf(k)+18.0*a1my*a2my
+ coef3=a1my*(1.0-3.0*c1my-6.0*a1my/b1my*stf(k))
+ sh(k)=coef1/(1.0-coef2*gh(k))
+ sm(k)=coef3+sh(k)*coef4*gh(k)
+ sm(k)=sm(k)/(1.0-coef5*gh(k))
+ akn=turlen(k)*sqrt(abs(q2(i,j,k-1,n)))
+ difqmy(i,j,k-1)=max(dflsiw,(akn*0.41*sh(k)+difqmy(i,j,k-1))*0.5)
+ vctymy(i,j,k-1)=max(dflmiw,(akn* sm(k)+vctymy(i,j,k-1))*0.5)
+ diftmy(i,j,k-1)=max(dflsiw,(akn* sh(k)+diftmy(i,j,k-1))*0.5)
+ enddo
+c
+c --- set diffusivity/viscosty on hycom interfaces
+ vcty(i,j,1)=0.0
+ dift(i,j,1)=0.0
+ difs(i,j,1)=0.0
+ do k=2,khy1
+ vcty(i,j,k)=min(0.5*(vctymy(i,j,k-1)+vctymy(i,j,k)),difmax)
+ dift(i,j,k)=min(0.5*(diftmy(i,j,k-1)+diftmy(i,j,k)),difmax)
+ difs(i,j,k)=dift(i,j,k)
+ enddo
+c
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+c
+c --- set new time pressure array
+c --- locate lowest substantial mass-containing layer.
+ pij(1)=p(i,j,1)
+ do k=1,kk
+ dpmm( k) =max(onemm,dp(i,j,k,n))
+ qdpmm(k) =1.0/dpmm(k)
+ pij( k+1)=pij(k)+dp(i,j,k,n)
+ p(i,j,k+1)=pij(k+1)
+ enddo
+ do k=kk,1,-1
+ if (dpmm(k).gt.tencm) then
+ exit
+ endif
+ enddo
+ klist(i,j)=min(klist(i,j), !minimum of m and n levels
+ & max(k,2) ) !always consider at least 2 layers
+c
+ khy1=klist(i,j)
+ khy2=klist(i,j)+1
+c
+ do k=khy2,kk+1
+ vcty(i,j,k)=dflmiw
+ difs(i,j,k)=dflsiw
+ dift(i,j,k)=dflsiw
+ enddo
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,101) (nstep,i+i0,j+j0,k,pij(k)*qonem,
+cdiag& 1.e4*vcty(i,j,k),1.e4*dift(i,j,k),1.e4*difs(i,j,k),
+cdiag& 1.e4*difqmy(i,j,k-1),k=1,khy2)
+cdiag call flush(lp)
+cdiag endif
+c
+c --- calculate zgrid
+ zgrid(i,j,1)=-0.5*dpmm(1)*qonem
+ do k=2,khy1
+ zgrid(i,j,k)=zgrid(i,j,k-1)-0.5*(dpmm(k-1)+dpmm(k))*qonem
+ enddo
+ zgrid(i,j,khy2)=-pij(khy2)*qonem
+c
+c --- forcing of t,s by surface fluxes. flux positive into ocean.
+c --- shortwave flux penetration depends on kpar or jerlov water type.
+c
+ if (jerlv0.eq.0) then
+ beta_r = qonem*2.0
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ beta_b = max( betabl(1), beta_b) !time interp. beta_b can be -ve
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ frac_r = 1.0 - frac_b
+ else
+ jrlv = jerlov(i,j)
+ beta_r = betard(jrlv)
+ beta_b = betabl(jrlv)
+ frac_r = redfac(jrlv)
+ frac_b = 1.0 - frac_r
+ endif
+ qspcifh=1.0/spcifh
+c
+c --- evenly re-distribute the flux below the bottom
+ k = klist(i,j)
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfbqp=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfbqp=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfbqp=0.0
+ endif
+ swfbqp = swfbqp/pij(k+1)
+c
+ do k=1,khy1
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfrac(k+1)=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfrac(k+1)=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfrac(k+1)=0.0
+ endif
+ swfrac(k+1)=swfrac(k+1)-swfbqp*pij(k+1) !spread out bottom frac
+ if (k.eq.1) then
+ sflux1=surflx(i,j)-sswflx(i,j)
+ dtemp=(sflux1+(1.-swfrac(k+1))*sswflx(i,j))*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=salflx(i,j)*
+ & delt1*g* qdpmm(k)
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,102) nstep,i+i0,j+j0,k,
+cdiag& 0.,1.-swfrac(k+1),dtemp,dsaln
+cdiag call flush(lp)
+cdiag endif
+ else
+ dtemp=(swfrac(k)-swfrac(k+1))*sswflx(i,j)*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=0.
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,102) nstep,i+i0,j+j0,k,
+cdiag& 1.-swfrac(k),1.-swfrac(k+1),dtemp
+cdiag call flush(lp)
+cdiag endif
+ endif
+ else !.not.thermo ...
+ dtemp=0.0
+ dsaln=0.0
+ endif !thermo.or.sstflg.gt.0.or.srelax:else
+ temp(i,j,k,n)=temp(i,j,k,n)+dtemp
+ saln(i,j,k,n)=saln(i,j,k,n)+dsaln
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ enddo !k
+c
+c --- calculate swfrml, the fraction of solar radiation left at depth dpbl(i,j)
+ if (-dpbl(i,j)*beta_r.gt.-10.0) then
+ swfrml=frac_r*exp(-dpbl(i,j)*beta_r)+
+ & frac_b*exp(-dpbl(i,j)*beta_b)
+ elseif (-dpbl(i,j)*beta_b.gt.-10.0) then
+ swfrml=frac_b*exp(-dpbl(i,j)*beta_b)
+ else
+ swfrml=0.0
+ endif
+ swfrml=swfrml-swfbqp*dpbl(i,j) !spread out bottom frac
+c
+c --- buoyfl = total buoyancy flux (m**2/sec**3) into atmos.
+c --- buoysw = shortwave radiation buoyancy flux (m**2/sec**3) into atmos.
+ dsgdt= dsigdt(tmn,smn)
+ buoyfs=g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref)
+ buoyfl=buoyfs+
+ & g*thref*(dsgdt *surflx(i,j)*thref/spcifh)
+ buoysw=g*thref*(dsgdt *sswflx(i,j)*thref/spcifh)
+ buoflx(i,j)=buoyfl -swfrml*buoysw !mixed layer buoyancy
+ mixflx(i,j)=surflx(i,j)-swfrml*sswflx(i,j) !mixed layer heat flux
+ bhtflx(i,j)=buoflx(i,j)-buoyfs !buoyancy from heat flux
+c
+ 101 format(25x,' thick viscty t diff s diff q diff '
+ & /(i9,2i5,i3,2x,5f10.2))
+ 102 format(i9,2i5,i3,'absorbup,dn,dtemp,dsaln ',2f6.3,2f10.6)
+c
+ return
+ end
+c
+ subroutine mxgissaij(m,n, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, i,j
+c--------------------------------------------------------------------
+c --- nasa giss vertical mixing model, single j-row (part A)
+c
+c --- V.M. Canuto, A. Howard, Y. Cheng, and M.S. Dubovikov, 2001:
+c --- Ocean turbulence, part I: One-point closure model -- momentum
+c --- and heat vertical diffusivities. JPO, 31, 1413-1426.
+c --- V.M. Canuto, A. Howard, Y. Cheng, and M.S. Dubovikov, 2002:
+c --- Ocean turbulence, part II: Vertical diffusivities of momentum,
+c --- heat, salt, and passive tracers. JPO, 32, 240-264.
+c
+c --- Modified by Armando Howard to implement the latitude dependent
+c --- background mixing due to waves formula from:
+c --- Gregg et. al. (2003): Reduced mixing from the breaking of
+c --- internal waves in equatorial waters, Nature 422 pp 513-515.
+c--------------------------------------------------------------------
+c
+c 1D turbulence calculation routine adapted by A.Romanou from A.Howard
+c from the 2000 original model.
+c
+c For a discussion of the turbulence model used here see "Ocean
+c Turbulence. Part II" referenced above.
+c
+c In general ria(k),rid(k) are calculated from the difference between
+c level k and k+1 and ak{m,h,s}(k) should be used to mix levels k and k+1.
+c n is (nlayers-1) because there are nlayers-1 ocean interfaces to
+c be mixed.
+c
+c In the mixed layer the model diffusivity for each field is a product of
+c a dimensionless function of the two variables ria and rid
+c and the Shear and the square of a lengthscale.
+c The lengthscale is proportional to depth near the surface but asymptotes
+c towards a fixed fraction of the Mixed Layer Depth deeper in the mixed
+c layer. The MLD is thus a necessary ingredient for calculating model
+c diffusivities.
+c
+c latitude dependent background mixing ("latdiw") option:
+c background mixing depends on |f| and N,
+c where f is the coriolis parameter and N brunt vaisala frequency.
+c note Gregg et al. use "f" when they mean the absolute value of
+c the coriolis parameter.
+c latitude dependent deep background mixing ("botdiw") option:
+c additional factor multiplying the `epsilon/N^2' for deep mixing
+c based on the formula cited as from Henyey et. al,
+c JGR vol.91 8487-8495,1986) in Gregg et al. where it is shown
+c confirmed by observations for lower latitudes except for being
+c low very near the equator.
+c I place a minimum, "eplatidepmin", on the Gregg et al. factor, "L".
+c Note that Gregg et. al.'s formula:
+c L(\theta,N) =
+c (|f| cosh^{-1} (N/|f|))/(f_30^o cosh^{-1} (N_0/f_30^o)
+c is only defined as a real number when N > |f|, since arccosh
+c can only be defined as a real for arguments of at least 1.
+c At 1 arccosh is zero.
+c I decide to set "L(\theta,N)" to "eplatidepmin"FOR (N/f < 1).
+c This corresponds to setting a floor of 1 on (N/f).
+c for foreground mixing at depth detached from the mixed-layer
+c I revert to the "deep" lengthscale, which uses density gradients,
+c in case (N/f)<1 to try not to make deep arctic&subarctic mixing
+c too small.
+c
+c-----------------------------------------------------------------------------
+c --- this is a level 2 turbulence model
+c --- sm and sh depends only on the richardson number
+c --- In salinity model case level 2 means S_M,S_H,S_C depend only on Ria,Ri_d
+c-----------------------------------------------------------------------------
+c
+ real, parameter :: difmax = 9999.0e-4 !maximum diffusion/viscosity
+ real, parameter :: acormin= 2.5453e-6 !minimum abs(corio), i.e. 1 degN
+c
+c --- local variables for giss mixing
+c
+ real z1d(kdm),th1d(kdm),u1d(kdm),v1d(kdm)
+ real ria(kdm),rid(kdm),s2(kdm),v_back(kdm),
+ & t_back(kdm),s_back(kdm),dtemp,dsaln,sflux1,
+ & alfadt,betads,al0,ri1,rid1,slq2,sm,sh,ss,akz,al,al2,anlq2,
+ & back_ri1,back_rid1,back_ra_r1,back_rit1,back_ric1,rit,ric,
+ & ra_r,theta_r,theta_r0,theta_r1,theta_r_deg,deltheta_r1,
+ & delback_ra_r,dback_ra_r_o_dtheta,slq2_back,sm_back,sh_back,
+ & ss_back,delsm_back,dsm_back_o_dtheta,delsh_back,
+ & dsh_back_o_dtheta,delss_back,dss_back_o_dtheta,delslq2_back,
+ & dslq2_back_o_dtheta,s2_back,al0_back,al_back,
+ & al2_back,anlq2_back,tmp_back,tmp,delz,delth,del2th,
+ & dzth,d2zth,rdzlndzth,al0deep,thsum,dens,
+ & beta_b,beta_r,frac_b,frac_r,qspcifh,hbl,swfbqp,
+ & epson2,epson2_bot,eplatidep,gatmbs,gatpbs
+ real akm(kdm),akh(kdm),aks(kdm),aldeep(kdm),tmpk(kdm)
+ real an2(kdm),an,acorio,zbot
+c
+ real swfrac(kdm+1) ! fractional surface shortwave radiation flux
+ real swfrml ! fractional surface sw rad flux at ml base
+ real hwide(kdm) ! layer thicknesses in m (minimum 1mm)
+ real dpmm(kdm) ! max(onemm,dp(i,j,:,n))
+ real qdpmm(kdm) ! 1.0/max(onemm,dp(i,j,:,n))
+ real pij(kdm+1) ! local copy of p(i,j,:)
+c
+ real buoyfl,buoyfs,buoysw,dsgdt,smn,tmn
+c
+ integer ifbelow,ifrafglt,jtheta_r
+ integer ifnofsmall
+c
+ integer jtheta_r0,jtheta_r1,itheta_r0,itheta_r1
+ common/mxgissij_b/ jtheta_r0,jtheta_r1,itheta_r0,itheta_r1
+ save /mxgissij_b/ !bugfix, reduces optimization of *theta_r*
+c
+ integer k,k1,jrlv
+c
+ integer iglobal,jglobal
+c
+ real acosh1,xx
+ include 'stmt_fns.h'
+ acosh1(xx) = log(xx+sqrt((xx**2)-1.0))
+c
+ iglobal=i0+i !for debugging
+ jglobal=j0+j !for debugging
+ if (iglobal+jglobal.eq.-99) then
+ write(lp,*) iglobal,jglobal !prevent optimization
+ endif
+c
+c --- set mid-time pressure array
+c --- locate lowest substantial mass-containing layer.
+ dpmm( 1)=max(onemm,dp(i,j,1,n))
+ qdpmm(1)=1.0/dpmm(1)
+ pij( 1)=p(i,j,1)
+ pij( 2)=pij(1)+dp(i,j,1,n)
+ p(i,j,2)=pij(2)
+ do k=2,kk
+ dpmm( k) =max(onemm,dp(i,j,k,n))
+ qdpmm(k) =1.0/dpmm(k)
+ pij( k+1)=pij(k)+dp(i,j,k,n)
+ p(i,j,k+1)=pij(k+1)
+ enddo
+ do k=kk,1,-1
+ if (dpmm(k).gt.tencm) then
+ exit
+ endif
+ enddo
+ klist(i,j)=max(k,2) !always consider at least 2 layers
+c
+c --- nominal surface bld is the mld, note that this depends on tmljmp
+ dpbl(i,j)=min(dpbl(i,j),pij(kk+1))
+ hbl=dpbl(i,j)
+c
+c --- forcing of t,s by surface fluxes. flux positive into ocean.
+c --- shortwave flux penetration depends on kpar or jerlov water type.
+c
+ if (jerlv0.eq.0) then
+ beta_r = qonem*2.0
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ beta_b = max( betabl(1), beta_b) !time interp. beta_b can be -ve
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ frac_r = 1.0 - frac_b
+ else
+ jrlv = jerlov(i,j)
+ beta_r = betard(jrlv)
+ beta_b = betabl(jrlv)
+ frac_r = redfac(jrlv)
+ frac_b = 1.0 - frac_r
+ endif
+ qspcifh=1.0/spcifh
+c
+c --- evenly re-distribute the flux below the bottom
+ k = klist(i,j)
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfbqp=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfbqp=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfbqp=0.0
+ endif
+ swfbqp = swfbqp/pij(k+1)
+c
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+c
+ do k=1,kk
+ k1=k+1
+c
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+ if (-pij(k+1)*beta_r.gt.-10.0) then
+ swfrac(k+1)=frac_r*exp(-pij(k+1)*beta_r)+
+ & frac_b*exp(-pij(k+1)*beta_b)
+ elseif (-pij(k+1)*beta_b.gt.-10.0) then
+ swfrac(k+1)=frac_b*exp(-pij(k+1)*beta_b)
+ else
+ swfrac(k+1)=0.0
+ endif
+ swfrac(k+1)=swfrac(k+1)-swfbqp*pij(k+1) !spread out bottom frac
+ if (k.eq.1) then
+ sflux1=surflx(i,j)-sswflx(i,j)
+ dtemp=(sflux1+(1.-swfrac(k+1))*sswflx(i,j))*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=salflx(i,j)*
+ & delt1*g* qdpmm(k)
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,101) nstep,i+i0,j+j0,k,
+cdiag& 0.,1.-swfrac(k+1),dtemp,dsaln
+cdiag call flush(lp)
+cdiag endif
+ elseif (k.le.klist(i,j)) then
+ dtemp=(swfrac(k)-swfrac(k+1))*sswflx(i,j)*
+ & delt1*g*qspcifh*qdpmm(k)
+ dsaln=0.0
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,101) nstep,i+i0,j+j0,k,
+cdiag& 1.-swfrac(k),1.-swfrac(k+1),dtemp
+cdiag call flush(lp)
+cdiag endif
+ else !k.gt.klist(i,j)
+ dtemp=0.0
+ dsaln=0.0
+ endif
+ else !.not.thermo ...
+ dtemp=0.0
+ dsaln=0.0
+ endif !thermo.or.sstflg.gt.0.or.srelax:else
+c
+c --- modify t and s
+ temp(i,j,k,n)=temp(i,j,k,n)+dtemp
+ saln(i,j,k,n)=saln(i,j,k,n)+dsaln
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+c
+ enddo !k
+c
+c --- calculate swfrml, the fraction of solar radiation left at depth hbl
+ if (-hbl*beta_r.gt.-10.0) then
+ swfrml=frac_r*exp(-hbl*beta_r)+
+ & frac_b*exp(-hbl*beta_b)
+ elseif (-hbl*beta_b.gt.-10.0) then
+ swfrml=frac_b*exp(-hbl*beta_b)
+ else
+ swfrml=0.0
+ endif
+ swfrml=swfrml-swfbqp*hbl !spread out bottom frac
+c
+c --- buoyfl = total buoyancy flux (m**2/sec**3) into atmos.
+c --- buoysw = shortwave radiation buoyancy flux (m**2/sec**3) into atmos.
+ dsgdt= dsigdt(tmn,smn)
+ buoyfs=g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref)
+ buoyfl=buoyfs+
+ & g*thref*(dsgdt *surflx(i,j)*thref/spcifh)
+ buoysw=g*thref*(dsgdt *sswflx(i,j)*thref/spcifh)
+ buoflx(i,j)=buoyfl -swfrml*buoysw !mixed layer buoyancy
+ mixflx(i,j)=surflx(i,j)-swfrml*sswflx(i,j) !mixed layer heat flux
+ bhtflx(i,j)=buoflx(i,j)-buoyfs !buoyancy from heat flux
+c
+c --- calculate z at vertical grid levels - this array is the z values in m
+c --- at the mid-depth of each model layer except for index klist+1, where it
+c --- is the z value of the bottom
+c
+c --- calculate layer thicknesses
+ do k=1,kk
+ if (k.eq.1) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=-.5*hwide(k)
+ else if (k.lt.klist(i,j)) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=zgrid(i,j,k-1)-.5*(hwide(k-1)+hwide(k))
+ else if (k.eq.klist(i,j)) then
+ hwide(k)=dpmm(k)*qonem
+ zgrid(i,j,k)=zgrid(i,j,k-1)-.5*(hwide(k-1)+hwide(k))
+ zgrid(i,j,k+1)=zgrid(i,j,k)-.5*hwide(k)
+ else
+ hwide(k)=0.
+ endif
+c
+c --- set 1-d array values; use cgs units
+ if (k.le.klist(i,j)) then
+ z1d (k)=-100.0*zgrid(i,j,k)
+ u1d (k)=50.0*(u(i,j,k,n)+u(i+1,j ,k,n))
+ v1d (k)=50.0*(v(i,j,k,n)+v(i ,j+1,k,n))
+ if (k.eq.1) then
+ thsum=0.001*th3d(i,j,k,n)
+ th1d(k)=thsum !offset by 1+0.001*thbase
+ else
+ k1=k-1
+ delz=z1d(k)-z1d(k1) !50.0*(hwide(k)+hwide(k1))
+ s2 (k1)=((u1d(k1)-u1d(k))**2+(v1d(k1)-v1d(k))**2)/
+ & (delz*delz)
+ if (locsig) then
+ alfadt=0.0005*
+ & (dsiglocdt(temp(i,j,k1,n),saln(i,j,k1,n),p(i,j,k))+
+ & dsiglocdt(temp(i,j,k ,n),saln(i,j,k ,n),p(i,j,k)))*
+ & (temp(i,j,k1,n)-temp(i,j,k,n))
+ betads=0.0005*
+ & (dsiglocds(temp(i,j,k1,n),saln(i,j,k1,n),p(i,j,k))+
+ & dsiglocds(temp(i,j,k ,n),saln(i,j,k ,n),p(i,j,k)))*
+ & (saln(i,j,k1,n)-saln(i,j,k,n))
+ thsum=thsum-alfadt-betads
+ th1d(k)=thsum !offset by 1+0.001*thbase
+ else
+ alfadt=0.0005*
+ & (dsigdt(temp(i,j,k1,n),saln(i,j,k1,n))+
+ & dsigdt(temp(i,j,k ,n),saln(i,j,k ,n)))*
+ & (temp(i,j,k1,n)-temp(i,j,k,n))
+ betads=0.0005*
+ & (dsigds(temp(i,j,k1,n),saln(i,j,k1,n))+
+ & dsigds(temp(i,j,k ,n),saln(i,j,k ,n)))*
+ & (saln(i,j,k1,n)-saln(i,j,k,n))
+ th1d(k)=0.001*th3d(i,j,k,n) !offset by 1+0.001*thbase
+ endif
+ dens=1.0+0.001*(th3d(i,j,k,n)+thbase)
+ gatpbs=-980.0*(alfadt+betads)
+ gatmbs=-980.0*(alfadt-betads)
+ if (gatpbs.ne.gatmbs) then !usual case
+ an2(k1)=gatpbs/(delz*dens)
+ ria(k1)=gatpbs/(delz*dens*max(epsil,s2(k1)))
+ rid(k1)=gatmbs/(delz*dens*max(epsil,s2(k1)))
+ else !must have ria(k1)==rid(k1)
+ an2(k1)=gatpbs/(delz*dens)
+ ria(k1)=gatpbs/(delz*dens*max(epsil,s2(k1)))
+ rid(k1)=ria(k1)
+ endif
+ endif
+ endif
+ enddo
+ k=klist(i,j)
+ s2 (k)=0.0
+ ria(k)=0.0
+ rid(k)=0.0
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag do k=1,klist(i,j)
+cdiag write(6,'(a,i9,i3,2f10.3,f9.1,f8.5,2f8.2)') 'giss1din1',
+cdiag& nstep,k,zgrid(i,j,k),hwide(k),z1d(k),
+cdiag& th1d(k),u1d(k),v1d(k)
+cdiag enddo
+cdiag write(6,'(a,a9,a3,3a13)')
+cdiag& 'giss1din2',' nstep',' k',
+cdiag& ' s2',' ria',' rid'
+cdiag do k=1,klist(i,j)
+cdiag write(6,'(a,i9,i3,1p,3e13.5)') 'giss1din2',
+cdiag& nstep,k,s2(k),ria(k),rid(k)
+cdiag enddo
+cdiag endif
+c
+ al0=0.17*hbl/onecm
+c
+c --- Write internal turbulence quantities to fort.91 when writing enabled.
+c --- Headers for each outputstep.
+c --- Add S_M,H,S to outputs.
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,'(a,i9)') 'nstep = ',nstep
+cdiag write(lp,*) 'hbl,al0 = ',hbl/onecm,al0
+cdiag write(lp,*) 'b1 = ',b1
+cdiag write(lp,'(a)') " z al slq2 "//
+cdiag& "ri1 rid1 "//
+cdiag& "sm sh ss "//
+cdiag& "v_back t_back s_back "
+cdiag endif
+c
+ if (latdiw) then
+ acorio = max(acormin, !f(1degN)
+ & 0.25*(abs(corio(i,j ))+abs(corio(i+1,j ))+
+ & abs(corio(i,j+1))+abs(corio(i+1,j+1)) ))
+ endif !latdiw
+ if (botdiw) then
+ zbot = -100.0*zgrid(i,j,klist(i,j)+1) !sea depth
+ endif !botdiw
+c
+c --- START OF FIRST LOOP THROUGH LEVELS
+c
+ if (ifepson2.eq.2) then
+c --- Initialize switch for sub(background-only) depth.
+ ifbelow=0
+ endif
+c
+c --- depth-grid dooloop starts here
+ do 22 k=1,klist(i,j)-1
+ ri1=ria(k)
+c
+c --- Use Ri_d = Ri_C - Ri_T in salinity-temperature turbulence model.
+ rid1=rid(k)
+c
+c --- Interpolate 2D table for salinity-temperature model case.
+ call interp2d_expabs(ri1,rid1,slq2,sm,sh,ss,mt,mt0,dri,rri)
+c
+c --- Check that "slq2" has been set to 0 where it might have been negative.
+ if (slq2.lt.0.) then
+ write(lp,*) "************************************************"
+ write(lp,*) "Error detected in turbulence module."
+ write(lp,*) "'slq2' negative in turb_2 subroutine"
+ & //" after interpolation."
+ write(lp,*) "k=",k," slq2=",slq2
+ write(lp,*) "sm=",sm," sh=",sh," ss=",ss
+ write(lp,*) "ri1=",ri1," rid1=",rid1
+ write(lp,*) "dri=",dri
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+c
+c
+c --- Assume region contiguous with surface where foreground model is
+c --- realizable has ended when get 0 "slq2".
+ if (slq2.eq.0.) then
+ ifbelow = 1
+ endif
+c
+ akz=0.4*z1d(k)
+ al=akz*al0/(al0+akz)
+ al2=al*al
+c
+c --- Do not use Deardorff limitation when use (\epsilon/N^2) dimensionalization.
+ if (.NOT.((ifepson2.EQ.2).AND.(ifbelow.EQ.1))) then
+c --- length scale reduction by buoyancy
+ if(ri1.gt.0.) then
+ anlq2=slq2*ri1
+ if(anlq2.gt.0.281) then !0.281=0.53**2
+ al2=0.281/anlq2*al2
+ slq2=0.281/(ri1+1.E-20)
+ endif
+ endif
+ endif !length scale reduction by buoyancy
+c
+ if (.not.latdiw) then
+c --- use constant epson2 from inigiss.
+ epson2 = epson2_ref
+ else
+c
+c --- latitude dependent internal wave diffusion/viscosity
+c --- Gregg et. al. (2003): Reduced mixing from the breaking of
+c --- internal waves in equatorial waters, Nature 422 pp 513-515.
+c
+ if (an2(k).le.0.0) then
+ eplatidep = eplatidepmin
+ else
+ an = SQRT(an2(k)) !N from N^2
+ if (an/acorio.lt.1.0) then !arccosh(N/|f|) undefined
+ eplatidep = eplatidepmin
+ else
+ eplatidep = (acorio*acosh1(an/acorio))/wave_30
+ eplatidep = max(eplatidep,eplatidepmin)
+ endif
+ endif
+ epson2 = epson2_ref*eplatidep
+c
+ if (botdiw .and. an2(k).gt.epsil) then
+c --- enhanced bottom mixing
+ epson2_bot = eps_bot0/an2(k) * exp((z1d(k) - zbot)/scale_bot)
+ epson2 = max(epson2,epson2_bot)
+ endif !botdiw
+ endif !latdiw
+c
+c------------------------------------------------------------------------
+c
+c --- BEGIN SECTION .or.SALINITY MODEL BACKGROUND DIFFUSIVITY CALCULATION.
+ if (ifsali.gt.0) then
+c
+ if (ifsalback.ge.4) then
+c --- Change ALL THREE BACKGROUND DIFFUSIVITIES from input values to
+c --- diffusivities calculated using the turbulence model
+c --- with Ri and l_0 replaced by constants 'ri_internal' and 'back_l_0'
+c --- and S^2 replaced by (N^2 / Ri_internal) for N^2>=0 and 0 for N^2 <0
+c --- to represent a modified Dubovikov internal wave generated turbulence
+c --- with constant Richardson number for ifsalback=4 case.
+c
+c --- Use a constant background Ri estimate.
+ if (ifsalback.EQ.4) then
+ back_rit1 = 0.
+ back_ric1 = 0.
+ back_ri1 = ri_internal
+ back_rid1 = (rid1/ri1)*ri_internal
+ else
+c
+c --- Change ALL THREE BACKGROUND DIFFUSIVITIES from input values to
+c --- diffusivities calculated using the turbulence model
+c --- with l_0 replaced by a constant 'back_l_0' and
+c --- Ri by a function of Ri_d
+c --- and S^2 replaced by (N^2 / Ri_internal) for N^2>=0 and 0 for N^2 <0
+c --- to represent a modified Dubovikov internal wave generated turbulence
+c --- with stability-ratio dependent Richardson number for ifsalback>4 case.
+c
+c --- When Ri_T = 0 and Ri_C \ne 0,
+c --- correctly set the angle 'theta_r' in the (Ri_T,Ri_C) plane to 'pi'/2 .
+c
+c --- Skip background ra_r calculation in unstable .or.NEUTRAL* case.
+c --- Set background ra_r arbitrarily to zero in these cases.
+ if (ria(k).le.0.) then
+ back_ra_r1 = 0.
+ back_rit1 = 0.
+ back_ric1 = 0.
+ back_ri1 = 0.
+ back_rid1 = 0.
+ go to 19
+ endif
+c
+c --- Linearly interpolate back_ra_r array to this angle in (Ri_C,Ri_T) space.
+c --- Ri \equiv Ri_T + Ri_C ; Ri_d \equiv Ri_T - Ri_C .
+ rit = (ria(k) + rid(k))/2.
+ ric = (ria(k) - rid(k))/2.
+ ra_r = sqrt((rit**2) + (ric**2))
+c
+c --- use newer better treatment of zero thermal gradient case.
+c --- find \theta_r for the Ri_T = 0 case. Treat "0/0 = 1".
+ if(rit.eq.0.0) then
+ if(ric.eq.0.0) then
+ theta_r = atan(1.0)
+ else
+ theta_r = pi/2.0 ! Arctangent of infinity.
+ endif
+ else
+ theta_r = atan(ric/rit)
+ endif
+c
+c --- Make sure the right choice of arctan(Ri_C/Ri_T) [\theta_r] is made.
+c --- Arctan only covers the range (-pi/2,pi/2) which theta_r may be outside.
+c --- Want to consider statically stable case only: Ri > 0.
+ if (abs(theta_r).gt.(pi/2.)) then
+ write(lp,*)
+ & "************************************************"
+ write(lp,*) "Error detected in turbulence module."
+ write(lp,*) "theta_r (=",abs(theta_r),") too large"
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+ if (theta_r.lt.(-pi)/4.) then
+ theta_r = theta_r + pi
+ endif
+c
+c --- MAKE 'jtheta' A NON-NEGATIVE INDEX - ZERO AT THETA = -PI/4 .
+c --- The fortran function "INT" rounds to the integer *NEAREST TO ZERO*
+c --- **I.E. ROUNDS **UP** .or.NEGATIVE NUMBERS**, DOWN ONLY .or.POSITIVES.
+ jtheta_r0 = INT((theta_r + (pi/4.))/deltheta_r)
+ jtheta_r1 = jtheta_r0+1
+c
+c --- INTRODUCE 'itheta' HERE .or.THE INDEX THAT IS ZERO AT THETA=0.
+ itheta_r0 = jtheta_r0 - n_theta_r_oct
+ itheta_r1 = itheta_r0+1
+c
+c --- ***WHEN THE ANGLE IS BETWEEN THE ANGLE .or.REALIZABILITY AT INFINITY***
+c --- ***AND THE LAST TABLE ANGLE BE.or. THAT CRITICAL ANGLE, ***
+c --- ***SET IT TO THE LAST TABLE ANGLE BE.or. THE CRITICAL ANGLE.****
+ theta_r0 = itheta_r0*deltheta_r
+ theta_r1 = itheta_r1*deltheta_r
+c
+ if ((theta_r0.le.theta_rcrp).AND.
+ & (theta_r .gt.theta_rcrp) ) then
+ theta_r = theta_r1
+ theta_r0 = theta_r1
+ itheta_r0 = itheta_r1
+ itheta_r1 = itheta_r1+1
+ theta_r1 = theta_r1 + deltheta_r
+ elseif ((theta_r1.ge.theta_rcrn).AND.
+ & (theta_r .lt.theta_rcrn) ) then
+ theta_r = theta_r0
+ theta_r1 = theta_r0
+ itheta_r1 = itheta_r0
+ itheta_r0 = itheta_r0-1
+ theta_r0 = theta_r0 - deltheta_r
+ endif
+c
+c --- Angle in degrees.
+ theta_r_deg = theta_r*180./pi
+c
+c --- Sound the alarm if have unrealizability outside expected range in angle.
+ if ((itheta_r1.gt.3*n_theta_r_oct).or.
+ & (itheta_r0.lt. -n_theta_r_oct) ) then
+ write(lp,*)
+ & "************************************************"
+ write(lp,*) "Problem in turbulence module!"
+ write(lp,*) "Unrealizability outside Ri>0 region. "
+ write(lp,*) "slq2=",slq2," sm=",sm," sh=",sh," ss=",ss
+ write(lp,*) "k=",k," ria(k)=",ria(k)," rid(k)=",rid(k)
+ write(lp,*) "rit=",rit,"ric=",ric," theta_r=",theta_r
+ write(lp,*) "theta_r_deg =",theta_r_deg
+ write(lp,*) "itheta_r0=",itheta_r0," itheta_r1=",itheta_r1
+ write(lp,*) "n_theta_r_oct=",n_theta_r_oct
+ write(lp,*) " "
+ write(lp,*) "i,j=",i+i0,j+j0
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+c
+ deltheta_r1 = theta_r - theta_r0
+ delback_ra_r = back_ra_r(itheta_r1) - back_ra_r(itheta_r0)
+ dback_ra_r_o_dtheta = delback_ra_r/deltheta_r
+ back_ra_r1 = back_ra_r(itheta_r0) +
+ & deltheta_r1*dback_ra_r_o_dtheta
+c
+c --- In case choose ifrafgmax=1, ra_r is at maximum the ForeGround ra_r
+c --- at the "strong" double diffusive \theta_r's
+c --- where have turbulence as Ri+> infinity.
+ ifrafglt=0
+ if (ifrafgmax.EQ.1) then
+ if ((theta_r.le.theta_rcrp).or.(theta_r.ge.theta_rcrn)) then
+ if (back_ra_r1.gt.ra_r) then
+ ifrafglt=1
+ back_ra_r1=ra_r
+ endif
+ endif
+ endif
+c
+ if (back_ra_r1.lt.0.) then
+ write(lp,*)
+ & "************************************************"
+ write(lp,*) "Problem in turbulence module!"
+ write(lp,*) "Negative bg ra_r \\equiv (Ri_T^2+Ri_C^2)^(1/2)"
+ write(lp,*) "back_ra_r1 =", back_ra_r1
+ write(lp,*) "theta_r =", theta_r
+ write(lp,*) " "
+ write(lp,*) "slq2=",slq2," sm=",sm," sh=",sh," ss=",ss
+ write(lp,*) "k=",k," ria(k)=",ria(k)," rid(k)=",rid(k)
+ write(lp,*) "rit=",rit,"ric=",ric
+ write(lp,*) "itheta_r0=",itheta_r0," itheta_r1=",itheta_r1
+ write(lp,*) "jtheta_r0=",jtheta_r0," jtheta_r1=",jtheta_r1
+ write(lp,*) "theta_r_deg =",theta_r_deg
+ write(lp,*) "n_theta_r_oct=",n_theta_r_oct
+ write(lp,*) " "
+ write(lp,*) "i,j=",i+i0,j+j0
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+c
+c --- Calculate the background Ri and Ri_d .
+ back_rit1 = cos(theta_r)*back_ra_r1
+ back_ric1 = sin(theta_r)*back_ra_r1
+ back_ri1 = back_rit1 + back_ric1
+ back_rid1 = back_rit1 - back_ric1
+c
+ endif !ifsalback.EQ.4:else
+c
+c --- CALCULATE THE BACKGROUND DIMENSIONLESS TURBULENCE FUNCTIONS
+c --- USING TABLE OF VALUES .or.BACKGROUND "\theta_r"'S
+c --- .or."ifbg_theta_interp"=1.
+c --- Can only use theta_r table when do *not* reduce ra_r_BackGround
+c --- to a smaller ra_r_ForeGround.
+ if ((ifbg_theta_interp.EQ.0).or.(ifrafglt.EQ.1)) then
+c
+c --- Use the calculated background Ri and Ri_d in the turbulence model.
+c --- Interpolate 2D table for salinity-temperature model case.
+c
+ call interp2d_expabs(back_ri1,back_rid1,
+ & slq2_back,sm_back,sh_back,ss_back,mt,mt0,dri,rri)
+c
+ elseif(ifbg_theta_interp.EQ.1) then
+c --- Interpolate 1D table of background vs. theta_r instead.
+* if (mnproc.eq.-99) then !always .false.
+* ! bugfix, potential I/O reduces the level of optimization
+* if ((iglobal.eq.344.and.jglobal.eq. 1) .or.
+* & (iglobal.eq.378.and.jglobal.eq. 32) ) then
+* write(lp,*) 'i,j,k = ',iglobal,jglobal,k
+* write(lp,*) ' ithet = ',itheta_r0,itheta_r1
+* write(lp,*) ' theta = ',theta_r,deltheta_r
+* write(lp,*) ' sm_r = ',sm_r1(itheta_r0),sm_r1(itheta_r1)
+* write(lp,*) ' sh_r = ',sh_r1(itheta_r0),sh_r1(itheta_r1)
+* write(lp,*) ' ss_r = ',ss_r1(itheta_r0),ss_r1(itheta_r1)
+* write(lp,*) 'slq2_r = ',slq2_r1(itheta_r0),slq2_r1(itheta_r1)
+* call flush(lp)
+* endif
+ deltheta_r1 = theta_r - itheta_r0*deltheta_r
+ delsm_back = sm_r1(itheta_r1) - sm_r1(itheta_r0)
+ dsm_back_o_dtheta = delsm_back/deltheta_r
+ sm_back = sm_r1(itheta_r0) +
+ & deltheta_r1*dsm_back_o_dtheta
+ delsh_back = sh_r1(itheta_r1) - sh_r1(itheta_r0)
+ dsh_back_o_dtheta = delsh_back/deltheta_r
+ sh_back = sh_r1(itheta_r0) +
+ & deltheta_r1*dsh_back_o_dtheta
+ delss_back = ss_r1(itheta_r1) - ss_r1(itheta_r0)
+ dss_back_o_dtheta = delss_back/deltheta_r
+ ss_back = ss_r1(itheta_r0) +
+ & deltheta_r1*dss_back_o_dtheta
+ delslq2_back = slq2_r1(itheta_r1) - slq2_r1(itheta_r0)
+ dslq2_back_o_dtheta = delslq2_back/deltheta_r
+ slq2_back = slq2_r1(itheta_r0) +
+ & deltheta_r1*dslq2_back_o_dtheta
+ else
+ write(lp,*) "Problem with choice of background interpolation."
+ write(lp,*) "ifbg_theta_interp=",ifbg_theta_interp
+ write(lp,*) "ifrafglt=",ifrafglt
+ write(lp,*) "Program is stopping."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+c
+c --- Calculate the square of the shear from the background Richardson number.
+c --- s2_back = N^2 / ri_internal = (N^2 / S_ext^2) (S_ext^2 /ri_internal)
+c --- = (Ri_ext / ri_internal) S_ext^2
+ s2_back = (ri1/back_ri1)*s2(k)
+c
+c --- Set square of shear to zero for unstable density stratification.
+ 19 continue
+ if (ri1.le.0.) then
+ s2_back = 0.
+ endif
+c
+c --- Set ill-defined S_M,H,S for unstable density stratification to zero.
+ if (ri1.lt.0.) then
+c
+ sm_back = 0
+ sh_back = 0
+ ss_back = 0
+ endif
+c
+ if ( sm_back.lt.0.0 .or.
+ & sh_back.lt.0.0 .or.
+ & ss_back.lt.0.0 .or.
+ & slq2_back.lt.0.0 ) then
+ v_back=2.0e-1
+ t_back=5.0e-2
+ s_back=5.0e-2
+* write(lp,'(i9,a,2i5,i3,a)')
+* & nstep,' i,j,k=',i+i0,j+j0,k,' GISS neg. sX_back'
+c
+c --- Skip background lengthscale calculation when using K_X/(epsilon/N^2) .
+ elseif (ifepson2.eq.0) then
+c
+c --- Use the constant background l_0 lengthscale in the turbulence model.
+ al0_back = back_l_0
+ akz=0.4*z1d(k)
+ al_back=akz*al0_back/(al0_back+akz)
+ al2_back=al_back*al_back
+c --- length scale reduction by buoyancy
+ if(back_ri1.gt.0.) then
+ anlq2_back=slq2_back*back_ri1
+ if(anlq2_back.gt.0.281) then !0.281=0.53**2
+ al2_back=0.281/anlq2_back*al2_back
+ slq2_back=0.281/(back_ri1+1.E-20)
+ endif
+ endif
+c
+c --- Calculate the background diffusivities.
+ tmp_back=0.5*b1*al2_back*sqrt(s2_back/(slq2_back+1.E-40))
+ v_back(k)=tmp_back*sm_back
+ t_back(k)=tmp_back*sh_back
+ s_back(k)=tmp_back*ss_back
+c
+c --- Use K_X = K_X/(\epsilon/N^2) * (\epsilon/N^2)
+c --- From NBp.000215-5, Volume IX :
+c --- K_X/(\epsilon/N^2) = (1/2) B_1 Ri (S l/q)^2 S_X .
+c --- K_X = (((1/2) B_1^2 Ri (S l/q)^2)* (\epsilon/N^2)) * S_X
+ else !if(ifepson2.gt.0) then
+ tmp_back=0.5*b1**2*back_ri1*slq2_back*epson2
+ v_back(k)=tmp_back*sm_back
+ t_back(k)=tmp_back*sh_back
+ s_back(k)=tmp_back*ss_back
+ endif
+c
+c --- Stop if background diffusivities are negative.
+ if ((v_back(k).lt.0.).or.
+ & (t_back(k).lt.0.).or.
+ & (s_back(k).lt.0.) ) then
+ write(lp,*)
+ & "************************************************"
+ write(lp,*) "Problem in turbulence module!"
+ write(lp,*) "Negative Background Diffusivity."
+ write(lp,*) "v_back=",v_back(k)
+ write(lp,*) "t_back=",t_back(k)
+ write(lp,*) "s_back=",s_back(k)
+ write(lp,*) " "
+ write(lp,*) "slq2_back=",slq2_back
+ write(lp,*) "sm_back=",sm_back
+ write(lp,*) "sh_back=",sh_back
+ write(lp,*) "ss_back=",ss_back
+ write(lp,*) " "
+ write(lp,*) "back_ra_r1 =", back_ra_r1
+ write(lp,*) "theta_r =", theta_r,
+ & " theta_r_deg=",theta_r_deg
+ write(lp,*) "back_rit1=",back_rit1,"back_ric1=",back_ric1
+ write(lp,*) "back_ri1=",back_ri1,"back_rid1=",back_rid1
+ write(lp,*) " "
+ write(lp,*) "k=",k," ria(k)=",ria(k)," rid(k)=",rid(k)
+ write(lp,*) "rit=",rit,"ric=",ric
+ write(lp,*) " "
+ write(lp,*) "i,j=",i+i0,j+j0
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+c
+c --- Stop if background diffusivities are zero at positive Ri.
+ if ((ria(k).gt.0.).and.
+ & ((v_back(k).eq.0.).or.
+ & (t_back(k).EQ.0.).or.
+ & (s_back(k).EQ.0.) )) then
+c
+ write(lp,*)
+ & "************************************************"
+ write(lp,*) "Problem in turbulence module!"
+ write(lp,*) "Zero Background Diffusivity in stable case."
+ write(lp,*) "v_back=",v_back(k),
+ & " t_back=",t_back(k),
+ & " s_back=",s_back(k)
+c Natassa
+ write(lp,*) "tmp_back=",tmp_back
+ write(lp,*) "b1=",b1
+ write(lp,*) "back_ri1=",back_ri1
+ write(lp,*) "epson2=",epson2
+ write(lp,*) "ri1=", ri1
+c
+c
+ write(lp,*) " "
+ write(lp,*) "slq2_back=",slq2_back
+ write(lp,*) "sm_back=",sm_back,
+ & " sh_back=",sh_back,
+ & " ss_back=",ss_back
+ write(lp,*) " "
+ write(lp,*) "slq2_r1(itheta_r0)=",slq2_r1(itheta_r0),
+ & " slq2_r1(itheta_r1)=",slq2_r1(itheta_r1)
+ write(lp,*) "sm_r1(itheta_r0)=",sm_r1(itheta_r0),
+ & " sm_r1(itheta_r1)=",sm_r1(itheta_r1)
+ write(lp,*) "sh_r1(itheta_r0)=",sh_r1(itheta_r0),
+ & " sh_r1(itheta_r1)=",sh_r1(itheta_r1)
+ write(lp,*) "ss_r1(itheta_r0)=",ss_r1(itheta_r0),
+ & " ss_r1(itheta_r1)=",ss_r1(itheta_r1)
+ write(lp,*) " "
+ write(lp,*) "back_ra_r1 =", back_ra_r1
+ write(lp,*) "theta_r =", theta_r
+ write(lp,*) "theta_r_deg =", theta_r_deg
+ write(lp,*) "back_rit1=",back_rit1,"back_ric1=",back_ric1
+ write(lp,*) "back_ri1=",back_ri1,"back_rid1=",back_rid1
+ write(lp,*) "itheta_r0=",itheta_r0," itheta_r1=",itheta_r1
+ write(lp,*) "jtheta_r0=",jtheta_r0," jtheta_r1=",jtheta_r1
+ write(lp,*) "n_theta_r_oct=",n_theta_r_oct
+ write(lp,*) "deltheta_r=",deltheta_r
+ write(lp,*) " "
+ write(lp,*) "k=",k," ria(k)=",ria(k)," rid(k)=",rid(k)
+ write(lp,*) "rit=",rit,"ric=",ric
+ write(lp,*) " "
+ write(lp,*) "i,j=",i+i0,j+j0
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+ endif
+ 20 continue
+c
+ endif !ifsali.gt.0
+c
+c --- end SECTION .or.SALINITY MODEL BACKGROUND DIFFUSIVITY CALCULATION.
+c
+c
+c --- Write internal turbulence quantities
+c --- Add S_M,H,S to outputs
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(lp,9000) z1d(k),al,slq2,ri1,rid1,sm,sh,ss,
+cdiag& v_back(k),t_back(k),s_back(k)
+cdiag endif
+c
+c --- introduce foreground minimum shear squared due to internal waves
+c --- to allow mixing in the unstable zero shear case
+c --- Reversion to ifsalback=3 model for this purpose,
+c --- based on Gargett et. al. JPO Vol.11 p.1258-71 "deep record".
+ s2(k) = max(s2(k),back_s2)
+c
+c --- In the case where the model is realizable at
+c --- the Ri obtained from the external Shear,
+c --- *but* there is a level above where it is NOT thus realizable,
+c --- USE THE "epsilon/(N^2)" DIMENSIONALIZATION .or."ifepson=2".
+c --- EXCEPT if "Ri<0" do *NOT* USE "epsilon/(N^2)" DIMENSIONALIZATION
+c --- BECAUSE IT PRODUCES NEGATIVE DIFFUSIVITIES IN THIS CASE.
+c --- *INSTEAD USE "l_deep^2 S", WHERE "l_deep" IS DERIVED FROM "rho" PROFILE.
+c --- "|{{d \rho / dz} \over {d2 \rho / dz^2}}| takes place of MLD in l_deep".
+c --- BUT *REVERT* TO "MLD" IN CASES OF FIRST TWO LEVELS.
+cdiag aldeep(k)=0.0
+ if ((ifepson2.EQ.2).AND.(ifbelow.EQ.1)) then
+ if (ri1.ge.0) then
+ tmp=0.5*b1**2*ri1*slq2*epson2
+ elseif(k.gt.2) then
+ delz = z1d(k+1) - z1d(k-1) !original version
+ delth = th1d(k+1) - th1d(k-1)
+ del2th = (th1d(k+1) + th1d(k-1)) - 2.*th1d(k)
+ dzth = delth/delz
+ d2zth = 4.*del2th/(delz**2)
+c
+c --- rdzlndzth = *Reciprocal* of Dz_{ln(Dz_{th})} = Dz_{th}/Dz2_{th} .
+ if (d2zth.eq.0.0) d2zth=epsil
+ rdzlndzth = dzth/d2zth
+c
+c --- introduce deep foreground minimum length scale due to internal waves
+c --- to prevent zero lengthscale in deep zero density gradient case
+c --- reversion to ifsalback=3 model for this purpose
+ al0deep=max(0.17*abs(rdzlndzth),back_l_0)
+ akz=0.4*z1d(k)
+ aldeep(k)=akz*al0deep/(al0deep+akz)
+ al2=aldeep(k)*aldeep(k)
+ tmp=0.5*b1*al2*sqrt(s2(k)/(slq2+1.E-40))
+ else
+ tmp=0.5*b1*al2*sqrt(s2(k)/(slq2+1.E-40))
+ endif
+ else
+ tmp=0.5*b1*al2*sqrt(s2(k)/(slq2+1.E-40))
+ endif
+ akm(k)=tmp*sm+v_back(k)
+ akh(k)=tmp*sh+t_back(k)
+ aks(k)=tmp*ss+s_back(k)
+c
+cdiag tmpk(k)=tmp
+c
+ 22 continue
+c
+c --- stop if DIFFUSIVITY IS NEGATIVE.
+ do k =1,klist(i,j)-1
+ if ((akm(k).lt.0.).or.(akh(k).lt.0.).or.(aks(k).lt.0.)) then
+ write(lp,*) "Diffusivity is negative."
+ write(lp,*) "k=",k
+ write(lp,*) "z[cm] tem[C] sal[ppt] rho[g/cm3] "//
+ & "Ri Ri_d S^2[/s2] "//
+ & "K_M[cm2/s] K_H[cm2/s] K_S[cm2/s] "
+ write(*,9000) z1d(k),th1d(k),ria(k),rid(k),s2(k),
+ & akm(k),akh(k),aks(k)
+ write(lp,*) " "
+ write(lp,*) "Program will stop."
+ call flush(lp)
+ call xchalt('(mxgissaij)')
+ stop '(mxgissaij)'
+ endif
+ enddo
+c
+c --- store new k values in the 3-d arrays
+ do k=1,kk
+ k1=k+1
+ if(k.lt.klist(i,j)) then
+ vcty(i,j,k1)=min(akm(k)*1.0e-4,difmax)
+ dift(i,j,k1)=min(akh(k)*1.0e-4,difmax)
+ difs(i,j,k1)=min(aks(k)*1.0e-4,difmax)
+ else
+ vcty(i,j,k1)=vcty(i,j,klist(i,j))
+ dift(i,j,k1)=dift(i,j,klist(i,j))
+ difs(i,j,k1)=difs(i,j,klist(i,j))
+ endif
+ enddo
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(6,'(a,a9,a3,5a13)')
+cdiag& 'giss1dout',' nstep',' k',
+cdiag& ' tmp',' aldeep',
+cdiag& ' akm',' akh',' aks'
+cdiag do k=1,klist(i,j)
+cdiag write(6,'(a,i9,i3,1p,6e13.5)') 'giss1dout',
+cdiag& nstep,k,tmpk(k),aldeep(k),akm(k),akh(k),aks(k)
+cdiag enddo
+cdiag endif
+c
+ 9000 format(12(1pe11.3))
+c
+ 101 format(i9,3i4,'absorbup,dn,dtemp,dsaln ',2f6.3,2f10.6)
+c
+ return
+ end
+c
+ subroutine mxkprfbij(m,n, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, i,j
+c
+c -------------------------------------------------------------
+c --- k-profile vertical diffusion, single j-row (part B)
+c --- vertical coordinate is z negative below the ocean surface
+c -------------------------------------------------------------
+c
+c --- perform the final vertical mixing at p points
+c
+c --- local 1-d arrays for matrix solution
+ real t1do(kdm+1),t1dn(kdm+1),s1do(kdm+1),s1dn(kdm+1),
+ & tr1do(kdm+1,mxtrcr),tr1dn(kdm+1,mxtrcr),
+ & difft(kdm+1),diffs(kdm+1),difftr(kdm+1),
+ & ghat(kdm+1),zm(kdm+1),hm(kdm),dzb(kdm)
+c
+c --- tridiagonal matrix solution arrays
+ real tri(kdm,0:1) ! dt/dz/dz factors in trid. matrix
+ real tcu(kdm), ! upper coeff for (k-1) on k line of trid.matrix
+ & tcc(kdm), ! central ... (k ) ..
+ & tcl(kdm), ! lower ..... (k-1) ..
+ & rhs(kdm) ! right-hand-side terms
+c
+ real ghatflux
+ integer k,ka,ktr,nlayer
+c
+ real, parameter :: difriv = 60.0e-4 !river diffusion
+c
+ include 'stmt_fns.h'
+c
+ nlayer=klist(i,j)
+c
+ do k=1,nlayer
+ difft( k+1)=dift(i,j,k+1)
+ diffs( k+1)=difs(i,j,k+1)
+ difftr(k+1)=difs(i,j,k+1)
+ ghat(k+1)= ghats(i,j,k+1)
+ t1do(k)=temp(i,j,k,n)
+ s1do(k)=saln(i,j,k,n)
+ do ktr= 1,ntracr
+ tr1do(k,ktr)=tracer(i,j,k,n,ktr)
+ enddo
+ hm(k)=max(onemm,dp(i,j,k,n))*qonem
+ zm(k)=zgrid(i,j,k)
+ enddo !k
+c
+ k=nlayer+1
+ ka=min(k,kk)
+ difft( k)=0.0
+ diffs( k)=0.0
+ difftr(k)=0.0
+ ghat(k)=0.0
+ t1do(k)=temp(i,j,ka,n)
+ s1do(k)=saln(i,j,ka,n)
+ do ktr= 1,ntracr
+ tr1do(k,ktr)=tracer(i,j,ka,n,ktr)
+ enddo
+ zm(k)=zm(k-1)-0.001
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,102) (nstep,i+i0,j+j0,k,
+cdiag& hm(k),t1do(k),temp(i,j,k,n),s1do(k),saln(i,j,k,n),
+cdiag& k=1,nlayer)
+cdiag call flush(lp)
+ 102 format(25x,
+ & ' thick t old t ijo s old s ijo'
+ & /(i9,2i5,i3,2x,f9.2,4f8.3))
+cdiag endif !test
+c
+c --- do rivers here because difs is also used for tracers.
+ if (thkriv.gt.0.0 .and. rivers(i,j,1).ne.0.0) then
+ do k=1,nlayer-1
+ if (-zm(k)+0.5*hm(k).lt.thkriv) then !interface Revision history:
+c>
+c> Jun 2000 - conversion to SI units.
+c> Jul 2000 - included wscale in this file to facilitate in-lining
+c> May 2002 - buoyfl (into the atmos.), calculated here
+c> Nov 2002 - added kPAR based turbidity
+c> Nov 2002 - hmonob,mixflx,buoflx,bhtflx saved for diagnostics
+c> Mar 2003 - added GISS mixed layer
+c> May 2003 - added bldmin and bldmax to KPP
+c> Jan 2004 - added latdiw to KPP and MY
+c> Jan 2004 - added bblkpp to KPP (bottom boundary layer)
+c> Jan 2004 - cv can now depend on bouyancy freqency
+c> Jan 2004 - added hblflg to KPP
+c> Mar. 2004 - added thkriv river support
+c> Mar 2004 - updated hblflg for KPP
+c> Mar. 2005 - added [ts]ofset
+c> Dec. 2008 - difsmo now a layer count
diff --git a/src_2.2.18_3_one/mxkrt.f b/src_2.2.18_3_one/mxkrt.f
new file mode 100755
index 0000000..1bb51a1
--- /dev/null
+++ b/src_2.2.18_3_one/mxkrt.f
@@ -0,0 +1,1263 @@
+ subroutine mxkrta(m,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- hycom version 1.0
+c --- original slab mixed layer
+c
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & depnew
+c
+ integer i,j,l
+cdiag integer k
+cdiag real totem,tosal,tndcyt,tndcys
+c
+c --- store 'old' t/s column integral in totem/tosal (diagnostic use only)
+c
+cdiag totem=0.
+cdiag tosal=0.
+cdiag do k=1,kk
+cdiag totem=totem+temp(itest,jtest,k,n)*dp(itest,jtest,k,n)
+cdiag tosal=tosal+saln(itest,jtest,k,n)*dp(itest,jtest,k,n)
+cdiag end do
+c
+ 103 format (i9,2i5,a/(32x,i3,2f8.2,f8.2,2f8.1))
+cdiag write (lp,103) nstep,itest+i0,jtest+j0,
+cdiag. ' entering mxkrt: temp saln dens thkns dpth',
+cdiag. (k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag. th3d(itest,jtest,k,n)+thbase,dp(itest,jtest,k,n)*qonem,
+cdiag. p(itest,jtest,k+1)*qonem,k=1,kk)
+c
+c --- ---------------
+c --- new mixed layer
+c --- ---------------
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtaaj(m,n, j, depnew)
+ enddo
+!$OMP END PARALLEL DO
+c
+cdiag write (lp,103) nstep,itest,jtest,
+cdiag. ' exiting mxkrta: temp saln dens thkns dpth',
+cdiag. (k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag. th3d(itest,jtest,k,n)+thbase,dp(itest,jtest,k,n)*qonem,
+cdiag. p(itest,jtest,k+1)*qonem,k=1,kk)
+c
+c --- compare 'old' with 'new' t/s column integral (diagnostic use only)
+c
+cdiag tndcyt=-totem
+cdiag tndcys=-tosal
+cdiag do k=1,kk
+cdiag tndcyt=tndcyt+temp(itest,jtest,k,n)*dp(itest,jtest,k,n)
+cdiag tndcys=tndcys+saln(itest,jtest,k,n)*dp(itest,jtest,k,n)
+cdiag end do
+cdiag write (lp,'(i9,2i5,3x,a,1p,3e12.4/22x,a,3e12.4)')
+cdiag. nstep,itest+i0,jtest+j0,
+cdiag. 'total saln,srf.flux,tndcy:',tosal/g,salflx(itest,
+cdiag. jtest)*delt1,tndcys/g,'total temp,srf.flux,tndcy:',totem/g,
+cdiag. surflx(itest,jtest)*delt1,tndcyt*spcifh/g
+c
+c --- ---------------
+c --- momentum mixing
+c --- ---------------
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtabj(m,n, j, depnew)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- fill mixed layer arrays
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpbl( i,j)=dpmixl(i,j, n)
+ tmix( i,j)=temp(i,j,1,n)
+ smix( i,j)=saln(i,j,1,n)
+ thmix(i,j)=th3d(i,j,1,n)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ return
+ end
+ subroutine mxkrtaaj(m,n, j, depnew)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+c --- single row, part A.
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n,j
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & depnew
+c
+ integer i,k,ka,k0,k1,ktr,l
+c
+ real tdp(idm),sdp(idm),dtemp(idm),dsaln(idm)
+ real dpth,ekminv,obuinv,ex,alf1,alf2,cp1,cp3,ape,cc4,spe,
+ . thknss,ustar3,buoyfl,dsgdt,tmn,smn,tup,sup,
+ . dtemp2,q,swfold,thet,alfadt,betads,
+ . swfrac,sflux1,tmin,tmax,smin,smax,trmin,trmax,
+ . thkold,thknew,t1,t2,s1,s2,tr1,tr2,dp1,dp2,dtrmax,
+ & beta_b,frac_b
+c
+ real ea1, ea2, em1, em2, em3, em4, em5
+ data ea1, ea2, em1, em2, em3, em4, em5
+ . /0.60,0.30,0.45,2.60,1.90,2.30,0.60/ ! Gaspar coefficients
+c
+ include 'stmt_fns.h'
+c
+c --- ---------------------
+c --- set the vertical grid
+c --- ---------------------
+c
+c --- store in -p- a set of interfaces that depict stratification the way a
+c --- "pure" isopycnic model would. -dpmixl- is physical mixed layer depth.
+c --- store variables averaged over -dpmixl- in layer 1.
+c
+ do 1 l=1,isp(j)
+c
+ do 10 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ klist(i,j)=-1
+c
+c --- start building up integral of t and s over mixed layer depth
+ tdp(i)=temp(i,j,1,n)*dp(i,j,1,n)
+ sdp(i)=saln(i,j,1,n)*dp(i,j,1,n)
+ util1(i,j)=dp(i,j,1,n)
+ util3(i,j)=th3d(i,j,1,n)
+ p(i,j,2)=dp(i,j,1,n)
+ pu(i,j,2)=dp(i,j,1,m)
+ 10 continue
+c
+ do 11 k=2,kk
+ do 11 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ pu(i,j,k+1)=pu(i,j,k)+dp(i,j,k,m)
+c
+c --- if mixed layer base is very close to interface, move it there
+ if (abs(p(i,j,k+1)-dpmixl(i,j,n)).lt.
+ . max(onecm,.001*dp(i,j,k,n)) ) then
+ dpmixl(i,j,n)=p(i,j,k+1)
+ endif
+c
+c --- watch for density decrease with depth (convective adjustment of
+c --- the mixed layer) - convection occurs for both time steps to
+c --- prevent mid-time and new mixed layer thicknesses from diverging
+ if (klist(i,j).le.-1 .and.
+ & p(i,j,k+1).gt.dpmixl(i,j,n) .and.
+ & p(i,j,k ).le.dpmixl(i,j,n) ) then
+ if (locsig) then
+ tup=tdp(i)/util1(i,j)
+ sup=sdp(i)/util1(i,j)
+ alfadt=0.5*
+ & (dsiglocdt(tup,sup,util1(i,j))+
+ & dsiglocdt(temp(i,j,k,n),saln(i,j,k,n),util1(i,j)))*
+ & (tup-temp(i,j,k,n))
+ betads=0.5*
+ & (dsiglocds(tup,sup,util1(i,j))+
+ & dsiglocds(temp(i,j,k,n),saln(i,j,k,n),util1(i,j)))*
+ & (sup-saln(i,j,k,n))
+ if(alfadt+betads.gt.0.0) then
+ dpmixl(i,j,n)=p (i,j,k+1)
+ klist(i,j)=-2
+ end if
+ else
+ th3d(i,j,1,n)=sig(tdp(i)/util1(i,j),sdp(i)/util1(i,j))
+ & -thbase
+ if(th3d(i,j,1,n).gt.th3d(i,j,k,n)) then
+ dpmixl(i,j,n)=p (i,j,k+1)
+ klist(i,j)=-2
+ endif
+ end if
+ end if
+c
+ if (p(i,j,k+1).le.dpmixl(i,j,n)) then
+ tdp(i)=tdp(i)+dp(i,j,k,n)*temp(i,j,k,n)
+ sdp(i)=sdp(i)+dp(i,j,k,n)*saln(i,j,k,n)
+ util1(i,j)=util1(i,j)+dp(i,j,k,n)
+c
+ else if (p(i,j,k).lt.dpmixl(i,j,n)) then
+ klist(i,j)=k
+ end if
+ 11 continue
+c
+ do 12 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ temp(i,j,1,n)=tdp(i)/util1(i,j)
+ saln(i,j,1,n)=sdp(i)/util1(i,j)
+ th3d(i,j,1,n)=sig(temp(i,j,1,n),saln(i,j,1,n))-thbase
+* if (klist(i,j).eq.-2) then
+* util3(i,j)=th3d(i,j,1,n)
+* do 122 k1=2,kk
+* if (p(i,j,k1+1).le.dpmixl(i,j,n)) then
+* th3d(i,j,k1,n)=th3d(i,j,1,n)
+* endif
+*122 continue
+* end if
+ 12 continue
+c
+c --- unmix t, s, and tracer
+c
+c --- the first guesses for upper sublayer values are the old-time mixed
+c --- layer values saved in hybgen plus all changes that have occurred
+c --- since then
+c
+c --- prevent spurious maxima or minima from being generated in the lower
+c --- sublayer, then adjust upper sublayer values if necessary to conserve
+c --- vertical averages
+c
+ do 13 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if(klist(i,j).ge.2) then
+ k=klist(i,j)
+ k0=min(k+1,kk)
+ dp1=dpmixl(i,j,n)-p(i,j,k)
+ dp2=p(i,j,k+1)-dpmixl(i,j,n)
+ q=-dp1/dp2
+ if(k.eq.nmlb(i,j,n)) then
+ t1=t1sav(i,j,n)+temp(i,j,k,n)-tmlb(i,j,n)
+ s1=s1sav(i,j,n)+saln(i,j,k,n)-smlb(i,j,n)
+ else
+ t1=temp(i,j,k-1,n)
+ s1=saln(i,j,k-1,n)
+ nmlb(i,j,n)=k
+ end if
+ tmin=min(t1,temp(i,j,k,n),temp(i,j,k0,n))
+ tmax=max(t1,temp(i,j,k,n),temp(i,j,k0,n))
+ smin=min(s1,saln(i,j,k,n),saln(i,j,k0,n))
+ smax=max(s1,saln(i,j,k,n),saln(i,j,k0,n))
+ t2=temp(i,j,k,n)+q*(t1-temp(i,j,k,n))
+ s2=saln(i,j,k,n)+q*(s1-saln(i,j,k,n))
+ temp(i,j,k,n)=min(tmax,max(tmin,t2))
+ saln(i,j,k,n)=min(smax,max(smin,s2))
+ util4(i,j)=th3d(i,j,k,n)
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ t1=t1+(t2-temp(i,j,k,n))*dp2/dp1
+ s1=s1+(s2-saln(i,j,k,n))*dp2/dp1
+ tdp(i)=tdp(i)+t1*dp1
+ sdp(i)=sdp(i)+s1*dp1
+ temp(i,j,1,n)=tdp(i)/dpmixl(i,j,n)
+ saln(i,j,1,n)=sdp(i)/dpmixl(i,j,n)
+ th3d(i,j,1,n)=sig(temp(i,j,1,n),saln(i,j,1,n))-thbase
+ do ktr= 1,ntracr
+ tr1=1.0 ! THIS MAY BE WRONG FOR MULTIPLE TRACERS
+ trmin=min(tr1,tracer(i,j,k,n,ktr),tracer(i,j,k0,n,ktr))
+ trmax=max(tr1,tracer(i,j,k,n,ktr),tracer(i,j,k0,n,ktr))
+ tr2=tracer(i,j,k,n,ktr)+q*(tr1-tracer(i,j,k,n,ktr))
+ tracer(i,j,k,n,ktr)=min(trmax,max(trmin,tr2))
+ enddo
+ end if
+13 continue
+c
+c --- set the new grid
+c
+ do 14 k=1,kk
+ do 14 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ 14 p(i,j,k+1)=max(dpmixl(i,j,n),p(i,j,k+1))
+c
+ 1 continue
+c
+c --- ----------------------------------------
+c --- slab mixed layer entrainment/detrainment
+c --- ----------------------------------------
+c
+ do 85 l=1,isp(j)
+c
+ do 86 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- determine turb.kin.energy generation due to wind stirring
+c --- ustar computed in subr. -thermf-
+c --- buoyancy flux (m**2/sec**3), all fluxes into the ocean
+c --- note: surface density increases (column is destabilized) if buoyfl < 0
+ thkold=dpmixl(i,j,n)
+ ustar3=ustar(i,j)**3
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+ dsgdt=dsigdt(tmn,smn)
+ buoyfl=-g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref+
+ & dsgdt *surflx(i,j)*thref/spcifh)
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 1 : k r a u s - t u r n e r mixed-layer t.k.e. closure
+c
+ccc em=0.8*exp(-p(i,j,2)/(50.*onem)) ! hadley centre choice (orig.: 1.25)
+ccc en=0.15 ! hadley centre choice (orig.: 0.4)
+ccc thermg=-0.5*((en+1.)*buoyfl+(en-1.)*abs(buoyfl))
+ccc turgen(i,j)=delt1*(2.*em*g*ustar3*qthref+thkold*thermg)*qthref**2
+c
+c --- find monin-obukhov length in case of receding mixed layer (turgen < 0).
+c --- the monin-obukhov length is found by stipulating turgen = 0.
+c
+ccc if (turgen(i,j).lt.0.) then
+ccc depnew(i,j)=-2.*em*g*ustar3/min(-epsil,thref*thermg)
+ccc else
+ccc depnew(i,j)=thkold
+ccc end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 2 : g a s p a r mixed-layer t.k.e. closure
+c
+ dpth=thkold*qonem
+ ekminv=1./hekman(i,j)
+ obuinv=buoyfl/max(epsil,ustar3)
+ ex=exp(min(50.,dpth*obuinv))
+ alf1=ea1+ea2*max(1.,2.5*dpth*ekminv)*ex
+ alf2=ea1+ea2*ex
+ cp1=((1.-em5)*(alf1/alf2)+.5*em4)*athird
+ cp3=max(0.,(em4*(em2+em3)-(alf1/alf2)*(em2+em3-em3*em5))*athird)
+ ape=cp3*ustar3-cp1*dpth*buoyfl
+c
+ if(ape.lt.0.) then ! detrainment
+ turgen(i,j)=(g*delt1*qthref**3)*ape
+ depnew(i,j)=min(thkold,g*cp3/(thref*cp1*max(epsil,obuinv)))
+c
+ else ! entrainment
+ cc4=2.*em4/(em1*em1) * alf1*alf1
+ spe=(em2+em3)*ustar3-0.5*dpth*buoyfl
+ turgen(i,j)=(g*delt1*qthref**3)*(sqrt((.5*ape-cp1*spe)**2
+ . +2.*cc4*ape*spe)-(.5*ape+cp1*spe))/(cc4-cp1)
+ depnew(i,j)=thkold
+ end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- util1,util2 are used to evaluate pot.energy changes during entrainment
+ util1(i,j)=util3(i,j)*dp(i,j,1,n)
+ util2(i,j)=util3(i,j)*dp(i,j,1,n)**2
+ pu(i,j,2)=dp(i,j,1,n)
+ 86 continue
+c
+c --- find thknew in case of mx.layer deepening (turgen>0). store in -depnew-.
+c --- entrain as many layers as needed to deplete -turgen-.
+c
+ do 85 k=2,kk
+ ka=k-1
+ do 85 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pu(i,j,k+1)=pu(i,j,k)+dp(i,j,k,n)
+ if (k.eq.2) then
+ thstar(i,j,ka,1)=util3(i,j)
+ endif
+ if (locsig) then
+ alfadt=0.5*
+ & (dsiglocdt(temp(i,j,ka,n),saln(i,j,ka,n),pu(i,j,k))+
+ & dsiglocdt(temp(i,j,k ,n),saln(i,j,k ,n),pu(i,j,k)))*
+ & (temp(i,j,ka,n)-temp(i,j,k,n))
+ betads=0.5*
+ & (dsiglocds(temp(i,j,ka,n),saln(i,j,ka,n),pu(i,j,k))+
+ & dsiglocds(temp(i,j,k ,n),saln(i,j,k ,n),pu(i,j,k)))*
+ & (saln(i,j,ka,n)-saln(i,j,k,n))
+ thstar(i,j,k,1)=thstar(i,j,ka,1)-alfadt-betads
+ thet=thstar(i,j,k,1)
+ else
+ if (k.ne.klist(i,j)) then
+ thet=th3d(i,j,k,n)
+ else
+ thet=util4(i,j)
+ endif
+ endif
+ thknew=max(dpmixl(i,j,n),min(pu(i,j,k+1),
+ . (2.0*turgen(i,j)+thet*pu(i,j,k)**2-util2(i,j))/
+ . max(epsil,thet*pu(i,j,k) -util1(i,j))))
+c --- stop iterating for 'thknew' as soon as thknew < k-th interface pressure
+ if (thknew.lt.pu(i,j,k)) thknew=depnew(i,j)
+c --- substitute 'thknew' for monin-obukhov length if mixed layer is deepening
+ if (turgen(i,j).ge.0.) then
+ depnew(i,j)=thknew
+ endif
+c
+ util1(i,j)=util1(i,j)+thet*(pu(i,j,k+1) -pu(i,j,k) )
+ 85 util2(i,j)=util2(i,j)+thet*(pu(i,j,k+1)**2-pu(i,j,k)**2)
+c
+ dtrmax = (onem*dtrate/86400.0) * delt1
+ do 26 l=1,isp(j)
+c
+ do 42 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag if (turgen(i,j).lt.0.) then
+cdiag write (lp,'(i9,2i5,a,1p,2e13.5)') nstep,i+i0,j+j0,
+cdiag. ' m-o length (m), turgen:',depnew(i,j)*qonem,turgen(i,j)
+cdiag else
+cdiag write (lp,'(i9,2i5,a,1p,2e13.5)') nstep,i+i0,j+j0,
+cdiag. ' new depth (m), turgen:',depnew(i,j)*qonem,turgen(i,j)
+cdiag endif
+cdiag endif
+c
+c --- don't allow mixed layer to get too deep or too shallow. mixed layer
+c --- detrainment rate limited to dtrate m/day
+ depnew(i,j)=min(p(i,j,kk+1)-onem,
+ . max(thkmin*onem,pu(i,j,3),dp(i,j,1,n)+onemm,
+ . depnew(i,j),dpmixl(i,j,n)-dtrmax))
+ 42 continue
+c
+ do 43 k=2,kk
+ do 43 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thknew=depnew(i,j)
+c --- integrate t/s over depth range slated for entrainment into mixed layer
+ tdp(i)=tdp(i)+temp(i,j,k,n)*(min(thknew,p(i,j,k+1))
+ . -min(thknew,p(i,j,k )))
+ 43 sdp(i)=sdp(i)+saln(i,j,k,n)*(min(thknew,p(i,j,k+1))
+ . -min(thknew,p(i,j,k )))
+c
+ do 26 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thkold=p(i,j,2)
+ thknew=depnew(i,j)
+ thknss=max(thknew,thkold)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) write (lp,'(i9,2i5,a,2f10.4)')
+cdiag. nstep,i+i0,j+j0,
+cdiag. ' old/new mixed layer depth:',thkold*qonem,thknew*qonem
+c
+c --- distribute thermohaline forcing over new mixed layer depth
+c --- flux positive into ocean
+ if(pensol) then
+c
+c --- penetrating solar radiation (all redfac in mixed layer)
+ if (thknew.lt.p(i,j,kk+1)-onecm) then
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ else
+ beta_b = betabl(jerlov(i,j))
+ frac_b = 1.0 - redfac(jerlov(i,j))
+ endif
+ if (-thknew*beta_b.gt.-10.0) then
+ swfrac=frac_b*exp(-thknew*beta_b)
+ else
+ swfrac=0.0
+ endif
+ else
+c --- mixed layer reaches the bottom
+ swfrac=0.0
+ endif
+ sflux1=surflx(i,j)-sswflx(i,j)
+ dtemp(i)=(sflux1+(1.-swfrac)*sswflx(i,j))*delt1*g/
+ & (spcifh*thknew)
+ dsaln(i)=salflx(i,j) *delt1*g/
+ & thknew
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write(lp,104) nstep,i+i0,j+j0,k,0.,1.-swfrac,dtemp(i),dsaln(i)
+cdiag endif
+ 104 format(i9,2i5,i3,'absorbup,dn,dtemp,dsaln ',2f6.3,2f10.6)
+c
+ else
+c
+ dtemp(i)=surflx(i,j)*delt1*g/(spcifh*thknew)
+ dsaln(i)=salflx(i,j)*delt1*g/ thknew
+c
+ end if
+c
+c --- calculate average temp, saln over max(old,new) mixed layer depth
+ temp(i,j,1,n)=tdp(i)/thknss
+ saln(i,j,1,n)=sdp(i)/thknss
+ p(i,j,2)=dp(i,j,1,n)
+ 26 continue
+c
+c --- homogenize water mass properties down to max(old,new) mixed layer depth
+c --- Asselin time smoothing of mixed layer depth
+c
+ do 9 l=1,isp(j)
+c
+ do 19 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thknss=max(depnew(i,j),dpmixl(i,j,n))
+ dpmixl(i,j,n)=depnew(i,j)
+ depnew(i,j)=thknss
+ dpmixl(i,j,m)=wts1*dpmixl(i,j,m)+wts2*(dpmold(i,j) +
+ . dpmixl(i,j,n) )
+ 19 continue
+c
+ do 9 k=2,kk
+ do 9 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ q=max(0.,min(1.,(depnew(i,j)-p(i,j,k))/(dp(i,j,k,n)+epsil)))
+ temp(i,j,k,n)=temp(i,j,k,n)+q*(temp(i,j,1,n)-temp(i,j,k,n))
+ saln(i,j,k,n)=saln(i,j,k,n)+q*(saln(i,j,1,n)-saln(i,j,k,n))
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=tracer(i,j,k,n,ktr)
+ & +q*(tracer(i,j,1,n,ktr)-tracer(i,j,k,n,ktr))
+ enddo
+ 9 continue
+c
+c --- add in surface thermohaline forcing over the new mixed layer depth
+c --- add penetrating solar radiation
+ do 79 l=1,isp(j)
+ do 79 k=1,kk
+ do 79 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thknss=dpmixl(i,j,n)
+ q=max(0.,min(1.,(thknss-p(i,j,k))/(dp(i,j,k,n)+epsil)))
+ if(q.eq.1.) then
+ temp(i,j,k,n)=temp(i,j,k,n)+dtemp(i)
+ saln(i,j,k,n)=saln(i,j,k,n)+dsaln(i)
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ else
+ temp(i,j,k,n)=temp(i,j,k,n)+q*dtemp(i)
+ saln(i,j,k,n)=saln(i,j,k,n)+q*dsaln(i)
+ if(pensol) then
+c
+c --- heat layers beneath mixed layer due to
+c --- penetrating solar radiation (all redfac in mixed layer)
+ if (p(i,j,k+1).lt.p(i,j,kk+1)-onecm) then
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ else
+ beta_b = betabl(jerlov(i,j))
+ frac_b = 1.0 - redfac(jerlov(i,j))
+ endif
+ if (-max(thknss,p(i,j,k))*beta_b.gt.-10.0) then
+ swfold=frac_b*exp(-max(thknss,p(i,j,k ))*beta_b)
+ swfrac=frac_b*exp( -p(i,j,k+1) *beta_b)
+ dtemp2=(swfold-swfrac)*sswflx(i,j)*delt1*g/(spcifh*
+ & max(onemm,p(i,j,k+1)-max(thknss,p(i,j,k))))
+ else
+ dtemp2=0.0
+ endif
+ elseif (p(i,j,k).lt.p(i,j,kk+1)-onecm) then
+c --- deepest non-zero layer
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ else
+ beta_b = betabl(jerlov(i,j))
+ frac_b = 1.0 - redfac(jerlov(i,j))
+ endif
+ if (-max(thknss,p(i,j,k))*beta_b.gt.-10.0) then
+ swfold=frac_b*exp(-max(thknss,p(i,j,k))*beta_b)
+ dtemp2= swfold *sswflx(i,j)*delt1*g/(spcifh*
+ & max(onemm,p(i,j,k+1)-max(thknss,p(i,j,k))))
+ else
+ dtemp2=0.0
+ endif
+ else
+ dtemp2=0.0
+ endif
+ temp(i,j,k,n)=temp(i,j,k,n)+(1.-q)*dtemp2
+cdiag if (i.eq.itest.and.j.eq.jtest) write (lp,104) nstep,i,j,1,
+cdiag& 1.-swfold,1.-swfrac,(1.-q)*dtemp2
+ end if
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ end if
+ 79 continue
+ return
+ end
+ subroutine mxkrtabj(m,n, j, depnew)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0
+c --- single row, part B.
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n,j
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & depnew
+c
+ integer i,k,k1,l
+c
+ real dp1,dp2,q,uv1,uv2,uvmin,uvmax
+c
+c --- ---------------
+c --- momentum mixing
+c --- ---------------
+c
+c --- homogenize -u- down to max(old,new) mixed layer depth
+c
+ do 32 l=1,isu(j)
+c
+ do 33 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ util1(i,j)=min(depthu(i,j)-onem,max(dpu(i,j,1,n),thkmin*onem,
+ . .5*(depnew(i,j)+depnew(i-1,j))))
+c
+c --- if mixed layer base is very close to interface, move it there
+ if (abs(util1(i,j)-dpu(i,j,1,n)).lt..001*dpu(i,j,1,n)) then
+ util1(i,j)=dpu(i,j,1,n)+onecm
+ endif
+c
+ uflux(i,j)=u(i,j,1,n)*dpu(i,j,1,n)
+ util2(i,j)=dpu(i,j,1,n)
+ 33 pu(i,j,2)=dpu(i,j,1,n)
+c
+ do 34 k=2,kk
+ do 34 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,n)
+c
+c --- if mixed layer base is very close to interface, move it there
+ if (abs(pu(i,j,k+1)-util1(i,j)).lt.
+ . max(onecm,.001*dpu(i,j,k,n)) ) then
+ util1(i,j)=pu(i,j,k+1)
+ endif
+c
+ if (pu(i,j,k+1).le.util1(i,j)) then
+ uflux(i,j)=uflux(i,j)+u(i,j,k,n)*dpu(i,j,k,n)
+ util2(i,j)=util2(i,j)+ dpu(i,j,k,n)
+ end if
+ 34 continue
+c
+ do 35 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ 35 u(i,j,1,n)=uflux(i,j)/util2(i,j)
+c
+c --- unmix u
+c --- first guess for upper sublayer value is the value from the layer
+c --- immediately above the one containing the mixed layer base
+ do 36 k=2,kk
+ k1=min(k+1,kk)
+ do 36 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (pu(i,j,k ).lt.util1(i,j) .and.
+ . pu(i,j,k+1).gt.util1(i,j) ) then
+ if(k.ge.3) then
+ dp1=util1(i,j)-pu(i,j,k)
+ dp2=pu(i,j,k+1)-util1(i,j)
+ uv1=u(i,j,k-1,n)
+ uvmin=min(uv1,u(i,j,k,n),u(i,j,k1,n))
+ uvmax=max(uv1,u(i,j,k,n),u(i,j,k1,n))
+ uv2=u(i,j,k,n)-(uv1-u(i,j,k,n))*dp1/dp2
+ u(i,j,k,n)=min(uvmax,max(uvmin,uv2))
+ uv1=uv1+(uv2-u(i,j,k,n))*dp2/dp1
+ u(i,j,1,n)=(uflux(i,j)+uv1*dp1)/util1(i,j)
+ end if
+ end if
+ 36 continue
+c
+ do 32 k=2,kk
+ do 32 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+cdiag uold=u(i,j,k,n)
+ q=max(0.,min(1.,(util1(i,j)-pu(i,j,k))/(dpu(i,j,k,n)+epsil)))
+ u(i,j,k,n)=u(i,j,k,n)+q*(u(i,j,1,n)-u(i,j,k,n))
+cdiag if (i.eq.itest .and. j.eq.jtest) write
+cdiag. (lp,'(i9,2i5,i3,a,f9.3,2f8.3)') nstep,i+i0,j+j0,k,
+cdiag. ' dpu, old/new u ',dpu(i,j,k,n)*qonem,uold,u(i,j,k,n)
+ 32 continue
+c
+c --- homogenize -v- down to max(old,new) mixed layer depth
+c
+ do 52 l=1,isv(j)
+c
+ do 53 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ util1(i,j)=min(depthv(i,j)-onem,max(dpv(i,j,1,n),thkmin*onem,
+ . .5*(depnew(i,j)+depnew(i,j-1))))
+c
+c --- if mixed layer base is very close to interface, move it there
+ if (abs(util1(i,j)-dpv(i,j,1,n)).lt..001*dpv(i,j,1,n)) then
+ util1(i,j)=dpv(i,j,1,n)+onecm
+ endif
+c
+ vflux(i,j)=v(i,j,1,n)*dpv(i,j,1,n)
+ util2(i,j)=dpv(i,j,1,n)
+ 53 pv(i,j,2)=dpv(i,j,1,n)
+c
+ do 54 k=2,kk
+ do 54 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,n)
+c
+c --- if mixed layer base is very close to interface, move it there
+ if (abs(pv(i,j,k+1)-util1(i,j)).lt.
+ . max(onecm,.001*dpv(i,j,k,n)) ) then
+ util1(i,j)=pv(i,j,k+1)
+ endif
+c
+ if (pv(i,j,k+1).le.util1(i,j)) then
+ vflux(i,j)=vflux(i,j)+v(i,j,k,n)*dpv(i,j,k,n)
+ util2(i,j)=util2(i,j)+ dpv(i,j,k,n)
+ end if
+ 54 continue
+c
+ do 55 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ 55 v(i,j,1,n)=vflux(i,j)/util2(i,j)
+c
+c --- unmix v
+c --- first guess for upper sublayer value is the value from the layer
+c --- immediately above the one containing the mixed layer base
+ do 56 k=2,kk
+ k1=min(k+1,kk)
+ do 56 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (pv(i,j,k ).lt.util1(i,j) .and.
+ . pv(i,j,k+1).gt.util1(i,j) ) then
+ if(k.ge.3) then
+ dp1=util1(i,j)-pv(i,j,k)
+ dp2=pv(i,j,k+1)-util1(i,j)
+ uv1=v(i,j,k-1,n)
+ uvmin=min(uv1,v(i,j,k,n),v(i,j,k1,n))
+ uvmax=max(uv1,v(i,j,k,n),v(i,j,k1,n))
+ uv2=v(i,j,k,n)-(uv1-v(i,j,k,n))*dp1/dp2
+ v(i,j,k,n)=min(uvmax,max(uvmin,uv2))
+ uv1=uv1+(uv2-v(i,j,k,n))*dp2/dp1
+ v(i,j,1,n)=(vflux(i,j)+uv1*dp1)/util1(i,j)
+ end if
+ end if
+ 56 continue
+c
+ do 52 k=2,kk
+ do 52 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+cdiag vold=v(i,j,k,n)
+ q=max(0.,min(1.,(util1(i,j)-pv(i,j,k))/(dpv(i,j,k,n)+epsil)))
+ v(i,j,k,n)=v(i,j,k,n)+q*(v(i,j,1,n)-v(i,j,k,n))
+cdiag if (i.eq.itest .and. j.eq.jtest) write
+cdiag. (lp,'(i9,2i5,i3,a,f9.3,2f8.3)') nstep,i+i0,j+j0,k,
+cdiag. ' dpv, old/new v ',dpv(i,j,k,n)*qonem,vold,v(i,j,k,n)
+ 52 continue
+c
+ 31 continue
+c
+ return
+ end
+c
+ subroutine mxkrtb(m,n)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0 -- alternative slab mixed layer model
+ implicit none
+c
+c
+ integer m,n
+c
+ integer j
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtbaj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtbbj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+ return
+ end
+c
+ subroutine mxkrtbaj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0 -- alternative slab mixed layer model
+c --- single row, part A.
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n,j
+c
+ real dpth,ekminv,obuinv,ex,alf1,alf2,cp1,cp3,ape,cc4,spe,
+ & ustar3,thkold,thknew,value,q,tdp,sdp,trdp(mxtrcr),
+ & tem,sal,rho,thet,alfadt,betads,
+ & ttem(kdm),ssal(kdm),ttrc(kdm,mxtrcr),dens(kdm),densl(kdm),
+ & pres(kdm+1),delp(kdm),sum1,sum2,buoyfl,dsgdt,tmn,smn
+cdiag real totem,tosal,tndcyt,tndcys
+ integer kmxbot
+ integer i,k,ka,ktr,l
+c
+c --- abs.bound (m/day) and rel.bound (percent/day) on detrainment rate:
+ccc real bound1, bound2
+ccc data bound1, bound2 /200.0, 0.10/
+c
+ real ea1, ea2, em1, em2, em3, em4, em5
+ data ea1, ea2, em1, em2, em3, em4, em5
+ . /0.60,0.30,0.45,2.60,1.90,2.30,0.60/ ! Gaspar coefficients
+c
+ include 'stmt_fns.h'
+c
+ do 1 l=1,isp(j)
+ do 1 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- extract single column from 3-d fields
+ pres(1)=p(i,j,1)
+ do 7 k=1,kk
+ ttem(k)=temp(i,j,k,n)
+ ssal(k)=saln(i,j,k,n)
+ dens(k)=th3d(i,j,k,n)
+ do ktr= 1,ntracr
+ ttrc(k,ktr)=tracer(i,j,k,n,ktr)
+ enddo
+ delp(k)=dp(i,j,k,n)
+ 7 pres(k+1)=pres(k)+delp(k)
+c
+ 103 format (i9,2i5,a/(33x,i3,2f8.3,f8.3,f8.2,f8.1))
+cdiag if (i.eq.itest .and. j.eq.jtest)
+cdiag. write (lp,103) nstep,itest+i0,jtest+j0,
+cdiag. ' entering mxlayr: temp saln dens thkns dpth',(k,
+cdiag.ttem(k),ssal(k),dens(k)+thbase,delp(k)*qonem,pres(k+1)*qonem,k=1,kk)
+c
+c --- store 'old' t/s column integral in totem/tosal (diagnostic use only)
+cdiag totem=0.
+cdiag tosal=0.
+cdiag do k=1,kk
+cdiag totem=totem+ttem(k)*delp(k)
+cdiag tosal=tosal+ssal(k)*delp(k)
+cdiag end do
+c
+ tdp=ttem(1)*delp(1)
+ sdp=ssal(1)*delp(1)
+ do ktr= 1,ntracr
+ trdp(ktr)=delp(1)
+ enddo
+c
+ kmxbot=1
+ do 11 k=2,kk
+c
+c --- watch for density decrease with depth (convective adjustment)
+ tem=(tdp+ttem(k)*delp(k))/pres(k+1)
+ sal=(sdp+ssal(k)*delp(k))/pres(k+1)
+ rho=sig(tem,sal)-thbase
+ if (locsig) then
+ alfadt=0.5*(dsiglocdt(tem,sal,pres(k+1))+
+ & dsiglocdt(ttem(k),ssal(k),pres(k+1)))*(tem-ttem(k))
+ betads=0.5*(dsiglocds(tem,sal,pres(k+1))+
+ & dsiglocds(ttem(k),ssal(k),pres(k+1)))*(sal-ssal(k))
+ if(alfadt+betads.gt.0.0) then
+ ttem(1)=tem
+ ssal(1)=sal
+ dens(1)=rho
+ tdp=tdp+ttem(k)*delp(k)
+ sdp=sdp+ssal(k)*delp(k)
+ do ktr= 1,ntracr
+ trdp(ktr)=trdp(ktr)+ttrc(k,ktr)*delp(k)
+ enddo
+ kmxbot=k
+ end if
+ else
+ if (rho.le.dens(1)) then
+ ttem(1)=tem
+ ssal(1)=sal
+ dens(1)=rho
+ tdp=tdp+ttem(k)*delp(k)
+ sdp=sdp+ssal(k)*delp(k)
+ do ktr= 1,ntracr
+ trdp(ktr)=trdp(ktr)+ttrc(k,ktr)*delp(k)
+ enddo
+ kmxbot=k
+ end if
+ endif
+ if (k.gt.kmxbot) then
+ go to 12
+ endif
+ 11 continue
+ 12 continue
+c
+ do 10 k=2,kmxbot
+ ttem(k)=ttem(1)
+ ssal(k)=ssal(1)
+ dens(k)=dens(1)
+ do ktr= 1,ntracr
+ ttrc(k,ktr)=ttrc(1,ktr)
+ enddo
+
+ 10 continue
+c
+c --- ----------------------------------------
+c --- slab mixed layer entrainment/detrainment
+c --- ----------------------------------------
+c
+c --- determine turb.kin.energy generation due to wind stirring
+c --- ustar computed in subr. -thermf-
+c --- buoyancy flux (m**2/sec**3), all fluxes into the ocean
+c --- note: surface density increases (column is destabilized) if buoyfl < 0
+ thkold=pres(kmxbot+1)
+ ustar3=ustar(i,j)**3
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+ dsgdt=dsigdt(tmn,smn)
+ buoyfl=-g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref+
+ & dsgdt *surflx(i,j)*thref/spcifh)
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 1 : k r a u s - t u r n e r mixed-layer t.k.e. closure
+c
+ccc em=0.8*exp(-pres(2)/(50.*onem)) ! hadley centre choice (orig.: 1.25)
+ccc en=0.15 ! hadley centre choice (orig.: 0.4)
+ccc thermg=0.5*((en+1.)*buoyfl+(en-1.)*abs(buoyfl))
+ccc turgen(i,j)=delt1*(2.*em*g*ustar3*qthref+thkold*thermg)*qthref**2
+c
+c --- find monin-obukhov length in case of receding mixed layer (turgen < 0).
+c --- the monin-obukhov length is found by stipulating turgen = 0.
+c
+ccc if (turgen(i,j).lt.0.) then
+ccc thknew=-2.*em*g*ustar3/min(-epsil,thref*thermg)
+ccc else
+ccc thknew=thkold
+ccc end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 2 : g a s p a r mixed-layer t.k.e. closure
+c
+ dpth=thkold*qonem
+ ekminv=abs(corio(i,j))/max(epsil,ustar(i,j))
+ obuinv=buoyfl/max(epsil,ustar3)
+ ex=exp(min(50.,dpth*obuinv))
+ alf1=ea1+ea2*max(1.,2.5*dpth*ekminv)*ex
+ alf2=ea1+ea2*ex
+ cp1=((1.-em5)*(alf1/alf2)+.5*em4)*athird
+ cp3=max(0.,(em4*(em2+em3)-(alf1/alf2)*(em2+em3-em3*em5))*athird)
+ ape=cp3*ustar3+cp1*dpth*buoyfl
+c
+ if(ape.lt.0.) then ! detrainment
+ turgen(i,j)=(g*delt1*qthref**3)*ape
+ thknew=min(thkold,g*cp3/(thref*cp1*max(epsil,obuinv)))
+c
+ else ! entrainment
+ cc4=2.*em4/(em1*em1) * alf1*alf1
+ spe=(em2+em3)*ustar3+0.5*dpth*buoyfl
+ turgen(i,j)=(g*delt1*qthref**3)*(sqrt((.5*ape-cp1*spe)**2
+ . +2.*cc4*ape*spe)-(.5*ape+cp1*spe))/(cc4-cp1)
+ thknew=thkold
+ end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- sum1,sum2 are used to evaluate pot.energy changes during entrainment
+ sum1=dens(1)*thkold
+ sum2=dens(1)*thkold**2
+c
+c --- find thknew in case of mx.layer deepening (turgen>0). store in -thknew-.
+c --- entrain as many layers as needed to deplete -turgen-.
+c
+ do 85 k=2,kk
+ ka=k-1
+ if (locsig) then
+ if (k.eq.2) then
+ densl(ka)=dens(ka)
+ endif
+ alfadt=0.5*
+ & (dsiglocdt(ttem(ka),ssal(ka),pres(k))+
+ & dsiglocdt(ttem(k ),ssal(k ),pres(k)))*(ttem(ka)-ttem(k))
+ betads=0.5*
+ & (dsiglocds(ttem(ka),ssal(ka),pres(k))+
+ & dsiglocds(ttem(k ),ssal(k ),pres(k)))*(ssal(ka)-ssal(k))
+ densl(k)=densl(ka)-alfadt-betads
+ thet=densl(k)
+ else
+ thet=dens (k)
+ endif
+ if (pres(k+1).gt.thkold) then
+ value=(2.*turgen(i,j)+thet*pres(k)**2-sum2)/
+ & max(epsil,thet*pres(k) -sum1)
+c --- stop iterating for 'thknew' as soon as thknew < k-th interface pressure
+ if (value.lt.pres(k)) then
+ value=thknew
+ endif
+c --- substitute 'thknew' for monin-obukhov length if mixed layer is deepening
+ if (turgen(i,j).ge.0.) then
+ thknew=value
+ endif
+c
+ sum1=sum1+thet*(pres(k+1) -max(pres(k),thkold) )
+ sum2=sum2+thet*(pres(k+1)**2-max(pres(k),thkold)**2)
+ end if
+ 85 continue
+c
+cdiag if (i.eq.itest .and. j.eq.jtest .and. turgen(i,j).lt.0.)
+cdiag. write (lp,'(i9,2i5,a,f8.2,1p,e13.3)') nstep,itest+i0,jtest+j0,
+cdiag. ' monin-obukhov length (m),turgen:',thknew*qonem,turgen(i,j)
+c
+c --- don't allow mixed layer to get too deep or too shallow.
+ccc q=max(bound1*onem,thkold*bound2)*delt1/86400.
+ccc thknew=min(pres(kk+1),max(thkmin*onem,delp(1),thknew,thkold-q))
+ thknew=min(pres(kk+1),max(thkmin*onem,delp(1),thknew))
+c
+c --- integrate t/s over new mixed layer depth
+c
+ tdp=ttem(1)*delp(1)
+ sdp=ssal(1)*delp(1)
+c
+ do 15 k=2,kk
+ if (pres(k).lt.thknew) then
+ q=min(thknew,pres(k+1))-min(thknew,pres(k))
+ tdp=tdp+ttem(k)*q
+ sdp=sdp+ssal(k)*q
+ end if
+ 15 continue
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) write (lp,'(i9,2i5,a,2f9.3)')
+cdiag. nstep,i+i0,j+j0,
+cdiag. ' old/new mixed layer depth:',thkold*qonem,thknew*qonem
+c
+c --- distribute thermohaline forcing over new mixed layer depth
+c
+ ttem(1)=(tdp+surflx(i,j)*delt1*g/spcifh)/thknew
+ ssal(1)=(sdp+salflx(i,j)*delt1*g )/thknew
+ dens(1)=sig(ttem(1),ssal(1))-thbase
+c
+c --- homogenize water mass properties down to new mixed layer depth
+c
+ do 14 k=2,kk
+ if (pres(k+1).le.thknew) then
+ ttem(k)=ttem(1)
+ ssal(k)=ssal(1)
+ dens(k)=dens(1)
+ do ktr= 1,ntracr
+ ttrc(k,ktr)=ttrc(1,ktr)
+ enddo
+ else if (pres(k).lt.thknew) then
+c
+cdiag if (i.eq.itest.and.j.eq.jtest)
+cdiag. write (lp,'(i9,2i5,i3,a,3f9.3,25x,2f9.3)')
+cdiag. nstep,i+i0,j+j0,k,
+cdiag. ' p_k,thknew,p_k+1,t_1,t_k=',pres(k)*qonem,thknew*qonem,
+cdiag. pres(k+1)*qonem,ttem(1),ttem(k)
+c
+ ttem(k)=(ttem(1)*(thknew-pres(k))
+ . +ttem(k)*(pres(k+1)-thknew))/delp(k)
+ ssal(k)=(ssal(1)*(thknew-pres(k))
+ . +ssal(k)*(pres(k+1)-thknew))/delp(k)
+ dens(k)=sig(ttem(k),ssal(k))-thbase
+ do ktr= 1,ntracr
+ ttrc(k,ktr)=(ttrc(1,ktr)*(thknew-pres(k))
+ & +ttrc(k,ktr)*(pres(k+1)-thknew))/delp(k)
+ enddo
+ end if
+ 14 continue
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) write (lp,103) nstep,itest,jtest,
+cdiag.' exiting mxlayr: temp saln dens thkns dpth',(k,
+cdiag.ttem(k),ssal(k),dens(k)+thbase,delp(k)*qonem,pres(k+1)*qonem,k=1,kk)
+c
+c --- compare 'old' with 'new' t/s column integral (diagnostic use only)
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag tndcyt=-totem
+cdiag tndcys=-tosal
+cdiag do k=1,kk
+cdiag tndcyt=tndcyt+ttem(k)*delp(k)
+cdiag tndcys=tndcys+ssal(k)*delp(k)
+cdiag end do
+cdiag tndcyt=tndcyt-surflx(i,j)*delt1*g/spcifh
+cdiag tndcys=tndcys-salflx(i,j)*delt1*g
+cdiag write (lp,'(2i5,a,1p,2e16.8,e9.1)') i+i0,j+j0,
+cdiag. ' mxlyr temp.col.intgl.:',totem,tndcyt,tndcyt/totem
+cdiag write (lp,'(2i5,a,1p,2e16.8,e9.1)') i+i0,j+j0,
+cdiag. ' mxlyr saln.col.intgl.:',tosal,tndcys,tndcys/tosal
+cdiag write (lp,'(i9,2i5,3x,a,1p,3e10.2/22x,a,3e10.2)')
+cdiag. nstep,i+i0,j+j0,'total saln,srf.flux,tndcy:',tosal/g,
+cdiag. salflx*delt1,tndcys/g,'total temp,srf.flux,tndcy:',
+cdiag. totem/g,surflx*delt1,tndcyt*spcifh/g
+cdiag endif
+c
+c --- put single column back into 3-d fields
+ do 8 k=1,kk
+ temp(i,j,k,n)=ttem(k)
+ saln(i,j,k,n)=ssal(k)
+ th3d(i,j,k,n)=dens(k)
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=ttrc(k,ktr)
+ enddo
+ 8 continue
+c
+ dpmixl(i,j,n)=thknew
+c
+c --- fill mixed layer arrays
+c
+ dpbl(i,j)=dpmixl(i,j,n)
+ tmix(i,j)=temp(i,j,1,n)
+ smix(i,j)=saln(i,j,1,n)
+ thmix(i,j)=th3d(i,j,1,n)
+
+ 1 continue
+ return
+ end
+c
+ subroutine mxkrtbbj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 1.0 -- alternative slab mixed layer model
+c --- single row, part B.
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+ real zup,zlo,s1,s2,s3,smax,smin,sup,slo,q
+ integer i,k,l,ja,km
+c
+ real small
+ parameter (small=1.e-4)
+c
+c --- ---------------
+c --- momentum mixing
+c --- ---------------
+c
+c --- homogenize -u- down to new mixed layer depth
+c
+ ja=mod(j-2+jj,jj)+1
+c
+ do 32 l=1,isu(j)
+c
+ do 33 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ klist(i,j)=-1
+ util1(i,j)=max(dpu(i,j,1,n),.5*(dpmixl(i,j,n)+dpmixl(i-1,j,n)))
+ uflux(i,j)=u(i,j,1,n)*dpu(i,j,1,n)
+ util2(i,j)=dpu(i,j,1,n)
+ 33 pu(i,j,2)=dpu(i,j,1,n)
+c
+ do 34 k=2,kk
+ do 34 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,k+1)=pu(i,j,k)+dpu(i,j,k,n)
+ if (pu(i,j,k+1).le.util1(i,j)) then
+ uflux(i,j)=uflux(i,j)+u(i,j,k,n)*dpu(i,j,k,n)
+ util2(i,j)=util2(i,j)+ dpu(i,j,k,n)
+ else if (pu(i,j,k).lt.util1(i,j)) then
+c --- divide layer k into 2 sublayers. upper one belongs to mixed layer
+ zup=util1(i,j)-pu(i,j,k)
+ zlo=dpu(i,j,k,n)-zup
+ s1=u(i,j,k-1,n)
+ s2=u(i,j,k, n)
+ if (k.eq.kk .or. (k.lt.kk .and. dpu(i,j,k+1,n).lt.onemm)) then
+ s3=2.*s2-s1
+ else
+ s3=u(i,j,k+1,n)
+ end if
+c --- define 'bounding box'
+ smax=max(s1,s2,s3)
+ smin=min(s1,s2,s3)
+ if (s2.lt.smin+small .or. s2.gt.smax-small) then
+ sup=s2
+ slo=s2
+ else
+ slo=s3
+ sup=(s2*dpu(i,j,k,n)-slo*zlo)/zup
+ if (sup.gt.smin-small .and. sup.lt.smax+small) then
+ go to 36
+ endif
+ sup=s1
+ slo=(s2*dpu(i,j,k,n)-sup*zup)/zlo
+ if (slo.gt.smin-small .and. slo.lt.smax+small) then
+ go to 36
+ endif
+cdiag write (lp,100)
+cdiag. nstep,i+i0,j+j0,' possible',' error in unmixing u',
+cdiag. dpu(i,j,k,n)*qonem,zup*qonem,zlo*qonem,s1,s2,s3,
+cdiag. (s2*dpu(i,j,k,n)-slo*zlo)/zup,(s2*dpu(i,j,k,n)-sup*zup)/zlo
+ sup=s2
+ slo=s2
+ end if
+ 36 uflux(i,j)=uflux(i,j)+sup*zup
+ util2(i,j)=util2(i,j)+ zup
+ util3(i,j)=u(i,j,k,n)
+ u(i,j,k,n)=slo
+ klist(i,j)=k
+ end if
+ 34 continue
+ 100 format (i9,2i5,2a,3f9.3/3f10.4,2(2x,2f10.4))
+c
+ do 35 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ 35 u(i,j,1,n)=uflux(i,j)/util2(i,j)
+c
+ do 32 k=2,kk
+ do 32 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ q=max(0.,min(1.,(util1(i,j)-pu(i,j,k))/(dpu(i,j,k,n)+epsil)))
+ if (q.eq.0. .and. k.eq.klist(i,j)) then
+ u(i,j,k,n)=util3(i,j)
+ else
+ u(i,j,k,n)=u(i,j,1,n)*q+u(i,j,k,n)*(1.-q)
+ end if
+ 32 continue
+c
+c --- homogenize -v- down to new mixed layer depth
+c
+ do 52 l=1,isv(j)
+c
+ do 53 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ klist(i,j)=-1
+ util1(i,j)=max(dpv(i,j,1,n),.5*(dpmixl(i,j,n)+dpmixl(i,ja ,n)))
+ vflux(i,j)=v(i,j,1,n)*dpv(i,j,1,n)
+ util2(i,j)=dpv(i,j,1,n)
+ 53 pv(i,j,2)=dpv(i,j,1,n)
+c
+ do 54 k=2,kk
+ do 54 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k+1)=pv(i,j,k)+dpv(i,j,k,n)
+ if (pv(i,j,k+1).le.util1(i,j)) then
+ vflux(i,j)=vflux(i,j)+v(i,j,k,n)*dpv(i,j,k,n)
+ util2(i,j)=util2(i,j)+ dpv(i,j,k,n)
+ else if (pv(i,j,k).lt.util1(i,j)) then
+c --- divide layer k into 2 sublayers. upper one belongs to mixed layer
+ zup=util1(i,j)-pv(i,j,k)
+ zlo=dpv(i,j,k,n)-zup
+ s1=v(i,j,k-1,n)
+ s2=v(i,j,k, n)
+ if (k.eq.kk .or. (k.lt.kk .and. dpv(i,j,k+1,n).lt.onemm)) then
+ s3=2.*s2-s1
+ else
+ s3=v(i,j,k+1,n)
+ end if
+c --- define 'bounding box'
+ smax=max(s1,s2,s3)
+ smin=min(s1,s2,s3)
+ if (s2.lt.smin+small .or. s2.gt.smax-small) then
+ sup=s2
+ slo=s2
+ else
+ slo=s3
+ sup=(s2*dpv(i,j,k,n)-slo*zlo)/zup
+ if (sup.gt.smin-small .and. sup.lt.smax+small) then
+ go to 56
+ endif
+ sup=s1
+ slo=(s2*dpv(i,j,k,n)-sup*zup)/zlo
+ if (slo.gt.smin-small .and. slo.lt.smax+small) then
+ go to 56
+ endif
+cdiag write (lp,100)
+cdiag. nstep,i+i0,j+j0,' possible',' error in unmixing v',
+cdiag. dpv(i,j,k,n)*qonem,zup*qonem,zlo*qonem,s1,s2,s3,
+cdiag. (s2*dpv(i,j,k,n)-slo*zlo)/zup,(s2*dpv(i,j,k,n)-sup*zup)/zlo
+ sup=s2
+ slo=s2
+ end if
+ 56 vflux(i,j)=vflux(i,j)+sup*zup
+ util2(i,j)=util2(i,j)+ zup
+ util3(i,j)=v(i,j,k,n)
+ v(i,j,k,n)=slo
+ klist(i,j)=k
+ end if
+ 54 continue
+c
+ do 55 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ 55 v(i,j,1,n)=vflux(i,j)/util2(i,j)
+c
+ do 52 k=2,kk
+ do 52 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ q=max(0.,min(1.,(util1(i,j)-pv(i,j,k))/(dpv(i,j,k,n)+epsil)))
+ if (q.eq.0. .and. k.eq.klist(i,j)) then
+ v(i,j,k,n)=util3(i,j)
+ else
+ v(i,j,k,n)=v(i,j,1,n)*q+v(i,j,k,n)*(1.-q)
+ end if
+ 52 continue
+c
+ return
+ end
+c
+c> Revision history:
+c>
+c> May 2000 - conversion to SI units
+c> May 2000 - changed dimensions of turgen in light of its use in loop 85
+c> Oct 2000 - added mxkrtaaj and mxkrtabj to simplify OpenMP logic
+c> Nov 2000 - added alternative slab mixed layer model (mxkrtb*)
+c> May 2002 - buoyfl (into the ocean), calculated here
diff --git a/src_2.2.18_3_one/mxkrtm.f b/src_2.2.18_3_one/mxkrtm.f
new file mode 100755
index 0000000..dab737c
--- /dev/null
+++ b/src_2.2.18_3_one/mxkrtm.f
@@ -0,0 +1,623 @@
+ subroutine mxkrtm(m,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- hycom version 1.0 (adapted from micom version 2.8)
+c
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & sdot
+c
+ integer i,j,k,l
+ real delp,q,thk
+ccc integer kmax
+ccc real totem,tosal,tndcyt,tndcys,work(3)
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 1 j=1-margin,jj+margin
+ do 1 k=1,kk
+ do 1 l=1,isp(j)
+ do 1 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ 1 continue
+!$OMP END PARALLEL DO
+c
+ 103 format (i9,2i5,a/(33x,i3,2f8.3,f8.3,0p,f8.2,f8.1))
+cdiag if (itest.gt.0 .and. jtest.gt.0) write (lp,103) nstep,itest,jtest,
+cdiag. ' entering mxlayr: temp saln dens thkns dpth',
+cdiag. (k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag. th3d(itest,jtest,k,n)+thbase,dp(itest,jtest,k,n)*qonem,
+cdiag. p(itest,jtest,k+1)*qonem,k=1,kk)
+c
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+c
+c --- -----------------------------------
+c --- mixed layer entrainment/detrainment
+c --- -----------------------------------
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n,sdot)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtmaj(m,n, sdot, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+ else !.not.thermo ...
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 87 j=1-margin,jj+margin
+ do 87 l=1,isp(j)
+ do 87 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ surflx(i,j)=0.
+ salflx(i,j)=0.
+ sdot(i,j)=dp(i,j,1,n)
+ 87 continue
+!$OMP END PARALLEL DO
+c
+ end if !thermo.or.sstflg.gt.0.or.srelax:else
+c
+cdiag if (itest.gt.0.and.jtest.gt.0.and.turgen(itest,jtest).lt.0.)
+cdiag. write (lp,'(i9,2i5,a,f8.2)') nstep,itest,jtest,
+cdiag. ' monin-obukhov length (m):',sdot(itest,jtest)*qonem
+c
+c --- store 'old' t/s column integral in totem/tosal (diagnostic use only)
+ccc totem=0.
+ccc tosal=0.
+ccc do k=1,kk
+ccc if (max(dp(itest,jtest,1,n)+sdot(itest,jtest),thkmin*onem).gt.
+ccc . p(itest,jtest,k) .or. max(th3d(itest,jtest,1,m),th3d(itest,
+ccc . jtest,1,n)) +sigjmp.ge.th3d(i,j,k,n)) then
+ccc kmax=k
+ccc totem=totem+temp(itest,jtest,k,n)*dp(itest,jtest,k,n)
+ccc tosal=tosal+saln(itest,jtest,k,n)*dp(itest,jtest,k,n)
+ccc end if
+ccc end do
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n,sdot)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxkrtmbj(m,n, sdot, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- compare 'old' with 'new' t/s column integral (diagnostic use only)
+c
+ccc tndcyt=-totem
+ccc tndcys=-tosal
+ccc do k=kmax,1,-1
+ccc tndcyt=tndcyt+temp(itest,jtest,k,n)*dp(itest,jtest,k,n)
+ccc tndcys=tndcys+saln(itest,jtest,k,n)*dp(itest,jtest,k,n)
+ccc end do
+ccc write (lp,'(i9,2i5,i3,3x,a,1p,3e10.2/25x,a,3e10.2)') nstep,itest,
+ccc . jtest,kmax,'total saln,srf.flux,tndcy:',tosal/g,salflx(itest,
+ccc . jtest)*delt1,tndcys/g,'total temp,srf.flux,tndcy:',totem/g,
+ccc . surflx(itest,jtest)*delt1,tndcyt*spcifh/g
+c
+c --- store 'old' interface pressures in -pu,pv-
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 882 j=1-margin,jj+margin
+ do 882 k=2,kk+1
+c
+ do 881 l=1,isu(j)
+ do 881 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ 881 pu(i,j,k)=min(depthu(i,j),.5*(p(i,j,k)+p(i-1,j,k)))
+c
+ do 882 l=1,isv(j)
+ do 882 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k)=min(depthv(i,j),.5*(p(i,j,k)+p(i,j-1,k)))
+ 882 continue
+!$OMP END PARALLEL DO
+c
+c --- store 'new' layer thicknesses in -dpu,dpv-
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj ! no margin because p's halo is updated in dpudpv
+ do k=1,kk
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, margin) ! p's halo updated by dpudpv
+c
+c --- redistribute momentum in the vertical.
+c --- homogenize (u,v) over depth range defined in -util1,util2-
+c
+c --- thk>0 activates momentum diffusion across mixed-layer interface
+ thk=vertmx*onem*delt1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 97 j=1-margin,jj+margin
+c
+ do 83 l=1,isu(j)
+c
+ do 822 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ util1(i,j)=max(dpu(i,j,1,n),pu(i,j,2)+thk)
+ uflux(i,j)=0.
+ 822 util3(i,j)=0.
+c
+ do 82 k=1,kk
+ do 82 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ delp=max(0.,min(util1(i,j),pu(i,j,k+1))
+ . -min(util1(i,j),pu(i,j,k )))
+ uflux(i,j)=uflux(i,j)+u(i,j,k,n)*delp
+ 82 util3(i,j)=util3(i,j) +delp
+c
+ do 83 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ u(i,j,1,n)=uflux(i,j)/util3(i,j)
+ 83 continue
+c
+ do 84 l=1,isv(j)
+c
+ do 844 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ util2(i,j)=max(dpv(i,j,1,n),pv(i,j,2)+thk)
+ vflux(i,j)=0.
+ 844 util4(i,j)=0.
+c
+ do 80 k=1,kk
+ do 80 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ delp=max(0.,min(util2(i,j),pv(i,j,k+1))
+ . -min(util2(i,j),pv(i,j,k )))
+ vflux(i,j)=vflux(i,j)+v(i,j,k,n)*delp
+ 80 util4(i,j)=util4(i,j) +delp
+c
+ do 84 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ v(i,j,1,n)=vflux(i,j)/util4(i,j)
+ 84 continue
+c
+ do 97 k=2,kk
+c
+ do 96 l=1,isu(j)
+ do 96 i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ pu(i,j,k)=pu(i,j,k-1)+dpu(i,j,k-1,n)
+ q=max(0.,min(1.,(util1(i,j)-pu(i,j,k))/(dpu(i,j,k,n)+epsil)))
+ 96 u(i,j,k,n)=u(i,j,1,n)*q+u(i,j,k,n)*(1.-q)
+c
+ do 97 l=1,isv(j)
+ do 97 i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ pv(i,j,k)=pv(i,j,k-1)+dpv(i,j,k-1,n)
+ q=max(0.,min(1.,(util2(i,j)-pv(i,j,k))/(dpv(i,j,k,n)+epsil)))
+ v(i,j,k,n)=v(i,j,1,n)*q+v(i,j,k,n)*(1.-q)
+ 97 continue
+!$OMP END PARALLEL DO
+c
+cdiag if (itest.gt.0 .and. jtest.gt.0) write (lp,103) nstep,itest,jtest,
+cdiag. ' exiting mxlayr: temp saln dens thkns dpth',
+cdiag. (k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag. th3d(itest,jtest,k,n)+thbase,dp(itest,jtest,k,n)*qonem,
+cdiag. p(itest,jtest,k+1)*qonem,k=1,kk)
+ return
+ end
+
+ subroutine mxkrtmaj(m,n, sdot, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & sdot
+c
+c --- hycom version 1.0 (adapted from micom version 2.8)
+c
+ integer i,k,ka,l
+c
+ real thknss,ustar3,dpth,ekminv,obuinv,buoyfl,dsgdt,tmn,smn,
+ . ex,alf1,alf2,cp1,cp3,ape,cc4,spe,pnew,alfadt,betads,thet
+c
+ real ea1, ea2, em1, em2, em3, em4, em5
+ data ea1, ea2, em1, em2, em3, em4, em5
+ . /0.60,0.30,0.45,2.60,1.90,2.30,0.60/ ! Gaspar coefficients
+c
+ include 'stmt_fns.h'
+c
+ locsig=.true.
+c
+c --- -----------------------------------
+c --- mixed layer entrainment/detrainment
+c --- -----------------------------------
+c
+ do 85 l=1,isp(j)
+c
+ do 86 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- determine turb.kin.energy generation due to wind stirring
+c --- ustar computed in subr. -thermf-
+c --- buoyancy flux (m**2/sec**3), all fluxes into the ocean
+c --- note: surface density increases (column is destabilized) if buoyfl < 0
+ thknss=dp(i,j,1,n)
+ ustar3=ustar(i,j)**3
+ tmn=.5*(temp(i,j,1,m)+temp(i,j,1,n))
+ smn=.5*(saln(i,j,1,m)+saln(i,j,1,n))
+ dsgdt=dsigdt(tmn,smn)
+ buoyfl=-g*thref*(dsigds(tmn,smn)*salflx(i,j)*thref+
+ & dsgdt *surflx(i,j)*thref/spcifh)
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 1 : k r a u s - t u r n e r mixed-layer t.k.e. closure
+c
+ccc em=0.8*exp(-p(i,j,2)/(50.*onem)) ! hadley centre choice (orig.: 1.25)
+ccc en=0.15 ! hadley centre choice (orig.: 0.4)
+ccc thermg=-.5*g*((en+1.)*buoyfl+(en-1.)*abs(buoyfl))*qthref
+ccc turgen(i,j)=delt1*(2.*em*g*ustar3*qthref+thknss*thermg)*qthref**2
+c
+c --- find monin-obukhov length in case of receding mixed layer (turgen < 0).
+c --- the monin-obukhov length is found by stipulating turgen = 0.
+c --- store temporarily in 'sdot'.
+c
+ccc if (turgen(i,j).lt.0.) then
+ccc sdot(i,j)=-2.*em*g*ustar3/min(-epsil,thref*thermg)
+ccc else
+ccc sdot(i,j)=thknss
+ccc end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- option 2 : g a s p a r mixed-layer t.k.e. closure
+c
+ dpth=thknss*qonem
+ ekminv=1./hekman(i,j)
+ obuinv=buoyfl/max(epsil,ustar3)
+ ex=exp(min(50.,dpth*obuinv))
+ alf1=ea1+ea2*max(1.,2.5*dpth*ekminv)*ex
+ alf2=ea1+ea2*ex
+ cp1=((1.-em5)*(alf1/alf2)+.5*em4)*athird
+ cp3=max(0.,(em4*(em2+em3)-(alf1/alf2)*(em2+em3-em3*em5))*athird)
+ ape=cp3*ustar3-cp1*dpth*buoyfl
+c
+ if(ape.lt.0.) then ! detrainment
+ turgen(i,j)=(g*delt1*qthref**3)*ape
+ sdot(i,j)=max(thkmin*onem,min(thknss,g*cp3/
+ .(thref*cp1*max(epsil,obuinv))))
+c
+ else ! entrainment
+ cc4=2.*em4/(em1*em1) * alf1*alf1
+ spe=(em2+em3)*ustar3-0.5*dpth*buoyfl
+ turgen(i,j)=(g*delt1*qthref**3)*(sqrt((.5*ape-cp1*spe)**2
+ . +2.*cc4*ape*spe)-(.5*ape+cp1*spe))/(cc4-cp1)
+ sdot(i,j)=thknss
+ end if
+c
+c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+c
+c --- util1,util2 are used to evaluate pot.energy changes during entrainment
+ util1(i,j)=th3d(i,j,1,n)*thknss
+ 86 util2(i,j)=th3d(i,j,1,n)*thknss**2
+c
+c --- find pnew in case of mixed layer deepening (turgen > 0). store in 'sdot'.
+c --- entrain as many layers as needed to deplete -turgen-.
+c
+ do 85 k=2,kk
+ ka=k-1
+ do 85 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (k.eq.2) then
+ thstar(i,j,ka,1)=th3d(i,j,ka,n)
+ endif
+ if (locsig) then
+ alfadt=0.5*
+ & (dsiglocdt(temp(i,j,ka,n),saln(i,j,ka,n),p(i,j,k))+
+ & dsiglocdt(temp(i,j,k ,n),saln(i,j,k ,n),p(i,j,k)))*
+ & (temp(i,j,ka,n)-temp(i,j,k,n))
+ betads=0.5*
+ & (dsiglocds(temp(i,j,ka,n),saln(i,j,ka,n),p(i,j,k))+
+ & dsiglocds(temp(i,j,k ,n),saln(i,j,k ,n),p(i,j,k)))*
+ & (saln(i,j,ka,n)-saln(i,j,k,n))
+ thstar(i,j,k,1)=thstar(i,j,ka,1)-alfadt-betads
+ thet=thstar(i,j,k,1)
+ else
+ thet=th3d(i,j,k,n)
+ endif
+ pnew=(2.*turgen(i,j)+thet*p(i,j,k)**2-util2(i,j))/
+ . max(epsil,thet*p(i,j,k) -util1(i,j))
+c --- stop iterating for 'pnew' as soon as pnew < k-th interface pressure
+ if (pnew.lt.p(i,j,k)) pnew=sdot(i,j)
+c --- substitute 'pnew' for monin-obukhov length if mixed layer is deepening
+ if (turgen(i,j).ge.0.) sdot(i,j)=pnew
+c
+ util1(i,j)=util1(i,j)+thet*dp(i,j,k,n)
+ util2(i,j)=util2(i,j)+thet*(p(i,j,k+1)**2-p(i,j,k)**2)
+ 85 continue
+ return
+ end
+
+ subroutine mxkrtmbj(m,n, sdot, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & sdot
+c
+c --- hycom version 1.0 (adapted from micom version 2.8)
+c
+ integer i,k,ktr,l,num
+c
+ real tdp(idm),sdp(idm)
+ real pnew,thknss,t1,s1,tmxl,smxl,
+ . dpn,sn,tn,dtemp,dsaln,tnew,snew,z,s_up,a,e,b,f,d,c1msig,
+ . cc0,cc3,cc1,cc2,x
+c
+ real ccubq,ccubr,ccubqr,ccubs1,ccubs2,ccubrl,ccubim,root,root1,
+ . root2,root3
+c
+ include 'stmt_fns.h'
+c
+c --- cubic eqn. solver used in mixed-layer detrainment
+ ccubq(s)=athird*(cc1/cc3-athird*(cc2/cc3)**2)
+ ccubr(s)=athird*(.5*(cc1*cc2)/(cc3*cc3)-1.5*cc0/cc3)
+ . -(athird*cc2/cc3)**3
+ ccubqr(s)=sqrt(abs(ccubq(s)**3+ccubr(s)**2))
+ ccubs1(s)=sign(abs(ccubr(s)+ccubqr(s))**athird,ccubr(s)+ccubqr(s))
+ ccubs2(s)=sign(abs(ccubr(s)-ccubqr(s))**athird,ccubr(s)-ccubqr(s))
+ root(s)=ccubs1(s)+ccubs2(s)-athird*cc2/cc3
+ ccubrl(s)=sqrt(max(0.,-ccubq(s)))
+ . *cos(athird*atan2(ccubqr(s),ccubr(s)))
+ ccubim(s)=sqrt(max(0.,-ccubq(s)))
+ . *sin(athird*atan2(ccubqr(s),ccubr(s)))
+ root1(s)=2.*ccubrl(s)-athird*cc2/cc3
+ root2(s)=-ccubrl(s)+sqrt(3.)*ccubim(s)-athird*cc2/cc3
+ root3(s)=-ccubrl(s)-sqrt(3.)*ccubim(s)-athird*cc2/cc3
+c
+ do 26 l=1,isp(j)
+c
+ do 42 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c --- store (pnew - pold) in 'sdot'.
+c --- don't allow mixed layer to get too deep or too shallow.
+ sdot(i,j)=min(p(i,j,kk+1),max(thkmin*onem,sdot(i,j)))-
+ . dp(i,j,1,n)
+ klist(i,j)=2
+ tdp(i)=0.
+ 42 sdp(i)=0.
+c
+ do 43 k=2,kk
+ do 43 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ pnew=dp(i,j,1,n)+sdot(i,j)
+c --- 'tdp,sdp' will be needed for temp./salin. mixing during entrainment
+ tdp(i)=tdp(i)+temp(i,j,k,n)*(min(pnew,p(i,j,k+1))
+ . -min(pnew,p(i,j,k )))
+ sdp(i)=sdp(i)+saln(i,j,k,n)*(min(pnew,p(i,j,k+1))
+ . -min(pnew,p(i,j,k )))
+c
+c --- if sdot > 0, remove water from layers about to be entrained.
+ dpold(i,j,k)=dp(i,j,k,n) ! diapyc.flux
+ dp(i,j,k,n)=max(p(i,j,k+1),pnew)-max(p(i,j,k),pnew)
+ diaflx(i,j,k)=diaflx(i,j,k)+(dp(i,j,k,n)-dpold(i,j,k)) ! diapyc.flux
+ if (pnew.ge.p(i,j,k+1)) then
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=0.
+ enddo
+ endif
+c
+c --- if sdot < 0, mixed layer water will be detrained into isopycnic layer
+c --- defined in -klist-. to prevent odd/even time step decoupling of mixed-
+c --- layer depth, determine -klist- from layer one -th3d- at 2 consecutive
+c --- time levels
+c
+ if (max(th3d(i,j,1,m),th3d(i,j,1,n))+sigjmp.ge.th3d(i,j,k,n))
+ . klist(i,j)=k+1
+c
+c --- set t/s in massless layers. step 1: copy salinity from layer(s) above
+c
+ saln(i,j,k,n)=(saln(i,j,k,n)*dp(i,j,k,n)+saln(i,j,k-1,n)*epsil)/
+ . ( dp(i,j,k,n)+ epsil)
+ 43 continue
+c
+c --- set t/s in massless layers. step 2: copy salinity from layer(s) below
+c
+ do 44 k=kk-1,2,-1
+ do 44 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ 44 saln(i,j,k,n)=(saln(i,j,k,n)*dp(i,j,k,n)+saln(i,j,k+1,n)*epsil)/
+ . ( dp(i,j,k,n)+ epsil)
+c
+c --- set t/s in massless layers. step 3: increase salinity where water
+c --- is too fresh to fit into layer k
+c
+ do 45 k=2,kk
+ do 45 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (saln(i,j,k,n).lt.salmin(k)) then
+ saln(i,j,k,n)=salmin(k)
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ end if
+ 45 continue
+c
+c --- redistribute temp. and salin. during both de- and entrainment
+c
+ do 26 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ thknss=dp(i,j,1,n)
+ pnew=thknss+sdot(i,j)
+ t1=temp(i,j,1,n)
+ s1=saln(i,j,1,n)
+c
+ tmxl=t1+surflx(i,j)*delt1*g/(spcifh*thknss)
+ smxl=s1+salflx(i,j)*delt1*g/ thknss
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) write (lp,'(i9,2i5,a,3f7.3,f8.2)')
+cdiag. nstep,i,j,' t,s,sig,dp after diab.forcing',tmxl,smxl,
+cdiag. sig(tmxl,smxl),thknss*qonem
+c
+ if (sdot(i,j).ge.0.) then
+c
+c --- (mixed layer d e e p e n s)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) write (lp,'(i9,2i5,a,f9.3,a)')
+cdiag. nstep,i,j,' entrain',sdot(i,j)*qonem,' m of water'
+c
+ tmxl=(tmxl*thknss+tdp(i))/pnew
+ smxl=(smxl*thknss+sdp(i))/pnew
+ dp(i,j,1,n)=pnew
+ diaflx(i,j,1)=diaflx(i,j,1)+sdot(i,j) ! diapyc.flux
+c
+ else if (sdot(i,j).lt.-onecm.and.surflx(i,j).ge.0.) then ! sdot < 0
+c
+c --- (mixed layer r e c e d e s)
+c
+ k=klist(i,j)
+ if (k.gt.kk) go to 27
+c
+cdiag if (i.eq.itest.and.j.eq.jtest)
+cdiag. write (lp,'(i9,2i5,a,i2,a,3p,2f7.3)') nstep,i,j,
+cdiag. ' sig\*(1),sig\*(',k,') =',th3d(i,j,1,n)+thbase,
+cdiag. th3d(i,j,k,n)+thbase
+c
+ dpn=max(dp(i,j,k,n),0.)
+ sn=saln(i,j,k,n)
+ tn=temp(i,j,k,n)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest)
+cdiag. write (lp,'(i9,2i5,i3,a,2f9.4,f8.2)') nstep,i,j,k,
+cdiag. ' t,s,dp before detrainment',tn,sn,dpn*qonem
+c
+c --- distribute last time step's heating and freshwater flux over depth range
+c --- 'pnew' (monin-obukhov length). split fossil mixed layer (depth= -sdot=
+c --- thknss-pnew) into lower part ('lo') of depth z cooled and detrained into
+c --- layer k, and an upper part ('up') heated to match temperature rise in
+c --- mixed layer. transfer as much salinity as possible from sublayer 'up' to
+c --- sublayer 'lo' without creating new maxima/minima in water column.
+c
+ dtemp=delt1*g*surflx(i,j)/(spcifh*pnew)
+ dsaln=delt1*g*salflx(i,j)/ pnew
+c
+ tnew=t1+dtemp
+ snew=s1+dsaln
+c
+ if (s1.le.sn .and. t1.gt.tn) then
+c
+c --- scenario 1: transfer t/s so as to achieve t_lo = t_k, s_lo = s_k
+c
+ z=-sdot(i,j)*min(1.,dtemp/max(epsil,tnew-tn))*qonem
+ s_up=s1+(s1-sn)*dtemp/max(epsil*dtemp,t1-tn)
+c --- is scenario 1 feasible?
+ if (s_up.ge.min(snew,s1)) go to 24
+ end if ! s_1 < s_n
+c
+c --- scenario 2: (t_lo,s_lo) differ from (tn,sn). main problem now is in
+c --- maintaining density in layer k during detrainment. This requires solving
+c --- 3rd deg. polynomial cc3*z**3 + cc2*z**2 + cc1*z + cc0 = 0 for z.
+c
+ s_up=min(s1,snew)
+c --- new (t,s) in layer k will be t=(a*z+b)/(z+d), s=(e*z+f)/(z+d).
+ a=tnew
+ e=s_up
+ b=(tn*dpn+ dtemp*sdot(i,j))*qonem
+ f=(sn*dpn+(s_up-s1)*sdot(i,j))*qonem
+ d=dpn*qonem
+c
+ c1msig=c1-(th3d(i,j,k,n)+thbase)
+ cc0=d*d*(d*c1msig+b*c2+f*c3)+b*(d*f*c5+b*(d*c4+b*c6+f*c7))
+ cc3= ( c1msig+a*c2+e*c3)+a*( e*c5+a*( c4+a*c6+e*c7))
+ cc1=d*(3. *d*c1msig+(2.*b +a*d)*c2+(2. *f+d*e)*c3)+b*((2.*a*d
+ . +b )*c4+3.*a*b*c6+(2.*a*f+b*e)*c7)+(a*d*f+b*(d*e+ f))*c5
+ cc2= (3. *d*c1msig+(2.*a*d+b )*c2+(2.*d*e+ f)*c3)+a*((2.*b
+ . +a*d)*c4+3.*a*b*c6+(2.*b*e+a*f)*c7)+(b *e+a*( f+d*e))*c5
+c --- bound cc3 away from zero
+ cc3=sign(max(1.e-6,abs(cc3)),cc3)
+c
+ x=0.0 ! dummy argument that is never used
+ if (ccubq(x)**3+ccubr(x)**2.gt.0.) then
+c --- one real root
+ num=1
+ z=root(x)
+ else
+c --- three real roots
+ num=3
+ z=root1(x)
+ end if
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag work(1)=z
+cdiag if (num.eq.3) then
+cdiag work(2)=root2(x)
+cdiag work(3)=root3(x)
+cdiag end if
+cdiag write (lp,100) nstep,i,j,' t,s,dp( 1)=',tnew,snew,
+cdiag. thknss*qonem,'sdot,z=',sdot(i,j)*qonem,z,'t,s,dp(',k,')=',tn,
+cdiag. sn,dpn*qonem,'real root(s):',(work(nu),nu=1,num)
+cdiag end if
+ 100 format (i9,2i5,a,2f7.3,f8.2,3x,a,2f8.2/20x,a,i2,a,2f7.3,f8.2,
+ . 3x,a,1p3e11.4)
+c
+c --- does root fall into appropriate range?
+ if (z.le.0.005) go to 27
+c
+c --- ready to detrain lowest 'z' meters from mixed layer
+c
+ temp(i,j,k,n)=(a*z+b)/(z+d)
+ saln(i,j,k,n)=(e*z+f)/(z+d)
+c
+ 24 sdot(i,j)=max(sdot(i,j),-z*onem)
+ dp(i,j,1,n)=thknss+sdot(i,j)
+ dp(i,j,k,n) =dpn -sdot(i,j)
+ smxl=(snew*pnew+s_up*(dp(i,j,1,n)-pnew))/dp(i,j,1,n)
+ tmxl=tnew
+ diaflx(i,j,1)=diaflx(i,j,1)+sdot(i,j) ! diapyc.flux
+ diaflx(i,j,k)=diaflx(i,j,k)-sdot(i,j) ! diapyc.flux
+c
+c --- inject 'ventilation' tracer into layer k
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=(tracer(i,j,k,n,ktr)*dpn-sdot(i,j))
+ & /(dpn-sdot(i,j))
+ enddo
+c
+cdiag if (i.eq.itest.and.j.eq.jtest)
+cdiag. write (lp,'(i9,2i5,i3,a,2f9.4,f8.2)') nstep,i,j,k,
+cdiag. ' t,s,dp after detrainment',temp(i,j,k,n),saln(i,j,k,n),
+cdiag. dp(i,j,k,n)*qonem
+c
+ end if ! sdot > or < 0
+c
+ 27 temp(i,j,1,n)=tmxl
+ saln(i,j,1,n)=smxl
+ th3d(i,j,1,n)=sig(tmxl,smxl)-thbase
+ do ktr= 1,ntracr
+ tracer(i,j,1,n,ktr)=1.0
+ enddo
+c
+ dpmixl(i,j,n)=dp( i,j,1,n)
+ dpbl( i,j) =dp( i,j,1,n)
+ tmix( i,j) =temp(i,j,1,n)
+ smix( i,j) =saln(i,j,1,n)
+ thmix( i,j) =th3d(i,j,1,n)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) write
+cdiag. (lp,'(i9,2i5,i3,a,2f9.4,f8.2)') nstep,i,j,1,
+cdiag. ' final mixed-layer t,s,dp ',tmxl,smxl,dp(i,j,1,n)*qonem
+c
+ 26 continue
+ return
+ end
+c
+c
+c> Revision history:
+c>
+c> June 1995 - removed restriction 'klist(i,j) .le. kk'
+c> June 1995 - added code for setting t/s in massless layers below mix.layer
+c> Oct. 1995 - removed bug created while changing klist (June 1995 revision):
+c> 'if (k.gt.kk) go to 26' now reads 'if (k.gt.kk) go to 27'
+c> May 1997 - changed -sdot- into local array
+c> Mar. 1998 - added -th3d-
+c> Nov. 1998 - fixed bug in computing tnew,snew in situations where z < 0.005
+c> Dec. 1998 - replaced dsaln by (s_up-s1) in definition of 'f'
+c> Feb. 1999 - limited 'tofsig' call in loop 45 to cases where saln < salmin
+c> Aug. 2000 - adapted from micom 2.8 to run within hycom 1.0
+c> May 2002 - buoyfl (into the ocean), calculated here
diff --git a/src_2.2.18_3_one/mxpwp.f b/src_2.2.18_3_one/mxpwp.f
new file mode 100755
index 0000000..7a0fced
--- /dev/null
+++ b/src_2.2.18_3_one/mxpwp.f
@@ -0,0 +1,845 @@
+ subroutine mxpwp(m,n)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c -------------------------------------------------------------------
+c --- price-weller-pinkel dynamical instability vertical mixing model
+c -------------------------------------------------------------------
+c
+c --- background diapycnal mixing is provided by the explicit diapycnal
+c --- mixing model, subroutine diapf2
+c
+ integer i,j,k,l
+ real delp,sigmlj
+c
+ include 'stmt_fns.h'
+c
+ call xctilr(u( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_uv)
+ call xctilr(v( 1-nbdy,1-nbdy,1,n),1,kk, 1,1, halo_vv)
+ call xctilr(p( 1-nbdy,1-nbdy,2 ),1,kk, 1,1, halo_ps)
+c
+ margin = 0 ! no horizontal derivatives
+c
+c --- diffisuvity/viscosity calculation
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxpwpaj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- final velocity mixing at u,v points
+c
+ call xctilr(vcty(1-nbdy,1-nbdy,1),1,kk, 1,1, halo_ps)
+ call xctilr(dpbl(1-nbdy,1-nbdy), 1, 1, 1,1, halo_ps)
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call mxpwpbj(m,n, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- mixed layer diagnostics
+c
+ if (diagno) then
+c
+c --- diagnose new mixed layer depth based on density jump criterion
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,sigmlj)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+c
+c --- depth of mixed layer base set to interpolated depth where
+c --- the density jump is equivalent to a tmljmp temperature jump.
+c --- this may not vectorize, but is used infrequently.
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ sigmlj = -tmljmp*dsigdt(temp(i,j,1,n),saln(i,j,1,n))
+ sigmlj = max(sigmlj,tmljmp*0.1) !cold-water fix
+ do k=2,kk
+ if (p(i,j,k+1).ge.p(i,j,kk+1)-onem) then
+ dpmixl(i,j,n) = p(i,j,k+1)
+ exit !k
+ elseif ((th3d(i,j,k,n)-th3d(i,j,1,n)).ge.sigmlj) then
+ dpmixl(i,j,n)=max(dp(i,j,1,n),
+ & p(i,j,k) + dp(i,j,k,n)*
+ & (th3d(i,j,1,n)+sigmlj-th3d(i,j,k-1,n))/
+ & (th3d(i,j,k,n) +epsil-th3d(i,j,k-1,n)) )
+ exit
+ endif
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ call xctilr(p( 1-nbdy,1-nbdy,2),1,kk, 1,1, halo_ps)
+ call xctilr(dpmixl(1-nbdy,1-nbdy,n),1, 1, 1,1, halo_ps)
+c
+c --- calculate bulk mixed layer t, s, theta
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+c
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ dpmixl(i,j,m)=dpmixl(i,j,n)
+ tmix(i,j)=temp(i,j,1,n)*dp(i,j,1,n)
+ smix(i,j)=saln(i,j,1,n)*dp(i,j,1,n)
+ enddo !i
+c
+ do k=2,kk
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ delp=min(p(i,j,k+1),dpmixl(i,j,n))
+ & -min(p(i,j,k ),dpmixl(i,j,n))
+ tmix(i,j)=tmix(i,j)+delp*temp(i,j,k,n)
+ smix(i,j)=smix(i,j)+delp*saln(i,j,k,n)
+ enddo !i
+ enddo !k
+c
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ tmix(i,j)=tmix(i,j)/dpmixl(i,j,n)
+ smix(i,j)=smix(i,j)/dpmixl(i,j,n)
+ thmix(i,j)=sig(tmix(i,j),smix(i,j))-thbase
+ enddo !i
+c
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+c --- calculate bulk mixed layer u
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+c
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ umix(i,j)=u(i,j,1,n)*2.*dpu(i,j,1,n)
+ enddo
+c
+ do k=2,kk
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ delp=
+ & (min(p(i,j,k+1)+p(i-1,j,k+1),
+ & dpmixl(i,j,n)+dpmixl(i-1,j,n))
+ & -min(p(i,j,k )+p(i-1,j,k ),
+ & dpmixl(i,j,n)+dpmixl(i-1,j,n)))
+ umix(i,j)=umix(i,j)+delp*u(i,j,k,n)
+ enddo
+ enddo
+c
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ umix(i,j)=umix(i,j)/(dpmixl(i,j,n)+dpmixl(i-1,j,n))
+ enddo
+c
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- calculate bulk mixed layer v
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,delp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isv(j)
+c
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vmix(i,j)=v(i,j,1,n)*2.*dpv(i,j,1,n)
+ enddo
+c
+ do k=2,kk
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ delp=
+ & (min(p(i,j,k+1)+p(i,j-1,k+1),
+ & dpmixl(i,j,n)+dpmixl(i,j-1,n))
+ & -min(p(i,j,k )+p(i,j-1,k ),
+ & dpmixl(i,j,n)+dpmixl(i,j-1,n)))
+ vmix(i,j)=vmix(i,j)+delp*v(i,j,k,n)
+ enddo
+ enddo
+c
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ vmix(i,j)=vmix(i,j)/(dpmixl(i,j,n)+dpmixl(i,j-1,n))
+ enddo
+c
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ endif ! diagno
+c
+ return
+ end
+ subroutine mxpwpaj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- calculate viscosity and diffusivity
+c
+ integer i,l
+c
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ call mxpwpaij(m,n, i,j)
+ enddo
+ enddo
+c
+ return
+ end
+c
+ subroutine mxpwpbj(m,n, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+c
+c --- final velocity mixing at u,v points
+c
+ integer i,l
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ call mxpwpbiju(m,n, i,j)
+ enddo
+ enddo
+c
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ call mxpwpbijv(m,n, i,j)
+ enddo
+ enddo
+c
+ return
+ end
+c
+ subroutine mxpwpaij(m,n, i,j)
+ use mod_xc ! HYCOM communication interface
+c
+c --- hycom version 2.1
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, i,j
+c
+c ----------------------------------------------
+c --- pwp vertical mixing, single j-row (part A)
+c ----------------------------------------------
+c
+c local variables for pwp mixing
+ real swfrac(kdm+1) ! fractional surface shortwave radiation flux
+c
+ real t1d(kdm),s1d(kdm),th1d(kdm),tr1d(kdm,mxtrcr),
+ & dp1d(kdm),p1d(kdm+1),u1d(kdm),v1d(kdm),rig(kdm+1)
+c
+ real dtemp,dsaln,rib,rigf,rig1,rig2,told,sold,trold,uold,vold,
+ & sflux1,tsum,ssum,trsum,usum,vsum,dpsum,tup,sup,thup,
+ & alfadt,betads,
+ & beta_b,beta_r,frac_b,frac_r,swfbqp
+c
+ integer k,k1,k2,k3,k10,kmax,kmlb,kmlb1,kintf,ktr,iter,jrlv
+c
+ include 'stmt_fns.h'
+c
+c -----------------------------------------------------------
+c --- set 1-d arrays and locate deepest mass-containing layer
+c -----------------------------------------------------------
+c
+ p1d(1)=0.0
+ do k=1,kk
+ t1d (k)=temp(i,j,k,n)
+ s1d (k)=saln(i,j,k,n)
+ th1d(k)=sig(t1d(k),s1d(k))-thbase
+ do ktr= 1,ntracr
+ tr1d(k,ktr)=tracer(i,j,k,n,ktr)
+ enddo
+ dp1d(k)=dp(i,j,k,n)
+ p1d(k+1)=p1d(k)+dp1d(k)
+ u1d (k)=0.5*(u(i ,j, k,n)+u(i+1,j ,k,n))
+ v1d (k)=0.5*(v(i ,j ,k,n)+v(i ,j+1,k,n))
+ enddo !k
+c
+ do k=kk,1,-1
+ if (dp1d(k).gt.tencm) then
+ exit !k
+ endif
+ enddo !k
+ kmax=max(k,2) !always consider at least 2 layers
+c
+c ---------------------------------
+c --- distribute surface t,s fluxes
+c ---------------------------------
+c
+c --- forcing of t,s by surface fluxes. flux positive into ocean.
+c --- shortwave flux penetration depends on kpar or jerlov water type.
+c
+ if (jerlv0.eq.0) then
+ beta_r = qonem*0.5
+ beta_b = qonem*( akpar(i,j,lk0)*wk0+akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2+akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ frac_r = 1.0 - frac_b
+ else
+ jrlv = jerlov(i,j)
+ beta_r = betard(jrlv)
+ beta_b = betabl(jrlv)
+ frac_r = redfac(jrlv)
+ frac_b = 1.0 - frac_r
+ endif
+c
+c --- evenly re-distribute the flux below the bottom
+ k = kk
+ if (-p1d(k+1)*beta_r.gt.-10.0) then
+ swfbqp=frac_r*exp(-p1d(k+1)*beta_r)+
+ & frac_b*exp(-p1d(k+1)*beta_b)
+ elseif (-p1d(k+1)*beta_b.gt.-10.0) then
+ swfbqp=frac_b*exp(-p1d(k+1)*beta_b)
+ else
+ swfbqp=0.0
+ endif
+ swfbqp = swfbqp/p1d(k+1)
+c
+ do k=1,kk
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+ if (pensol) then
+ if (-p1d(k+1)*beta_r.gt.-10.0) then
+ swfrac(k+1)=frac_r*exp(-p1d(k+1)*beta_r)+
+ & frac_b*exp(-p1d(k+1)*beta_b)
+ elseif (-p1d(k+1)*beta_b.gt.-10.0) then
+ swfrac(k+1)=frac_b*exp(-p1d(k+1)*beta_b)
+ else
+ swfrac(k+1)=0.0
+ endif
+ swfrac(k+1)=swfrac(k+1)-swfbqp*p1d(k+1) !spread out bottom frac
+ endif !pensol
+ if (k.eq.1) then
+ if (pensol) then
+ sflux1=surflx(i,j)-sswflx(i,j)
+ dtemp=(sflux1+(1.-swfrac(k+1))*sswflx(i,j))*delt1*g/
+ & (spcifh*max(onemm,dp1d(k)))
+ dsaln=salflx(i,j) *delt1*g/
+ & (max(onemm,dp1d(k)))
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,100)
+cdiag& nstep,i+i0,j+j0,k,0.,1.-swfrac(k+1),dtemp,dsaln
+cdiag call flush(lp)
+cdiag endif
+ 100 format(i9,2i5,i3,'absorbup,dn,dtemp,dsaln ',2f6.3,2f10.6)
+ else !.not.pensol
+ dtemp=surflx(i,j)*
+ & delt1*g/(spcifh*max(onemm,dp1d(k)))
+ dsaln=salflx(i,j)*
+ & delt1*g/( max(onemm,dp1d(k)))
+ endif
+ elseif (k.le.kmax) then
+ if (pensol) then
+ dtemp=(swfrac(k)-swfrac(k+1))*sswflx(i,j)*delt1*g/
+ & (spcifh*max(onemm,dp1d(k)))
+ dsaln=0.
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write (lp,100)
+cdiag& nstep,i+i0,j+j0,k,1.-swfrac(k),1.-swfrac(k+1),dtemp
+cdiag call flush(lp)
+cdiag endif
+ else !.not.pensol
+ dtemp=0.0
+ dsaln=0.0
+ endif
+ else !k.gt.kmax
+ dtemp=0.0
+ dsaln=0.0
+ endif
+ else !.not.thermo ...
+ dtemp=0.0
+ dsaln=0.0
+ endif !thermo.or.sstflg.gt.0.or.srelax:else
+c
+ t1d(k)=t1d(k)+dtemp
+ s1d(k)=s1d(k)+dsaln
+ th1d(k)=sig(t1d(k),s1d(k))-thbase
+ enddo !k
+c
+c ----------------------------------------------
+c --- Don't use PWP when relaxing to climatology
+c ----------------------------------------------
+c
+ if (rmu(i,j).ne.0.0) then
+ kmlb=kmax
+ do k=2,kmax
+ if (p1d(k).gt.thkmin*onem) then
+ kmlb=k-1
+ exit !k
+ endif
+ enddo !k
+ dpbl(i,j)=p1d(kmlb+1)
+ do k=1,kmax
+ temp(i,j,k,n)=t1d(k)
+ saln(i,j,k,n)=s1d(k)
+ th3d(i,j,k,n)=sig(t1d(k),s1d(k))-thbase
+ enddo !k
+ return
+ endif
+c
+c ------------------------------------------
+c --- relieve mixed layer static instability
+c ------------------------------------------
+c
+ kmlb=1
+ tsum=t1d(1)*dp1d(1)
+ ssum=s1d(1)*dp1d(1)
+ dpsum=dp1d(1)
+ do k=2,kmax
+ if (locsig) then
+ tup=tsum/dpsum
+ sup=ssum/dpsum
+ alfadt=0.5*(dsiglocdt(tup,sup,dpsum)+
+ & dsiglocdt(t1d(k),s1d(k),dpsum))*(tup-t1d(k))
+ betads=0.5*(dsiglocds(tup,sup,dpsum)+
+ & dsiglocds(t1d(k),s1d(k),dpsum))*(sup-s1d(k))
+ if (alfadt+betads.gt.0.0) then
+ kmlb=k
+ tsum=tsum+t1d(k)*dp1d(k)
+ ssum=ssum+s1d(k)*dp1d(k)
+ dpsum=dpsum+dp1d(k)
+ else
+ exit !k
+ endif
+ else
+ thup=sig(tsum/dpsum,ssum/dpsum)-thbase
+ if (th1d(k).lt.thup) then
+ kmlb=k
+ tsum=tsum+t1d(k)*dp1d(k)
+ ssum=ssum+s1d(k)*dp1d(k)
+ dpsum=dpsum+dp1d(k)
+ else
+ exit !k
+ endif
+ endif
+ enddo !k
+c
+ if (kmlb.gt.1) then
+ t1d(1)=tsum/dpsum
+ s1d(1)=ssum/dpsum
+ th1d(1)=sig(t1d(1),s1d(1))-thbase
+ do k=2,kmlb
+ t1d(k)=t1d(1)
+ s1d(k)=s1d(1)
+ th1d(k)=th1d(1)
+ do ktr= 1,ntracr
+ tr1d(k,ktr)=1.0
+ enddo !ktr
+c
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write (lp,101) nstep,i+i0,j+j0,k,kmlb,
+cdiag& ' relieve static instability - t,s,th:',
+cdiag& t1d(k),s1d(k),tr1d(k,1)
+cdiag call flush(lp)
+cdiag endif
+ 101 format (i9,2i5,2i3,a/9x,3f9.4)
+ enddo !k
+ endif !kmlb>1
+c
+c --- diagnose depth of mixed layer base and homogenize
+ call mlbdep(t1d,s1d,th1d,tr1d,u1d,v1d,p1d,dp1d,kmlb,kmax)
+c
+c ---------------------------------
+c --- bulk richardson number mixing
+c ---------------------------------
+c
+c --- mixing within the layer containing the mixed layer base
+ kmlb1=kmlb+1
+ tsum=t1d(1)*p1d(kmlb1)
+ ssum=s1d(1)*p1d(kmlb1)
+ usum=u1d(1)*p1d(kmlb1)
+ vsum=v1d(1)*p1d(kmlb1)
+ k10=kmlb
+ do k=kmlb1,kmax
+ k1=k-1
+ k2=k+1
+ if (locsig) then
+ alfadt=0.5*(dsiglocdt(t1d(k1),s1d(k1),p1d(k))+
+ & dsiglocdt(t1d(k ),s1d(k ),p1d(k)))*
+ & (t1d(k1)-t1d(k))
+ betads=0.5*(dsiglocds(t1d(k1),s1d(k1),p1d(k))+
+ & dsiglocds(t1d(k ),s1d(k ),p1d(k)))*
+ & (s1d(k1)-s1d(k))
+ rib=-g*thref*p1d(k)*min(0.0,alfadt+betads)/
+ & (onem*max(1.e-8,(u1d(k)-u1d(k1))**2+(v1d(k)-v1d(k1))**2))
+ else
+ rib=g*thref*p1d(k)*max(0.0,th1d(k)-th1d(k1))/
+ & (onem*max(1.e-8,(u1d(k)-u1d(k1))**2+(v1d(k)-v1d(k1))**2))
+ endif
+c
+c --- if rib indicates instability, mix downward to the next interface
+ if (rib.lt.ribc.and.p1d(kk+1)-p1d(k+1).ge.tencm) then
+c
+ tsum=tsum+t1d(k)*dp1d(k)
+ ssum=ssum+s1d(k)*dp1d(k)
+ do ktr= 1,ntracr
+ tr1d(k,ktr)=1.0
+ enddo
+ usum=usum+u1d(k)*dp1d(k)
+ vsum=vsum+v1d(k)*dp1d(k)
+c
+ t1d(1)=tsum/p1d(k2)
+ s1d(1)=ssum/p1d(k2)
+ th1d(1)=sig(t1d(1),s1d(1))-thbase
+ u1d(1)=usum/p1d(k2)
+ v1d(1)=vsum/p1d(k2)
+c
+ do k3=2,k
+ t1d (k3)=t1d (1)
+ s1d (k3)=s1d (1)
+ th1d(k3)=th1d(1)
+ do ktr= 1,ntracr
+ tr1d(k3,ktr)=1.0
+ enddo
+ u1d (k3)=u1d (1)
+ v1d (k3)=v1d (1)
+c
+cdiag if (i.eq.itest .and. j.eq.jtest .and. k3.eq.k10) then
+cdiag write (lp,102) nstep,i+i0,j+j0,k,k1,k2,k3,kmlb,
+cdiag& ' bulk ri mixing - rib,t,s,th:',min(1000.0,rib),
+cdiag& t1d(k3),s1d(k3),th1d(k3)
+cdiag call flush(lp)
+cdiag endif
+ 102 format (i9,2i5,5i3,a/9x,4f9.4)
+c
+ enddo
+ kmlb=k
+ else
+ exit !k
+ endif
+ enddo !k
+c
+c --- diagnose depth of mixed layer base and homogenize
+ call mlbdep(t1d,s1d,th1d,tr1d,u1d,v1d,p1d,dp1d,kmlb,kmax)
+c
+c -------------------------------------
+c --- gradient richardson number mixing
+c -------------------------------------
+c
+c --- use array 'vcty' to store gradient Ri mixing factor for u,v mixing
+c
+ do k=1,kk+1
+ vcty(i,j,k)=0.0
+ enddo
+c
+c --- perform up to 5 iterations
+ do iter=1,5
+c
+c --- calculate rig array
+c
+ do k=kmlb+1,kmax
+ k1=k-1
+ if (locsig) then
+ alfadt=0.5*(dsiglocdt(t1d(k1),s1d(k1),p1d(k))+
+ & dsiglocdt(t1d(k ),s1d(k ),p1d(k)))*
+ & (t1d(k1)-t1d(k))
+ betads=0.5*(dsiglocds(t1d(k1),s1d(k1),p1d(k))+
+ & dsiglocds(t1d(k ),s1d(k ),p1d(k)))*
+ & (s1d(k1)-s1d(k))
+ rig(k)=-g*min(dp1d(k1),dp1d(k))*thref*
+ & min(-1.0e-3,alfadt+betads)/(onem*
+ & max( 1.0e-6,(u1d(k1)-u1d(k))**2+(v1d(k1)-v1d(k))**2))
+ else
+ rig(k)=g*min(dp1d(k1),dp1d(k))*thref*
+ & max(1.0e-3,th1d(k)-th1d(k1))/(onem*
+ & max(1.0e-6,(u1d(k1)-u1d(k))**2+
+ & (v1d(k1)-v1d(k))**2))
+ endif
+cdiag if (i.eq.itest .and. j.eq.jtest) then
+cdiag write(6,103) nstep,i+i0,j+j0,k,iter,th1d(k1)+thbase,
+cdiag& th1d(k)+thbase,
+cdiag& (u1d(k1)-u1d(k))**2+
+cdiag& (v1d(k1)-v1d(k))**2,rig(k),
+cdiag& dp1d(k1)/onem,dp1d(k)/onem
+cdiag call flush(lp)
+cdiag endif
+ 103 format('rig(k)',i9,2i5,2i3,1p,6e13.5)
+ enddo !k
+c
+c --- identify interface where rig has a vertical minimum at each grid point
+ kintf=0
+ rig2=huge
+ do k=kmlb+1,kmax
+ if(rig(k).lt.rig2) then
+ kintf=k
+ rig2=rig(k)
+ end if
+ enddo !k
+c
+c --- if selected layer pair is unstable, mix to bring rig up to rigc
+c --- store factor rig1 in array vcty for u,v mixing
+ if(rig2.lt.rigc) then
+ k=kintf
+ rig1=1.-rig2/rigc
+ vcty(i,j,k)=rig1
+c
+ rigf=rig1*(t1d(k-1)-t1d(k))
+ told=t1d(k-1)
+ t1d(k-1)=t1d(k-1)-rigf*dp1d(k )/max(epsil,dp1d(k-1)+dp1d(k))
+ t1d(k )=t1d(k )+rigf*dp1d(k-1)/max(epsil,dp1d(k-1)+dp1d(k))
+cdiag if (i.eq.itest .and. j.eq.jtest.and.mnproc.eq.1) then
+cdiag if(k.gt.15.and.k.lt.22) then
+cdiag write(6,104) nstep,i+i0,j+j0,k,rigf,rig1,t1d(k-1),t1d(k),
+cdiag& dp1d(k-1)/onem,dp1d(k)/onem,
+cdiag& dp1d(min(kk,k+1))/onem
+cdiag call flush(lp)
+cdiag endif
+ 104 format('rig mixing',i9,2i5,i3,1p,7e13.5)
+c
+ rigf=rig1*(s1d(k-1)-s1d(k))
+ sold=s1d(k-1)
+ s1d(k-1)=s1d(k-1)-rigf*dp1d(k )/max(epsil,dp1d(k-1)+dp1d(k))
+ s1d(k )=s1d(k )+rigf*dp1d(k-1)/max(epsil,dp1d(k-1)+dp1d(k))
+c
+ th1d(k-1)=sig(t1d(k-1),s1d(k-1))-thbase
+ th1d(k )=sig(t1d(k ),s1d(k ))-thbase
+c
+ do ktr= 1,ntracr
+ rigf=rig1*(tr1d(k-1,ktr)-tr1d(k,ktr))
+ trold=tr1d(k-1,ktr)
+ tr1d(k-1,ktr)=tr1d(k-1,ktr)-rigf*dp1d(k )/
+ & max(epsil,dp1d(k-1)+dp1d(k))
+ tr1d(k ,ktr)=tr1d(k ,ktr)+rigf*dp1d(k-1)/
+ & max(epsil,dp1d(k-1)+dp1d(k))
+ enddo !ktr
+c
+ rigf=rig1*(u1d(k-1)-u1d(k))
+ uold=u1d(k-1)
+ u1d(k-1)=u1d(k-1)-rigf*dp1d(k )/max(epsil,dp1d(k-1)+dp1d(k))
+ u1d(k )=u1d(k )+rigf*dp1d(k-1)/max(epsil,dp1d(k-1)+dp1d(k))
+c
+ rigf=rig1*(v1d(k-1)-v1d(k))
+ vold=v1d(k-1)
+ v1d(k-1)=v1d(k-1)-rigf*dp1d(k )/max(epsil,dp1d(k-1)+dp1d(k))
+ v1d(k )=v1d(k )+rigf*dp1d(k-1)/max(epsil,dp1d(k-1)+dp1d(k))
+c
+ end if !rig2 Revision history:
+c>
+c> Mar 2004: minimum layer thickness used to calculate gradient Ri
diff --git a/src_2.2.18_3_one/overtn.f b/src_2.2.18_3_one/overtn.f
new file mode 100755
index 0000000..def4a71
--- /dev/null
+++ b/src_2.2.18_3_one/overtn.f
@@ -0,0 +1,91 @@
+ subroutine overtn(dtime,dyear)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ real*8 dtime,dyear
+c
+c --- diagnose meridional heat flux in basin model
+c
+ real*8 dsmall
+ parameter (dsmall=0.001d0)
+c
+ integer i,j,k,l,noo
+c
+ logical lfirst
+ save lfirst
+ data lfirst / .true. /
+c
+ real*8 anum(jtdm),heatf(jtdm),heatfl(jtdm),hfxzon(jtdm),
+ & zonavt(jtdm,kdm),zonavf(jtdm,kdm)
+ save anum,heatfl,hfxzon,zonavt,zonavf
+c
+c --- integrate meridional heat fluxes vertically and in zonal direction
+ do j=1,jtdm
+ hfxzon(j)=0.
+ heatfl(j)=0.
+ enddo
+c
+ do k=1,kk
+ do j=1,jj
+ do i=1,ii
+ if (iv(i,j).ne.0) then
+ util1(i,j) = (temp(i,j,k,1)+temp(i,j-1,k,1))
+ util2(i,j) = vflx(i,j,k)
+ util3(i,j) = (temp(i,j,k,1)+temp(i,j-1,k,1))*vflx(i,j,k)
+ endif
+ enddo
+ enddo
+ call xcsumj(zonavt(1,k), util1,iv)
+ call xcsumj(zonavf(1,k), util2,iv)
+ call xcsumj(heatf, util3,iv)
+ if (lfirst) then
+ util4 = 1.0
+ call xcsumj(anum, util4,iv)
+ endif
+ if (mnproc.eq.1) then
+ do j=1,jtdm
+ if (anum(j).ne.0.0) then
+ heatfl(j)=heatfl(j)+heatf(j)
+ hfxzon(j)=hfxzon(j)+zonavt(j,k)*zonavf(j,k)/anum(j)
+ endif
+ enddo
+ endif
+ enddo
+ if (mnproc.eq.1) then
+ do j= 1,jtdm
+ hfxzon(j)=.5*hfxzon(j)*spcifh/g * 1.e-15
+ heatfl(j)=.5*heatfl(j)*spcifh/g * 1.e-15
+ enddo
+cdiag print 999, nstep,vflx(31,11,11)
+cdiag 999 format(' overtn - nstep,vflx=',i10,d20.12)
+c
+c --- save everything in a special file
+ noo=26
+c
+ if (lfirst) then
+ open (unit=noo,file=flnmovr,status='new',form='formatted')
+ endif
+c
+ write (noo,'(a,f10.2,i6,f7.2)')
+ & ' time,year,day =',dtime,int((dtime+dsmall)/dyear),
+ & mod(dtime+dsmall, dyear)
+ write (noo,'(a/(11f7.3))')
+ & ' northward heat flux (petawatts):', (heatfl(j),j=1,jtdm-1)
+ write (noo,'(a/(11f7.3))')
+ & ' meridional overturning component:',(hfxzon(j),j=1,jtdm-1)
+ call flush(noo)
+c
+ write (lp, '(a/(11f7.3))')
+ & ' northward heat flux (petawatts):', (heatfl(j),j=1,jtdm-1)
+ call flush(lp)
+ endif
+ call xcsync(flush_lp)
+c
+ lfirst = .false.
+c
+ return
+ end subroutine overtn
+
+
diff --git a/src_2.2.18_3_one/poflat.f b/src_2.2.18_3_one/poflat.f
new file mode 100755
index 0000000..0bf00c8
--- /dev/null
+++ b/src_2.2.18_3_one/poflat.f
@@ -0,0 +1,155 @@
+ subroutine profile_lat(theta,press,xlat)
+ implicit none
+c
+ real theta,press,xlat
+c
+ integer lp
+ common/linepr/ lp
+ save /linepr/
+c
+c --- this routine returns either:
+c
+c --- pressure as function of density and latitude
+c --- density as function of pressure and latitude
+c
+c --- set press < 0.0 on input to return pressure
+c
+c --- typically invoked via either poflat or roflat.
+c
+ integer ix,kz
+ real p1,p2,pinthi,pintlo,pz,thet,thetlo,thethi,x,xla,z
+c
+ integer kdpth,klat
+ parameter (kdpth=14,klat=21) ! kdpth>1, klat>3
+c
+ real onem,thet1,thet2,dthet,xlat1,xlat2,dlat
+ real pdat(kdpth,klat)
+c
+ data onem/9806./ ! SI units
+ data thet1,thet2,dthet/22.0,28.5,0.5/
+ data xlat1,xlat2,dlat/-30.,70.,5./
+c
+c--- depth (m) of isopycnals of potential density 22.0, 22.5, ... , 28.5
+c--- at latitudes 30s ... 70n for ATLd (source: levitus atlas)
+c
+ data pdat /
+ + 0.,0., 0., 0., 0., 0., 1., 23.,158.,257.,575.,1009.,8100.,8100. !30s
+ +,0.,0., 0., 0., 0., 0., 1., 28.,160.,252.,560., 969.,8100.,8100. !25s
+ +,0.,0., 0., 0., 0., 0., 0., 40.,159.,233.,478., 913.,8100.,8100. !20s
+ +,0.,0., 0., 0., 0., 0.,22., 78.,147.,194.,388., 968.,8100.,8100. !15s
+ +,0.,0., 0., 0., 3.,38.,79., 98.,120.,156.,336.,1033.,8100.,8100. !10s
+ +,0.,0., 0., 0.,21.,39.,67., 73., 92.,134.,376., 946.,8100.,8100. ! 5s
+ +,1.,1., 1., 5.,36.,51.,62., 71., 86.,121.,407., 873.,8100.,8100. ! 0
+ +,2.,3., 9.,46.,56.,65.,76., 85., 99.,134.,318., 879.,8100.,8100. ! 5n
+ +,3.,5.,10.,24.,45.,60.,72., 86.,104.,137.,283., 929.,8100.,8100. !10n
+ +,1.,3., 8.,17.,40.,60.,93.,112.,142.,187.,350., 868.,8100.,8100. !15n
+ +,0.,0., 2.,20.,34.,47.,69.,112.,154.,224.,446., 794.,8100.,8100. !20n
+ +,0.,0., 2., 6.,16.,27.,42., 68.,131.,217.,527., 772.,8100.,8100. !25n
+ +,0.,1., 1., 3., 6.,15.,24., 42., 77.,193.,557., 761.,8100.,8100. !30n
+ +,0.,0., 0., 0., 1., 7.,15., 26., 48.,105.,389., 622.,8100.,8100. !35n
+ +,0.,0., 0., 0., 1., 6., 9., 19., 38., 72.,227., 617.,8100.,8100. !40n
+ +,0.,0., 0., 0., 1., 3., 5., 9., 21., 55., 87., 607.,8100.,8100. !45n
+ +,0.,0., 0., 1., 1., 2., 3., 5., 8., 28., 78., 353.,8100.,8100. !50n
+ +,0.,0., 0., 0., 0., 0., 0., 1., 3., 8., 36., 165.,8100.,8100. !55n
+ +,0.,0., 0., 0., 0., 0., 0., 0., 1., 3., 12., 132.,1367.,8100. !60n
+ +,0.,0., 0., 0., 0., 0., 0., 1., 3., 9., 30., 90., 422.,8100. !65n
+ +,0.,0., 0., 0., 0., 0., 0., 0., 1., 2., 9., 32., 239.,8100. !70n
+ +/
+c
+c--- quasi-hermite interpolation function (0 < xx < 1)
+c
+ real parabl,xx,a,b,c
+ parabl(xx,a,b,c)=b+.5*xx*(c-a+xx*(a+c-b-b))
+c
+ xla=(xlat-xlat1)/dlat+1.
+ ix=max(2,min(klat-2,int(xla)))
+ x=max(0.,min(1.,xla-float(ix)))
+c
+ if (press.lt.0.0) then
+c
+c ---- pressure from density.
+c
+ thet=(theta-thet1)/dthet+1.
+ if (thet.lt.1.0) then
+ press=0.0
+ else ! normal case
+ kz=max(1,min(kdpth-1,int(thet)))
+ z=max(0.,min(1.,thet-float(kz)))
+c
+c --- horizontal/vertical interpolation: quasi-hermite/linear
+c
+ p1=parabl( x,pdat(kz ,ix-1),pdat(kz ,ix ),pdat(kz ,ix+1))
+ p2=parabl(1.-x,pdat(kz ,ix+2),pdat(kz ,ix+1),pdat(kz ,ix ))
+ pintlo=p1*(1.-x)+p2*x
+ p1=parabl( x,pdat(kz+1,ix-1),pdat(kz+1,ix ),pdat(kz+1,ix+1))
+ p2=parabl(1.-x,pdat(kz+1,ix+2),pdat(kz+1,ix+1),pdat(kz+1,ix ))
+ pinthi=p1*(1.-x)+p2*x
+ press =(pintlo*(1.-z)+pinthi*z)*onem
+ endif
+cdiag write (lp,'('' poflat'',2f7.2,2i5,2f7.2,f7.1)')
+cdiag& theta,xlat,ix,kz,x,z,press/onem
+ else
+c
+c ---- density from pressure.
+c
+ pz=press/onem
+ kz=1
+ p1=parabl( x,pdat(kz,ix-1),pdat(kz,ix ),pdat(kz,ix+1))
+ p2=parabl(1.-x,pdat(kz,ix+2),pdat(kz,ix+1),pdat(kz,ix ))
+ pinthi=p1*(1.-x)+p2*x
+ if (pinthi.ge.pz) then
+ theta=thet1
+ else ! normal range
+ do kz= 2,kdpth
+ pintlo=pinthi
+ p1=parabl( x,pdat(kz,ix-1),pdat(kz,ix ),pdat(kz,ix+1))
+ p2=parabl(1.-x,pdat(kz,ix+2),pdat(kz,ix+1),pdat(kz,ix ))
+ pinthi=p1*(1.-x)+p2*x
+ if (pinthi.ge.pz) then
+ exit
+ elseif (kz.eq.kdpth) then
+ exit
+ endif
+ enddo
+ z=max((pinthi-pz)/(pinthi-pintlo),0.0)
+ theta=thet1+(kz-z-1.0)*dthet
+ endif
+cdiag write (lp,'('' roflat'',2f7.2,2i5,2f7.2,f7.1)')
+cdiag& theta,xlat,ix,kz,x,z,pz
+ endif
+ return
+ end
+
+ real function poflat(theta,xlat)
+ implicit none
+c
+ real theta,xlat
+c
+c --- returns pressure as function of density and latitude
+c
+ real press
+ press = -1.0
+ call profile_lat(theta,press,xlat)
+ poflat = press
+ return
+ end
+
+ real function roflat(press,xlat)
+ implicit none
+c
+ real press,xlat
+c
+c --- returns density as function of pressure and latitude
+c
+ real theta
+c
+ call profile_lat(theta,press,xlat)
+ roflat = theta
+ return
+ end
+
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Aug 2001 - added roflat and profile_lat to poflat.
diff --git a/src_2.2.18_3_one/prtmsk.f b/src_2.2.18_3_one/prtmsk.f
new file mode 100755
index 0000000..527ea2c
--- /dev/null
+++ b/src_2.2.18_3_one/prtmsk.f
@@ -0,0 +1,53 @@
+ subroutine prtmsk(mask,array,work,idm,ii,jj,offset,scale,title)
+c
+c --- Delete 'array' elements outside 'mask'. Then
+c --- break 'array' into sections, each 'nchar' characters wide, for printing.
+c
+ implicit none
+ integer nchar
+ parameter (nchar=120)
+ccc parameter (nchar= 76)
+ccc parameter (nchar= 80)
+ccc parameter (nchar=132)
+c
+ integer idm,ii,jj
+ integer mask(idm,*)
+ real array(idm,*),work(idm,*)
+ real offset,scale
+ character title*(*)
+c
+ integer lp
+ common/linepr/ lp
+ save /linepr/
+c
+ integer i,i1,i2,j,n,ncols
+c
+ real cvmgp,cvmgz,a,b,c
+ integer ic
+ cvmgp(a,b,c)=a*(.5+sign(.5,c))+b*(.5-sign(.5,c))
+ cvmgz(a,b,ic)=cvmgp(a,b,-1.*iabs(ic))
+c
+ ncols=nchar/4
+ do 1 n=1,ii/ncols+1
+ i1=ncols*(n-1)+1
+ i2=min0(ncols*n,ii)
+ if (i1.gt.i2) go to 1
+ write (lp,'(/'' Sec.'',i2,'' (cols'',i4,'' -'',i4,'') -- '',a)')
+ . n,i1,i2,title
+ccc if (i2.lt.i1+5) then
+ccc write (lp,'('' (Not printed. Too few columns. Save paper.)'')')
+ccc go to 1
+ccc end if
+ do 2 j=jj,1,-1
+ do 3 i=i1,i2
+ 3 work(i,j)=cvmgz(0.,array(i,j),mask(i,j))
+ do 4 i=i1,i2
+ 4 work(i,j)=cvmgz(0.,(work(i,j)-offset)*scale,mask(i,j))
+ write (lp,'(32i4)') j,(int(work(i,j)),i=i1,i2)
+ccc write (lp,'(i4,1x,75i1)') j,(int(work(i,j)),i=i1,i2)
+ccc write (lp,'(i4,1x,120i1)') j,(int(work(i,j)),i=i1,i2)
+ 2 continue
+ 1 continue
+ call flush(lp)
+ return
+ end
diff --git a/src_2.2.18_3_one/psmoo.f b/src_2.2.18_3_one/psmoo.f
new file mode 100755
index 0000000..dc2bfb1
--- /dev/null
+++ b/src_2.2.18_3_one/psmoo.f
@@ -0,0 +1,266 @@
+ subroutine psmooth(a,margin_smooth)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer margin_smooth
+ real a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- ragged boundary version of basic 9-point smoothing routine.
+c --- this routine is set up to smooth data carried at -p- points.
+c
+c --- see also psmooth_ice and psmooth_dif.
+c
+c --- util1 used as workspace, so array a can't be util1
+c
+ integer i,ismth,j,jsmth,msmth
+ real qc,sh
+c
+ real c(-1:1,-1:1)
+ save c
+ data c / 1.0, 2.0, 1.0,
+ & 2.0, 4.0, 2.0,
+ & 1.0, 2.0, 1.0 /
+c
+ qc = 1.0/sum(c(:,:))
+c
+ msmth = min(margin_smooth,nbdy-1)
+c
+ if (margin.lt.msmth+1) then
+c --- update the halo
+ call xctilr(a,1,1, msmth+1,msmth+1, halo_ps)
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC)
+ do j=0-msmth,jj+msmth+1
+ do i=0-msmth,ii+msmth+1
+ util1(i,j) = a(i,j)
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j,i,sh,jsmth,ismth)
+!$OMP& SCHEDULE(STATIC)
+ do j=1-msmth,jj+msmth
+ do i=1-msmth,ii+msmth
+ if (ip(i,j).eq.1) then
+ sh = 0.0
+ do jsmth= -1,1
+ do ismth= -1,1
+ if (ip(i+ismth,j+jsmth).eq.1) then
+ sh = sh + c(ismth,jsmth)*util1(i+ismth,j+jsmth)
+ else
+ sh = sh + c(ismth,jsmth)*util1(i, j)
+ endif
+ enddo
+ enddo
+ a(i,j) = sh*qc
+ endif !ip.eq.1
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ return
+ end subroutine psmooth
+
+ subroutine psmooth_new(a,b,margin_smooth)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer margin_smooth
+ real a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & b(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- ragged boundary version of basic 9-point smoothing routine.
+c --- this routine is set up to smooth data carried at -p- points.
+c --- input in a, output in b.
+c
+c --- see also psmooth.
+c
+c --- a and b must not be the same array.
+c
+ integer i,ismth,j,jsmth,msmth
+ real qc,sh
+c
+ real c(-1:1,-1:1)
+ save c
+ data c / 1.0, 2.0, 1.0,
+ & 2.0, 4.0, 2.0,
+ & 1.0, 2.0, 1.0 /
+c
+ qc = 1.0/sum(c(:,:))
+c
+ msmth = min(margin_smooth,nbdy-1)
+c
+ if (margin.lt.msmth+1) then
+c --- update the halo
+ call xctilr(a,1,1, msmth+1,msmth+1, halo_ps)
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i,sh,jsmth,ismth)
+!$OMP& SCHEDULE(STATIC)
+ do j=1-msmth,jj+msmth
+ do i=1-msmth,ii+msmth
+ if (ip(i,j).eq.1) then
+ sh = 0.0
+ do jsmth= -1,1
+ do ismth= -1,1
+ if (ip(i+ismth,j+jsmth).eq.1) then
+ sh = sh + c(ismth,jsmth)*a(i+ismth,j+jsmth)
+ else
+ sh = sh + c(ismth,jsmth)*a(i, j)
+ endif
+ enddo
+ enddo
+ b(i,j) = sh*qc
+ endif !ip.eq.1
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ return
+ end subroutine psmooth_new
+
+ subroutine psmooth_ice(a,margin_smooth)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer margin_smooth
+ real a(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- ragged boundary version of basic 9-point smoothing routine.
+c --- this routine is set up to smooth data carried at -p- points.
+c --- it also smooths covice=1.0 and covice=0.0 regions separately,
+c --- leaving areas with fractional covice untouched. note that
+c --- covice must be valid in the halo out to margin_smooth.
+c
+c --- see also psmooth and psmooth_dif
+c
+c --- util1 used as workspace, so array a can't be util1 or covice
+c
+ integer i,ismth,j,jsmth,msmth
+ real qc,sh,ci
+c
+ real c(-1:1,-1:1)
+ save c
+ data c / 1.0, 2.0, 1.0,
+ & 2.0, 4.0, 2.0,
+ & 1.0, 2.0, 1.0 /
+c
+ qc = 1.0/sum(c(:,:))
+c
+ msmth = min(margin_smooth,nbdy-1)
+c
+ if (margin.lt.msmth+1) then
+c --- update the halo
+ call xctilr(a,1,1, msmth+1,msmth+1, halo_ps)
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC)
+ do j=0-msmth,jj+msmth+1
+ do i=0-msmth,ii+msmth+1
+ util1(i,j) = a(i,j)
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j,i,sh,ci,jsmth,ismth)
+!$OMP& SCHEDULE(STATIC)
+ do j=1-msmth,jj+msmth
+ do i=1-msmth,ii+msmth
+ if (ip(i,j).eq.1) then
+ ci = covice(i,j)
+ if (ci.eq.0.0 .or.
+ & ci.eq.1.0 ) then !full sea or full ice
+ sh = 0.0
+ do jsmth= -1,1
+ do ismth= -1,1
+ if ( ip(i+ismth,j+jsmth).eq.1 .and.
+ & covice(i+ismth,j+jsmth).eq.ci ) then
+ sh = sh + c(ismth,jsmth)*util1(i+ismth,j+jsmth)
+ else
+ sh = sh + c(ismth,jsmth)*util1(i, j)
+ endif
+ enddo
+ enddo
+ a(i,j) = sh*qc
+ endif !full sea or full ice
+ endif !ip.eq.1
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ return
+ end subroutine psmooth_ice
+
+ subroutine psmooth_dif(a,aklist,k,margin_smooth)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+ include 'common_blocks.h'
+c
+ integer k,margin_smooth
+ real a( 1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & aklist(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- ragged boundary version of basic 9-point smoothing routine.
+c --- this routine is set up to smooth vcty carried at -p- points.
+c --- it return the maximum of the original and smoothed value and
+c --- ignores locations where k > aklist(i,j).
+c
+c --- see also psmooth and psmooth_ice.
+c
+c --- util1 used as workspace, so array a can't be util1
+c --- assumes that aklist's halo is valid out to msmth+1.
+c
+ integer i,ismth,j,jsmth,msmth
+ real qc,sh
+c
+ real c(-1:1,-1:1)
+ save c
+ data c / 1.0, 2.0, 1.0,
+ & 2.0, 4.0, 2.0,
+ & 1.0, 2.0, 1.0 /
+c
+ qc = 1.0/sum(c(:,:))
+c
+ msmth = min(margin_smooth,nbdy-1)
+c
+ if (margin.lt.msmth+1) then
+c --- update the halo
+ call xctilr(a,1,1, msmth+1,msmth+1, halo_ps)
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,i)
+!$OMP& SCHEDULE(STATIC)
+ do j=0-msmth,jj+msmth+1
+ do i=0-msmth,ii+msmth+1
+ util1(i,j) = a(i,j)
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+!$OMP PARALLEL DO PRIVATE(j,i,sh,jsmth,ismth)
+!$OMP& SCHEDULE(STATIC)
+ do j=1-msmth,jj+msmth
+ do i=1-msmth,ii+msmth
+ if ( ip(i,j).eq.1 .and.
+ & aklist(i,j).ge.k ) then
+ sh = 0.0
+ do jsmth= -1,1
+ do ismth= -1,1
+ if ( ip(i+ismth,j+jsmth).eq.1 .and.
+ & aklist(i+ismth,j+jsmth).ge.k ) then
+ sh = sh + c(ismth,jsmth)*util1(i+ismth,j+jsmth)
+ else
+ sh = sh + c(ismth,jsmth)*util1(i, j)
+ endif
+ enddo
+ enddo
+ a(i,j) = max( a(i,j), sh*qc )
+ endif !ip.eq.1
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ return
+ end subroutine psmooth_dif
diff --git a/src_2.2.18_3_one/restart.f b/src_2.2.18_3_one/restart.f
new file mode 100755
index 0000000..f9193ce
--- /dev/null
+++ b/src_2.2.18_3_one/restart.f
@@ -0,0 +1,875 @@
+ subroutine restart_in(nstep0, dtime0, flnmra,flnmrb)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ use mod_tides ! HYCOM tides
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer nstep0
+ real*8 dtime0
+ character*(*) flnmra,flnmrb
+c
+c read in a restart file.
+c flnmra is the ".a" file, and flnmrb is the ".b" file.
+c
+ logical lmyin,ltidin,lold
+ integer i,ios,j,k,kskip,ktr
+ character cline*80
+c
+ include 'stmt_fns.h'
+c
+ call zaiopf(flnmra,'old', 11)
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ open (unit=uoff+11,file=flnmrb,
+ & status='old',action='read',form='formatted')
+ endif
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ if (mnproc.eq.1) then
+ write(lp,'(a)') trim(cline)
+ endif !1st tile
+ if (cline(1:9).eq.'RESTART: ') then
+ lold = .true. !original, larger, restart file
+ elseif (cline(1:9).eq.'RESTART2:') then
+ lold = .false.
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)') 'error in hycom - unknown restart type'
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ if (mnproc.eq.1) then
+ write(lp,'(a)') trim(cline)
+ call flush(lp)
+ endif !1st tile
+ i = index(cline,'=')
+ read(cline(i+1:),*) nstep0,dtime0
+c
+ call restart_in3d(u, 2*kdm, iu, 'u ')
+ call restart_in3d(v, 2*kdm, iv, 'v ')
+ call restart_in3d(dp, 2*kdm, ip, 'dp ')
+ call restart_in3d(temp, 2*kdm, ip, 'temp ')
+ call restart_in3d(saln, 2*kdm, ip, 'saln ')
+ if (lold) then
+ call restart_in3d(th3d, 2*kdm, ip, 'th3d ')
+ else
+ do k= 1,kdm
+ do j= 1,jj
+ do i= 1,ii
+ if (ip(i,j).eq.1) then
+ th3d(i,j,k,1)=sig(temp(i,j,k,1),saln(i,j,k,1))-thbase
+ th3d(i,j,k,2)=sig(temp(i,j,k,2),saln(i,j,k,2))-thbase
+ else
+ th3d(i,j,k,1) = 0.0
+ th3d(i,j,k,2) = 0.0
+ endif
+ enddo !i
+ enddo !j
+ enddo !k
+ endif
+c
+c do we have MY2.5 arrays in the restart file?
+c
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ if (lold) then
+ kskip = 12*kdm + 2
+ else
+ kskip = 10*kdm + 2
+ endif
+ call restart_inrw(kskip)
+c
+ lmyin = cline(1:8).eq.'q2 '
+c
+ if (lmyin) then
+c
+c MY2.5 in restart file.
+c
+ if (mxlmy) then
+ call restart_in3d(q2 ,2*kdm+4, ip, 'q2 ')
+ call restart_in3d(q2l ,2*kdm+4, ip, 'q2l ')
+ call restart_in3d(vctymy, kdm+2, ip, 'vctymy ')
+ call restart_in3d(difqmy, kdm+2, ip, 'difqmy ')
+ call restart_in3d(diftmy, kdm+2, ip, 'diftmy ')
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(a)') 'RESTART: skipping MY2.5 input fields'
+ call flush(lp)
+ endif !1st tile
+ kskip = 7*kdm+14
+ do k= 1,kskip
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+* if (mnproc.eq.1) then
+* write(lp,'(a)') cline
+* endif !1st tile
+ call zaiosk(11)
+ enddo !k
+ endif !mxlmy:else
+c
+c do we have DETIDE arrays in the restart file?
+c
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ if (lold) then
+ kskip = 12*kdm + 2 + 7*kdm+14
+ else
+ kskip = 10*kdm + 2 + 7*kdm+14
+ endif
+ call restart_inrw(kskip)
+ elseif (mxlmy) then
+ if (mnproc.eq.1) then
+ write(lp,'(a)') 'RESTART: no MY2.5 fields input'
+ call flush(lp)
+ endif !1st tile
+ endif !lmyin:mxlmy
+c
+c do we have DETIDE arrays in the restart file?
+c
+ ltidin = cline(1:8).eq.'uhrly '
+c
+ if (ltidin) then
+c
+c DETIDE in restart file.
+c
+ if (tidflg.gt.0) then
+ if (.not.allocated(uhrly)) then
+ allocate( uhrly(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,25),
+ & vhrly(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,25),
+ & untide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & vntide(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) )
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - uhrly already allocated'
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif !allocated:else
+ call restart_in3d(uhrly ,25, iu, 'uhrly ')
+ call restart_in3d(vhrly ,25, iv, 'vhrly ')
+ nhrly = 25 ![uv]ntide will be initialised in tides_set (tides_detide)
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(a)') 'RESTART: skipping DETIDE input fields'
+ call flush(lp)
+ endif !1st tile
+ do k= 1,50
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+* if (mnproc.eq.1) then
+* write(lp,'(a)') cline
+* endif !1st tile
+ call zaiosk(11)
+ enddo !k
+ endif !tidflg:else
+ elseif (tidflg.gt.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(a)') 'RESTART: no DETIDE fields input'
+ call flush(lp)
+ endif !1st tile
+ endif !ltidin:tidflg
+c
+ call restart_in3d(ubavg, 3, iu, 'ubavg ')
+ call restart_in3d(vbavg, 3, iv, 'vbavg ')
+ call restart_in3d(pbavg, 3, ip, 'pbavg ')
+ call restart_in3d(pbot, 1, ip, 'pbot ')
+ call restart_in3d(psikk,kapnum, ip, 'psikk ') !kapnum 1 or 2
+ call restart_in3d(thkk, kapnum, ip, 'thkk ') !kapnum 1 or 2
+ call restart_in3d(dpmixl, 2, ip, 'dpmixl ')
+ if (icegln) then
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in)')
+ stop '(restart_in)'
+ endif
+ if (ios.ne.0 .or. cline(1:8).ne.'temice ') then
+c
+c --- assume this is an addition of ice to the simulation.
+c
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)') 'adding ice to the simulation.'
+ call flush(lp)
+ endif !1st tile
+c
+ do j= 1,jj
+ do i= 1,ii
+ temice(i,j) = temp(i,j,1,1)
+ covice(i,j) = 0.0
+ thkice(i,j) = 0.0
+ enddo
+ enddo
+ if (trcrin .and. cline(1:8).eq.'tracer ') then
+c --- reposition file for tracer input
+ if (lold) then
+ kskip = 12*kdm+14+2*kapnum
+ else
+ kskip = 10*kdm+14+2*kapnum
+ endif
+ if (lmyin) then
+ kskip = kskip + 7*kdm+14
+ endif
+ if (ltidin) then
+ kskip = kskip + 50
+ endif
+ call restart_inrw(kskip)
+ endif
+ else
+c
+c --- reposition file for ice input
+c
+ if (lold) then
+ kskip = 12*kdm+14+2*kapnum
+ else
+ kskip = 10*kdm+14+2*kapnum
+ endif
+ if (lmyin) then
+ kskip = kskip + 7*kdm+14
+ endif
+ if (ltidin) then
+ kskip = kskip + 50
+ endif
+ call restart_inrw(kskip)
+c
+ call restart_in3d(temice, 1, ip, 'temice ')
+ call restart_in3d(covice, 1, ip, 'covice ')
+ call restart_in3d(thkice, 1, ip, 'thkice ')
+ endif
+ endif
+ if (trcrin) then
+ do ktr= 1,ntracr
+ call restart_in3d(tracer(1-nbdy,1-nbdy,1,1,ktr),
+ & 2*kdm, ip, 'tracer ')
+ enddo
+ endif
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ close (unit=uoff+11)
+ endif
+ call zaiocl(11)
+c
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ klist(i,j) = kk !for MY2.5 mixed layer
+ enddo
+ enddo
+ return
+ end subroutine restart_in
+
+ subroutine restart_in3d(field,l, mask, cfield)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+c
+ integer l
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,l) ::
+ & field
+ integer, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & mask
+ character cfield*8
+c
+c --- read a single restart 3-d array field.
+c
+ integer i,ios,layer,level,k
+ real hmina(2*kdm+25),hminb,hmaxa(2*kdm+25),hmaxb !+25 for [uv]hrly
+ character cline*80
+c
+ if (mnproc.eq.1) then
+ write(lp,'(a,i3,2x,a)') 'restart_in3d - l,cfield = ',l,cfield
+ call flush(lp)
+ endif !1st tile
+ call zaiord3(field,l, mask,.false., hmina,hmaxa, 11)
+c
+ do k= 1,l
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_in3d)')
+ stop '(restart_in3d)'
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(a)') trim(cline)
+ endif !1st tile
+ if (cline(1:8).ne.cfield) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,a /)') trim(cline),
+ & 'error in restart_in3d - expected ',cfield
+ endif !1st tile
+ call xcstop('(restart_in3d)')
+ stop '(restart_in3d)'
+ endif
+ i = index(cline,'=')
+ read (cline(i+1:),*) layer,level,hminb,hmaxb
+ if (abs(hmina(k)-hminb).gt.abs(hminb)*1.e-4 .or.
+ & abs(hmaxa(k)-hmaxb).gt.abs(hmaxb)*1.e-4 ) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a / a,3i3 / a / a,1p3e14.6 / a,1p3e14.6 /)')
+ & 'error - .a and .b files not consistent:',
+ & 'iunit,k,l = ',11,k,l,
+ & cline,
+ & '.a,.b min = ',hmina(k),hminb,hmina(k)-hminb,
+ & '.a,.b max = ',hmaxa(k),hmaxb,hmaxa(k)-hmaxb
+ endif !1st tile
+ call xcstop('(restart_in3d)')
+ stop '(restart_in3d)'
+ endif
+ enddo
+c
+ return
+ end subroutine restart_in3d
+
+ subroutine restart_inrw(kline)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ implicit none
+c
+ integer kline
+c
+c reposition the input restart .b file at line kline.
+c
+ integer ios,k
+ character cline*80
+c
+ if (mnproc.eq.1) then ! .b file from 1st tile only
+ rewind(uoff+11)
+ endif
+ do k= 1,kline
+ call zagetc(cline,ios, uoff+11)
+ if (ios.ne.0) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4,i9 /)')
+ & 'I/O error from zagetc, iunit,ios = ',uoff+11,ios
+ endif !1st tile
+ call xcstop('(restart_inrw)')
+ stop '(restart_inrw)'
+ endif
+ enddo !k
+ if (mnproc.eq.1) then
+ write(lp,'(a,i5)') 'restart_inrw, kline =',kline
+ write(lp,'(a)') trim(cline)
+ call flush(lp)
+ endif !1st tile
+ return
+ end subroutine restart_inrw
+
+ subroutine restart_out(nstepx, dtimex, flnmra,flnmrb, last)
+ use mod_xc ! HYCOM communication interface
+ use mod_za ! HYCOM I/O interface
+ use mod_tides ! HYCOM tides
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ logical last
+ integer nstepx
+ real*8 dtimex
+ character*(*) flnmra,flnmrb
+c
+c write out in a restart file on unit 12 or 22 (and a flux file on 25).
+c
+c flnmra is the ".a" file (usually without the .a, and
+c flnmrb is the ".b" file (usually without the .b).
+c Usually flnmra == flnmrb, and there are standard and backup restarts;
+c otherwise the restart is unique and flnmra and flnmrb are the complete
+c filenames (including any .a and .b).
+c
+ logical lopen
+ integer i,iunit,iunta,j,k,ktr,l
+ real xmin(2*kdm+25),xmax(2*kdm+25) !+25 for [uv]hrly
+ character cline*80
+c
+ integer, save :: icount = 0
+c
+ include 'stmt_fns.h'
+c
+ icount = icount + 1
+c
+ if (flnmra.ne.flnmrb .or. last .or. mod(icount,2).eq.0) then
+ iunta = 12 ! standard restart file
+ else
+ iunta = 22 ! backup restart file
+ endif
+ iunit = uoff+iunta
+c
+ call zaiopi(lopen, iunta)
+ if (.not.lopen) then
+ if (flnmra.ne.flnmrb) then
+ call zaiopf(trim(flnmra), 'new', iunta) !unique
+ elseif (iunta.eq.12) then
+ call zaiopf(trim(flnmra)//'.a', 'new', iunta) !standard
+ else
+ call zaiopf(trim(flnmra)//'1.a','new', iunta) !backup
+ endif
+ if (mnproc.eq.1) then
+ if (flnmra.ne.flnmrb) then
+ open (unit=iunit,file=trim(flnmrb), !12
+ & status='new',action='write',form='formatted')
+ write(lp,'(a)') ' creating a new unique restart file'
+ elseif (iunta.eq.12) then
+ open (unit=iunit,file=trim(flnmra)//'.b', !12
+ & status='new',action='write',form='formatted')
+ write(lp,'(a)') ' creating a new standard restart file'
+ else
+ open (unit=iunit,file=trim(flnmra)//'1.b', !22
+ & status='new',action='write',form='formatted')
+ write(lp,'(a)') ' creating a new backup restart file'
+ endif
+ call flush(lp)
+ endif !1st tile
+ elseif (flnmra.ne.flnmrb) then
+ if (mnproc.eq.1) then
+ write(lp,'(a)')
+ & ' error - (unique) restart file already exists.'
+ write(lp,'(a,a)')
+ & ' flnmra = ',trim(flnmra)
+ write(lp,'(a,a)')
+ & ' flnmrb = ',trim(flnmrb)
+ endif !1st tile
+ call xcstop('(restart_out)')
+ stop '(restart_out)'
+ else
+ call zaiorw(iunta)
+ if (mnproc.eq.1) then
+ rewind(unit=iunit)
+ if (iunta.eq.12) then
+ write(lp,'(a)')
+ & ' over-writing any previous standard restart'
+ else
+ write(lp,'(a)')
+ & ' over-writing any previous backup restart'
+ endif
+ call flush(lp)
+ endif !1st tile
+ endif
+c
+ if (mnproc.eq.1) then
+ write(iunit,'(a,4i6)') 'RESTART2: iexpt,iversn,yrflag,sigver = ',
+ & iexpt,iversn,yrflag,sigver
+ write(cline,*) nstepx,dtimex,thbase
+ write(iunit,'(a,a)') 'RESTART2: nstep,dtime,thbase = ',
+ & trim(cline)
+ call flush(iunit)
+ endif !1st tile
+c
+ call zaiowr3(u, 2*kdm, iu,.false., xmin,xmax, iunta,.true.)
+ call xctilr( u, 1,2*kdm, nbdy,nbdy, halo_uv)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'u ',k,l+1,xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(v, 2*kdm, iv,.false., xmin,xmax, iunta,.true.)
+ call xctilr( v, 1,2*kdm, nbdy,nbdy, halo_vv)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'v ',k,l+1,xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(dp, 2*kdm, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( dp, 1,2*kdm, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'dp ',k,l+1,xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(temp, 2*kdm, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( temp, 1,2*kdm, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'temp ',k,l+1,xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(saln, 2*kdm, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( saln, 1,2*kdm, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'saln ',k,l+1,xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+c
+c --- temp and saln may have been changed, so update th3d
+ do k= 1,kdm
+ do j= 1-nbdy,jj+nbdy
+ do i= 1-nbdy,ii+nbdy
+ if (ip(i,j).eq.1) then
+ th3d(i,j,k,1)=sig(temp(i,j,k,1),saln(i,j,k,1))-thbase
+ th3d(i,j,k,2)=sig(temp(i,j,k,2),saln(i,j,k,2))-thbase
+ else
+ th3d(i,j,k,1) = 0.0
+ th3d(i,j,k,2) = 0.0
+ endif
+ enddo !i
+ enddo !j
+ enddo !k
+c
+ if (mxlmy) then
+ call zaiowr3(q2, 2*kdm+4, ip,.false., xmin,xmax, iunta,.true.)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm+2
+ write(iunit,4100) 'q2 '
+ & ,k,l+1,xmin(k+l*(kdm+2)),xmax(k+l*(kdm+2))
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(q2l, 2*kdm+4, ip,.false., xmin,xmax, iunta,.true.)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm+2
+ write(iunit,4100) 'q2l '
+ & ,k,l+1,xmin(k+l*(kdm+2)),xmax(k+l*(kdm+2))
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(vctymy, kdm+2, ip,.false., xmin,xmax, iunta,.true.)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 1,kdm+2
+ write(iunit,4100) 'vctymy ',k,l,xmin(k),xmax(k)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(difqmy, kdm+2, ip,.false., xmin,xmax, iunta,.true.)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 1,kdm+2
+ write(iunit,4100) 'difqmy ',k,l,xmin(k),xmax(k)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(diftmy, kdm+2, ip,.false., xmin,xmax, iunta,.true.)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 1,kdm+2
+ write(iunit,4100) 'diftmy ',k,l,xmin(k),xmax(k)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ endif !mxlmy
+c
+ if (tidflg.gt.0) then
+ call zaiowr3(uhrly, 25, iu,.false., xmin,xmax, iunta,.true.)
+ call xctilr( uhrly, 1,25, nbdy,nbdy, halo_uv)
+ if (mnproc.eq.1) then
+ do l= 1,25
+ do k= 0,0
+ write(iunit,4100) 'uhrly ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(vhrly, 25, iv,.false., xmin,xmax, iunta,.true.)
+ call xctilr( vhrly, 1,25, nbdy,nbdy, halo_vv)
+ if (mnproc.eq.1) then
+ do l= 1,25
+ do k= 0,0
+ write(iunit,4100) 'vhrly ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ endif !tidflg
+c
+ call zaiowr3(ubavg, 3, iu,.false., xmin,xmax, iunta,.true.)
+ call xctilr( ubavg, 1,3, nbdy,nbdy, halo_uv)
+ if (mnproc.eq.1) then
+ do l= 1,3
+ do k= 0,0
+ write(iunit,4100) 'ubavg ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(vbavg, 3, iv,.false., xmin,xmax, iunta,.true.)
+ call xctilr( vbavg, 1,3, nbdy,nbdy, halo_vv)
+ if (mnproc.eq.1) then
+ do l= 1,3
+ do k= 0,0
+ write(iunit,4100) 'vbavg ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(pbavg, 3, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( pbavg, 1,3, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,3
+ do k= 0,0
+ write(iunit,4100) 'pbavg ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(pbot, 1, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( pbot, 1,1, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 0,0
+ write(iunit,4100) 'pbot ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(psikk, kapnum,ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( psikk,1,kapnum,nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,kapnum !kapnum 1 or 2
+ do k= 0,0
+ write(iunit,4100) 'psikk ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(thkk, kapnum, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( thkk,1,kapnum, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,kapnum !kapnum 1 or 2
+ do k= 0,0
+ write(iunit,4100) 'thkk ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(dpmixl, 2, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( dpmixl, 1,2, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,2
+ do k= 0,0
+ write(iunit,4100) 'dpmixl ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ if (icegln) then
+ call zaiowr3(temice, 1, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( temice, 1,1, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 0,0
+ write(iunit,4100) 'temice ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(covice, 1, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( covice, 1,1, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 0,0
+ write(iunit,4100) 'covice ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ call zaiowr3(thkice, 1, ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( thkice, 1,1, nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 1,1
+ do k= 0,0
+ write(iunit,4100) 'thkice ',k,l, xmin(l),xmax(l)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ endif
+ if (trcout) then
+ do ktr= 1,ntracr
+ call zaiowr3(tracer(1-nbdy,1-nbdy,1,1,ktr), 2*kdm,
+ & ip,.false., xmin,xmax, iunta,.true.)
+ call xctilr( tracer(1-nbdy,1-nbdy,1,1,ktr),1,2*kdm,
+ & nbdy,nbdy, halo_ps)
+ if (mnproc.eq.1) then
+ do l= 0,1
+ do k= 1,kdm
+ write(iunit,4100) 'tracer ',k,l+1,xmin(k+l*kdm),
+ & xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(iunit)
+ endif !1st tile
+ enddo !ktr
+ endif !trcout
+c
+ if (flnmra.ne.flnmrb) then !unique restart file
+ call zaiocl(iunta)
+ if (mnproc.eq.1) then
+ close(unit=iunit)
+ write(lp,'(a,f11.3)')
+ & ' unique restart created at model day',dtimex
+ call flush(lp)
+ endif !1st tile
+ elseif (last) then !close all restart files
+ call zaiocl(iunta) !iunta==12
+ if (mnproc.eq.1) then
+ close(unit=iunit)
+ write(lp,'(a,f11.3)')
+ & ' restart created & closed at model day',dtimex
+ call flush(lp)
+ endif
+ call zaiopi(lopen, 22) !backup restart file?
+ if (lopen) then
+ call zaiocl(22)
+ if (mnproc.eq.1) then
+ close(unit=uoff+22)
+ endif
+ endif
+ else
+ call zaiofl(iunta)
+ if (mnproc.eq.1) then
+ call flush(iunit)
+ write(lp,'(a,f11.3)')
+ & ' restart created at model day',dtimex
+ call flush(lp)
+ endif
+ endif
+ call xcsync(flush_lp)
+c
+c --- output to flux file
+c
+ if (.FALSE.) then ! turn on/off flux output
+ call zaiopi(lopen, 25)
+ if (.not.lopen) then
+ call zaiopf(trim(flnmflx)//'.a','new', 25)
+ if (mnproc.eq.1) then
+ open (unit=uoff+25,file=trim(flnmflx)//'.b',
+ & status='new',action='write',form='formatted')
+ write(uoff+25,'(a,3i6)') 'FLUXES: iexpt,iversn,yrflag = ',
+ & iexpt,iversn,yrflag
+ call flush(uoff+25)
+ endif !1st tile
+ endif
+c
+ if (mnproc.eq.1) then
+ write(cline,*) nstepx,dtimex
+ write(uoff+25,'(a,a)') 'FLUXES: nstep,dtime = ',
+ & trim(cline)
+ call flush(uoff+25)
+ endif !1st tile
+c
+ call zaiowr3(dpav, kdm, ip,.true., xmin,xmax, 25, .false.)
+ if (mnproc.eq.1) then
+ do l= 0,0
+ do k= 1,kdm
+ write(uoff+25,4100) 'dpav ',k,l,
+ & xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(uoff+25)
+ endif !1st tile
+ call zaiowr3(uflxav, kdm, iu,.true., xmin,xmax, 25, .false.)
+ if (mnproc.eq.1) then
+ do l= 0,0
+ do k= 1,kdm
+ write(uoff+25,4100) 'uflxav ',k,l,
+ & xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush(uoff+25)
+ endif !1st tile
+ call zaiowr3(vflxav, kdm, iv,.true., xmin,xmax, 25, .false.)
+ if (mnproc.eq.1) then
+ do l= 0,0
+ do k= 1,kdm
+ write(uoff+25,4100) 'vflxav ',k,l,
+ & xmin(k+l*kdm),xmax(k+l*kdm)
+ enddo
+ enddo
+ call flush( uoff+25)
+ endif !1st tile
+ call zaiofl(25)
+ endif !flux output
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-nbdy,jj+nbdy
+ do i=1-nbdy,ii+nbdy
+ klist(i,j) = kk !for MY2.5 mixed layer
+ do k=1,kk
+ dpav(i,j,k)=0.
+ uflxav(i,j,k)=0.
+ vflxav(i,j,k)=0.
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+ return
+ 4100 format(a,': layer,tlevel,range = ',i3,i3,2x,1p2e16.7)
+ end subroutine restart_out
+c
+c
+c> Revision history:
+c>
+c> May. 2007 - removed th3d from the restart file
diff --git a/src_2.2.18_3_one/stmt_fns.h b/src_2.2.18_3_one/stmt_fns.h
new file mode 100755
index 0000000..26b3f1d
--- /dev/null
+++ b/src_2.2.18_3_one/stmt_fns.h
@@ -0,0 +1,164 @@
+c-----------------------------------------------------------------------------
+ integer, parameter ::
+ & sigver=1 !7-term sigma-0
+csig2& sigver=2 !7-term sigma-2
+c
+ real sig,dsigdt,dsigds,tofsig,sofsig,kappaf,kappaf1,
+ & sigloc,dsiglocdt,dsiglocds,tofsigloc
+c
+ real a0,a1,a2,cubr,cubq,cuban,cubrl,cubim
+ real c1l,c2l,c3l,c4l,c5l,c6l,c7l
+ real r,s,t,prs
+ integer kkf
+c
+ real, parameter ::
+ & ahalf=1.0/2.0,
+ & a3rd =1.0/3.0, athird =a3rd,
+ & a4th =1.0/4.0, afourth=a4th
+c
+c --- coefficients for sigma-0 (based on Brydon & Sun fit)
+ real, parameter ::
+ & c1=-1.36471E-01, !const. coefficent
+ & c2= 4.68181E-02, !T coefficent
+ & c3= 8.07004E-01, ! S coefficent
+ & c4=-7.45353E-03, !T^2 coefficent
+ & c5=-2.94418E-03, !T S coefficent
+ & c6= 3.43570E-05, !T^3 coefficent
+ & rc6= 1.0/c6,
+ & c7= 3.48658E-05, !T^2S coefficent
+ & pref= 0.0 ! reference pressure
+c
+c --- coefficients for sigma-2 (based on Brydon & Sun fit)
+csig2 real, parameter ::
+csig2& c1= 9.77093E+00, !const. coefficent
+csig2& c2=-2.26493E-02, !T coefficent
+csig2& c3= 7.89879E-01, ! S coefficent
+csig2& c4=-6.43205E-03, !T^2 coefficent
+csig2& c5=-2.62983E-03, !T S coefficent
+csig2& c6= 2.75835E-05, !T^3 coefficent
+csig2& rc6= 1.0/c6,
+csig2& c7= 3.15235E-05, !T^2S coefficent
+csig2& pref= 2000.0e4 !reference pressure
+c
+c --- coefficients for kappa^(theta)
+c --- new values (w.r.t. t-toff,s-soff,prs) from Shan Sun, Sep.2004
+c --- 1=Arctic/Antarctic; 2=Atlantic; 3=Mediterranean
+ real, parameter ::
+ & sclkap=1.e-11
+ real, parameter, dimension(3) ::
+ & toff = (/ 0.0, 3.0, 13.0 /)
+ & ,soff = (/ 34.5, 35.0, 38.5 /)
+ & ,qttt = (/ -3.03869354E-05, -3.03869352E-05, -3.03869353E-05 /)
+ & ,qtt = (/ 4.56625601E-03, 4.29277358E-03, 3.38116552E-03 /)
+ & ,qt = (/ -2.88801209E-01, -2.61828868E-01, -1.81335007E-01 /)
+ & ,qs = (/ -1.08670290E-01, -1.05131061E-01, -9.33336309E-02 /)
+ & ,qst = (/ 7.90503772E-04, 7.71096940E-04, 1.07270585E-03 /)
+ & ,qpt = (/ 1.07813750E-09, 1.00638435E-09, 7.57239852E-10 /)
+ & ,qpst = (/ 1.41541548E-11, 1.48598578E-11, 3.89226107E-12 /)
+ & ,qptt = (/ -1.31383708E-11, -1.31383707E-11, -1.31383708E-11 /)
+c
+c --- sub-coefficients for locally referenced sigma
+c --- a fit towards Jackett & McDougall (1995)
+ real, parameter, dimension(7) ::
+ & alphap = (/ -0.1364705627213484 , 0.04681812123458564,
+ & 0.80700383913187 ,-0.007453530323180844,
+ & -0.002944183249153631 , 0.00003435702568990446,
+ & 0.0000348657661057688 /)
+ & ,betap = (/ 0.05064226654169138 ,-0.0003571087848996894,
+ & -0.0000876148051892879, 5.252431910751829e-6,
+ & 1.579762259448864e-6 ,-3.466867400295792e-8,
+ & -1.687643078774232e-8 /)
+ & ,gammap = (/ -5.526396144304812e-6 , 4.885838128243163e-8,
+ & 9.96026931578033e-9 ,-7.251389796582352e-10,
+ & -3.987360250058777e-11, 4.006307891935698e-12,
+ & 8.26367520608008e-13 /)
+c
+c --- auxiliary statements for finding root of cubic polynomial
+ a0(s,r)=(c1+c3*s-r)*rc6 !constant coefficient
+ a1(s) =(c2+c5*s )*rc6 !linear coefficient
+ a2(s) =(c4+c7*s )*rc6 !quadratic coefficient
+ !cubic coefficient is c6*rc6=1.0
+ cubq(s)=a3rd*a1(s)-(a3rd*a2(s))**2
+ cubr(r,s)=a3rd*(0.5*a1(s)*a2(s)-1.5*a0(s,r))-(a3rd*a2(s))**3
+c --- if q**3+r**2>0, water is too dense to yield real root at given
+c --- salinitiy. setting q**3+r**2=0 in that case is equivalent to
+c --- lowering sigma until a double real root is obtained.
+ cuban(r,s)=a3rd*atan2(sqrt(max(0.0,-(cubq(s)**3+cubr(r,s)**2))),
+ & cubr(r,s))
+ cubrl(r,s)=sqrt(-cubq(s))*cos(cuban(r,s))
+ cubim(r,s)=sqrt(-cubq(s))*sin(cuban(r,s))
+c
+c --- -----------------
+c --- equation of state
+c --- -----------------
+c
+c --- sigma-theta as a function of temp (deg c) and salinity (psu)
+c --- (friedrich-levitus, polynomial fit that is cubic in T and linear in S)
+c
+ sig(t,s)=(c1+c3*s+t*(c2+c5*s+t*(c4+c7*s+c6*t)))
+c
+c --- d(sig)/dt
+ dsigdt(t,s)=(c2+c5*s+2.0*t*(c4+c7*s+1.5*c6*t))
+c
+c --- d(sig)/ds
+ dsigds(t,s)=(c3+t*(c5+t*c7))
+c
+c --- temp (deg c) as a function of sigma and salinity (psu)
+c --- find a cubic polynominal root of t**3+a2*t**2+a1*t+a0=0
+ tofsig(r,s)=-cubrl(r,s)+sqrt(3.0)*cubim(r,s)-a3rd*a2(s)
+c
+c --- salinity (psu) as a function of sigma and temperature (deg c)
+ sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
+c
+c --- thermobaric compressibility coefficient (integral from prs to pref)
+c --- Sun et.al. (1999) JPO 29 pp 2719-2729.
+c --- kappaf1 used internally to simplify offsetting T and S,
+c --- always invoke via kappaf.
+c --- offset limits based on stability estimates from:
+c --- Hallberg (2005) Ocean Modelling 8 pp 279-300.
+c --- t: potential temperature (degC); s: salinity (psu);
+c --- r: potential density (sigma); prs: pressure; kkf: ref.state
+c --- example: kappaf(4.5,34.5,36.406,1.e7,1) = 0.11827355
+c --- example: kappaf(4.5,34.5,36.406,1.e7,2) = 0.03204273
+c --- example: kappaf(4.5,34.5,36.408,1.e7,3) = -0.05106071
+ kappaf1(t,s,r,prs,kkf)=(r+qthref)*
+ & (exp(sclkap*(prs-pref)*
+ & ( s*( qs(kkf)+t* qst(kkf) ) +
+ & t*( qt(kkf)+t*(qtt(kkf)+t*qttt(kkf))+
+ & 0.5*(prs+pref)*
+ & (qpt(kkf)+s*qpst(kkf)+t*qptt(kkf)) ) ) )
+ & -1.0)
+ kappaf(t,s,r,prs,kkf)=
+ & kappaf1(max(-1.2, t-toff(kkf) ), !Hallberg,T-only: -1.8,0.9
+ & max(-3.0,min(1.5, s-soff(kkf))), !Hallberg,S-only: -4.2,2.1
+ & r,prs,kkf)
+c
+c --- locally referenced sigma, a fit towards Jackett & McDougall (1995)
+c --- t: potential temperature; s: psu; prs: pressure
+ c1l(prs)=alphap(1)+1.e-5*prs*(betap(1)+1.e-5*prs*gammap(1))
+ c2l(prs)=alphap(2)+1.e-5*prs*(betap(2)+1.e-5*prs*gammap(2))
+ c3l(prs)=alphap(3)+1.e-5*prs*(betap(3)+1.e-5*prs*gammap(3))
+ c4l(prs)=alphap(4)+1.e-5*prs*(betap(4)+1.e-5*prs*gammap(4))
+ c5l(prs)=alphap(5)+1.e-5*prs*(betap(5)+1.e-5*prs*gammap(5))
+ c6l(prs)=alphap(6)+1.e-5*prs*(betap(6)+1.e-5*prs*gammap(6))
+ c7l(prs)=alphap(7)+1.e-5*prs*(betap(7)+1.e-5*prs*gammap(7))
+ sigloc(t,s,prs)=c1l(prs)+c3l(prs)*s+
+ & t*(c2l(prs)+c5l(prs)*s+t*(c4l(prs)+c7l(prs)*s+c6l(prs)*t))
+ dsiglocdt(t,s,prs)=(c2l(prs)+c5l(prs)*s+
+ & 2.0*t*(c4l(prs)+c7l(prs)*s+1.5*c6l(prs)*t))
+ dsiglocds(t,s,prs)=(c3l(prs)+t*(c5l(prs)+t*c7l(prs)))
+c
+c> Revision history
+c>
+c> May 2000 - conversion to SI units
+c> Jul 2000 - removed rarely used functions, constants via parameter
+c> Jan 2002 - removed geometery functions
+c> Dec 2002 - new thermobaricity fit with toff=0.0,soff=34.0
+c> Jun 2003 - removed sigma4
+c> Jun 2003 - added locally referenced sigma
+c> Sep 2004 - added kkf to kappaf, select one of three reference states
+c> Aug 2006 - more restrictive kappaf1 offset limits
+c> May 2007 - added sigver
+c> Mar 2009 - modified limits in kappaf
+c> Mar 2009 - more accurate kappaf, with potential density
+c-----------------------------------------------------------------------------
diff --git a/src_2.2.18_3_one/thermf.f b/src_2.2.18_3_one/thermf.f
new file mode 100755
index 0000000..b280b12
--- /dev/null
+++ b/src_2.2.18_3_one/thermf.f
@@ -0,0 +1,1132 @@
+ subroutine thermf_oi(m,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ----------------------------------------------------------
+c --- thermal forcing - combine ocean and sea ice surface fluxes
+c --- - complete surface salinity forcing
+c --- ----------------------------------------------------------
+c
+ integer i,j,l
+ real*8 d1,d2
+c
+ margin = 0 ! no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ if (iceflg.ne.0) then
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ sswflx(i,j) = (1.0-covice(i,j))*sswflx(i,j) +
+ & fswice(i,j) !cell average
+ surflx(i,j) = (1.0-covice(i,j))*surflx(i,j) +
+ & flxice(i,j) !cell average
+ sstflx(i,j) = (1.0-covice(i,j))*sstflx(i,j) !relax over ocean
+ salflx(i,j) = (1.0-covice(i,j))*salflx(i,j) +
+ & sflice(i,j) + !cell average
+ & sssflx(i,j) !relax everywhere
+ util1(i,j) = surflx(i,j)*scp2(i,j)
+ util2(i,j) = salflx(i,j)*scp2(i,j)
+ enddo !i
+ enddo !l
+ else !covice(:,:)==0.0
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ salflx(i,j) = salflx(i,j) + sssflx(i,j) !relax everywhere
+ util1(i,j) = surflx(i,j)*scp2(i,j)
+ util2(i,j) = salflx(i,j)*scp2(i,j)
+ enddo !i
+ enddo !l
+ endif !iceflg
+ if (epmass) then
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c --- change total water depth by the water exchanged with the atmos.
+ if (btrlfr) then
+ pbavg(i,j,n) = pbavg(i,j,n)-
+ & onem* delt1*salflx(i,j)/
+ & (saln(i,j,1,n)*qthref)
+ else
+ pbavg(i,j,n) = pbavg(i,j,n)-
+ & onem*0.5*delt1*salflx(i,j)/
+ & (saln(i,j,1,n)*qthref)
+ endif !btrlfr:else
+ enddo !i
+ enddo !l
+ endif !epmass
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ call xcsum(d1, util1,ip)
+ call xcsum(d2, util2,ip)
+ watcum=watcum+d1
+ empcum=empcum+d2
+ return
+ end subroutine thermf_oi
+
+ subroutine thermf(m,n, dtime)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+ real*8 dtime
+c
+c --- ---------------
+c --- thermal forcing
+c --- note: on exit flux is for ocean fraction of each grid cell
+c --- ---------------
+c
+ integer i,j,k,ktr,nm,l, iyear,iday,ihour
+ real day365,pwl,q,utotij,vtotij
+ real*8 t1mean,s1mean,tmean,smean,pmean,rmean,
+ & rareac,runsec,secpyr
+ real*8 d1,d2,d3,d4
+c
+ real pwij(kk+1),trwij(kk,ntracr),
+ & prij(kk+1),trcij(kk,ntracr)
+c
+ real*8 tmean0,smean0,rmean0
+ save tmean0,smean0,rmean0
+c
+ double precision dtime_diurnl
+ save dtime_diurnl
+ data dtime_diurnl / -99.d0 /
+c
+ include 'stmt_fns.h'
+c
+ margin = 0 ! no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i,ktr)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do k=1,kk
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,n)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- ----------------------------
+c --- thermal forcing at nestwalls
+c --- ----------------------------
+c
+ if (nestfq.ne.0.0 .and. delt1.ne.baclin) then !not on very 1st time step
+c
+!$OMP PARALLEL DO PRIVATE(j,i,k,pwl)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+ if (ip(i,j).eq.1 .and. rmunp(i,j).ne.0.0) then
+ k=1
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmunp(i,j)*
+ & ((snest(i,j,k,ln0)*wn0+snest(i,j,k,ln1)*wn1)
+ & - saln(i,j,k,n))
+ temp(i,j,k,n)=temp(i,j,k,n)+delt1*rmunp(i,j)*
+ & ((tnest(i,j,k,ln0)*wn0+tnest(i,j,k,ln1)*wn1)
+ & - temp(i,j,k,n))
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+c
+ if (hybrid) then
+ do k=kk,2,-1
+ pwl=pnest(i,j,k,ln0)*wn0+pnest(i,j,k,ln1)*wn1
+ if (pwl.gt.p(i,j,kk+1)-tencm) then
+ pwl=p(i,j,kk+1)
+ endif
+ p(i,j,k)=min(p(i,j,k+1),
+ & p(i,j,k)+delt1*rmunp(i,j)*(pwl-p(i,j,k)))
+ dp(i,j,k,n)=p(i,j,k+1)-p(i,j,k)
+c
+ if (pwl.lt.p(i,j,kk+1)) then
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmunp(i,j)*
+ & ((snest(i,j,k,ln0)*wn0+snest(i,j,k,ln1)*wn1)
+ & - saln(i,j,k,n))
+ if (k.le.nhybrd) then
+ temp(i,j,k,n)=temp(i,j,k,n)+delt1*rmunp(i,j)*
+ & ((tnest(i,j,k,ln0)*wn0+tnest(i,j,k,ln1)*wn1)
+ & - temp(i,j,k,n))
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),
+ & saln(i,j,k,n))-thbase
+ else
+ th3d(i,j,k,n)= theta(i,j,k)
+ temp(i,j,k,n)=tofsig(theta(i,j,k)+thbase,
+ & saln(i,j,k,n))
+ endif
+ endif
+ enddo !k
+ dp(i,j,1,n)=p(i,j,2)-p(i,j,1)
+ else ! isopyc
+ do k=kk,2,-1
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmunp(i,j)*
+ & ((snest(i,j,k,ln0)*wn0+snest(i,j,k,ln1)*wn1)
+ & - saln(i,j,k,n))
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ if (k.ge.3) then
+ pwl=pnest(i,j,k,ln0)*wn0+pnest(i,j,k,ln1)*wn1
+ pwl=max(p(i,j,2),pwl)
+ if (pwl.gt.p(i,j,kk+1)-tencm) then
+ pwl=p(i,j,kk+1)
+ endif
+ p(i,j,k)=min(p(i,j,k+1),
+ & p(i,j,k)+delt1*rmunp(i,j)*(pwl-p(i,j,k)))
+ endif
+ dp(i,j,k,n)=p(i,j,k+1)-p(i,j,k)
+ enddo !k
+ endif ! hybrid:isopyc
+c
+c --- minimal tracer support (non-negative in buffer zone).
+ do ktr= 1,ntracr
+ tracer(i,j,k,n,ktr)=max(tracer(i,j,k,n,ktr),0.0)
+ enddo
+ endif !ip.eq.1 .and. rmunp.ne.0.0
+c
+ if (iu(i,j).eq.1 .and.
+ & max(rmunv(i,j),rmunv(i-1,j)).ne.0.0) then
+ do k= 1,kk
+ pwl=u(i,j,k,n)
+ u(i,j,k,n)=u(i,j,k,n)+delt1*max(rmunv(i,j),rmunv(i-1,j))*
+ & ((unest(i,j,k,ln0)*wn0+unest(i,j,k,ln1)*wn1)
+ & - u(i,j,k,n))
+ enddo !k
+ endif !iu.eq.1 .and. rmunv.ne.0.0
+c
+ if (iv(i,j).eq.1 .and.
+ & max(rmunv(i,j),rmunv(i,j-1)).ne.0.0) then
+ do k= 1,kk
+ pwl=v(i,j,k,n)
+ v(i,j,k,n)=v(i,j,k,n)+delt1*max(rmunv(i,j),rmunv(i,j-1))*
+ & ((vnest(i,j,k,ln0)*wn0+vnest(i,j,k,ln1)*wn1)
+ & - v(i,j,k,n))
+ enddo !k
+ endif !iv.eq.1 .and. rmunv.ne.0.0
+ enddo !i
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ endif ! nestfq.ne.0.0
+c
+c --- ----------------------------
+c --- thermal forcing at sidewalls
+c --- ----------------------------
+c
+ if (relax .and. delt1.ne.baclin) then !not on very 1st time step
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,pwl)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do 53 j=1-margin,jj+margin
+ do 53 l=1,isp(j)
+ do 53 i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (rmu(i,j).ne.0.0) then
+ k=1
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmu(i,j)*
+ & (( swall(i,j,k,lc0)*wc0+swall(i,j,k,lc1)*wc1
+ & +swall(i,j,k,lc2)*wc2+swall(i,j,k,lc3)*wc3)
+ & - saln(i,j,k,n))
+ if (lwflag.eq.2 .or. sstflg.gt.2 .or.
+ & icmflg.eq.2 .or. ticegr.eq.0.0 ) then
+c --- use seatmp, since it is the best available SST
+ temp(i,j,k,n)=temp(i,j,k,n)+delt1*rmu(i,j)*
+ & (( seatmp(i,j,l0)*w0+seatmp(i,j,l1)*w1
+ & +seatmp(i,j,l2)*w2+seatmp(i,j,l3)*w3)
+ & - temp(i,j,k,n))
+ else
+ temp(i,j,k,n)=temp(i,j,k,n)+delt1*rmu(i,j)*
+ & (( twall(i,j,k,lc0)*wc0+twall(i,j,k,lc1)*wc1
+ & +twall(i,j,k,lc2)*wc2+twall(i,j,k,lc3)*wc3)
+ & - temp(i,j,k,n))
+ endif
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+c
+ if (hybrid) then
+ do k=kk,2,-1
+ pwl=pwall(i,j,k,lc0)*wc0+pwall(i,j,k,lc1)*wc1
+ & +pwall(i,j,k,lc2)*wc2+pwall(i,j,k,lc3)*wc3
+ if (pwl.gt.p(i,j,kk+1)-tencm) then
+ pwl=p(i,j,kk+1)
+ endif
+ p(i,j,k)=min(p(i,j,k+1),
+ & p(i,j,k)+delt1*rmu(i,j)*(pwl-p(i,j,k)))
+ dp(i,j,k,n)=p(i,j,k+1)-p(i,j,k)
+c
+ if (pwl.lt.p(i,j,kk+1)) then
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmu(i,j)*
+ & ((swall(i,j,k,lc0)*wc0+swall(i,j,k,lc1)*wc1
+ & +swall(i,j,k,lc2)*wc2+swall(i,j,k,lc3)*wc3)
+ & - saln(i,j,k,n))
+ if (k.le.nhybrd) then
+ temp(i,j,k,n)=temp(i,j,k,n)+delt1*rmu(i,j)*
+ & ((twall(i,j,k,lc0)*wc0+twall(i,j,k,lc1)*wc1
+ & +twall(i,j,k,lc2)*wc2+twall(i,j,k,lc3)*wc3)
+ & - temp(i,j,k,n))
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ else
+ th3d(i,j,k,n)= theta(i,j,k)
+ temp(i,j,k,n)=tofsig(theta(i,j,k)+thbase,
+ & saln(i,j,k,n))
+ endif !hybrid:else
+ endif !pwl.lt.p(i,j,kk+1)
+ enddo !k
+ dp(i,j,1,n)=p(i,j,2)-p(i,j,1)
+ else ! isopyc
+ do k=kk,2,-1
+ saln(i,j,k,n)=saln(i,j,k,n)+delt1*rmu(i,j)*
+ & ((swall(i,j,k,lc0)*wc0+swall(i,j,k,lc1)*wc1
+ & +swall(i,j,k,lc2)*wc2+swall(i,j,k,lc3)*wc3)
+ & - saln(i,j,k,n))
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ if (k.ge.3) then
+ pwl=pwall(i,j,k,lc0)*wc0+pwall(i,j,k,lc1)*wc1
+ & +pwall(i,j,k,lc2)*wc2+pwall(i,j,k,lc3)*wc3
+ pwl=max(p(i,j,2),pwl)
+ if (pwl.gt.p(i,j,kk+1)-tencm) then
+ pwl=p(i,j,kk+1)
+ endif
+ p(i,j,k)=min(p(i,j,k+1),
+ & p(i,j,k)+delt1*rmu(i,j)*(pwl-p(i,j,k)))
+ endif !k.ge.3
+ dp(i,j,k,n)=p(i,j,k+1)-p(i,j,k)
+ enddo !k
+ endif !hybrid:isopyc
+ endif !rmu(i,j).ne.0.0
+ 53 continue
+!$OMP END PARALLEL DO
+c
+ endif ! relax = .true.
+c
+c --- ----------------------------
+c --- tracer forcing at sidewalls
+c --- ----------------------------
+c
+ if (trcrlx .and. delt1.ne.baclin) then !not on very 1st time step
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,ktr,pwij,trwij,prij,trcij)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (rmutra(i,j).ne.0.0) then !at least one mask is non-zero
+ prij(1)=0.0
+ do k=1,kk
+ prij(k+1) = prij(k)+dp(i,j,k,n)
+ pwij(k) = pwall(i,j,k,lc0)*wc0
+ & +pwall(i,j,k,lc1)*wc1
+ & +pwall(i,j,k,lc2)*wc2
+ & +pwall(i,j,k,lc3)*wc3
+ do ktr= 1,ntracr
+ trwij(k,ktr) = trwall(i,j,k,lc0,ktr)*wc0
+ & +trwall(i,j,k,lc1,ktr)*wc1
+ & +trwall(i,j,k,lc2,ktr)*wc2
+ & +trwall(i,j,k,lc3,ktr)*wc3
+ enddo !ktr
+ enddo !k
+ pwij(kk+1)=prij(kk+1)
+* call plctrc(trwij,pwij,kk,ntracr,
+* & trcij,prij,kk )
+ call plmtrc(trwij,pwij,kk,ntracr,
+ & trcij,prij,kk )
+ do ktr= 1,ntracr
+ if (rmutr(i,j,ktr).ne.0.0) then
+ do k=1,kk
+ tracer(i,j,k,n,ktr) = tracer(i,j,k,n,ktr)+
+ & delt1*rmutr(i,j,ktr)*(trcij(k,ktr)-
+ & tracer(i,j,k,n,ktr))
+ enddo !k
+ endif !rmutr.ktr.ne.0.0
+ enddo !ktr
+ endif !rmutra.ne.0.0
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ endif ! trcrlx = .true.
+c
+c --- ---------------------------------------------------------
+c --- Update dpu,dpv, and rebalance velocity, if dp has changed
+c --- ---------------------------------------------------------
+c
+ if ((nestfq.ne.0.0 .and. delt1.ne.baclin) .or.
+ & (relax .and. delt1.ne.baclin) ) then
+ call dpudpv(dpu(1-nbdy,1-nbdy,1,n),
+ & dpv(1-nbdy,1-nbdy,1,n),
+ & p,depthu,depthv, margin)
+c
+!$OMP PARALLEL DO PRIVATE(j,i,k,utotij,vtotij)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do i=1-margin,ii+margin
+ if (iu(i,j).eq.1 .and.
+ & max(rmunv(i,j),rmunv(i-1,j),
+ & rmu( i,j),rmu( i-1,j) ).ne.0.0) then
+ utotij = 0.0
+ do k=1,kk
+ utotij = utotij + u(i,j,k,n)*dpu(i,j,k,n)
+ enddo ! k
+ utotij=utotij/depthu(i,j)
+ do k=1,kk
+ u(i,j,k,n) = u(i,j,k,n) - utotij
+ enddo ! k
+ endif !rebalance u
+c
+ if (iv(i,j).eq.1 .and.
+ & max(rmunv(i,j),rmunv(i,j-1),
+ & rmu( i,j),rmu( i,j-1) ).ne.0.0) then
+ vtotij = 0.0
+ do k=1,kk
+ vtotij = vtotij + v(i,j,k,n)*dpv(i,j,k,n)
+ enddo ! k
+ vtotij=vtotij/depthv(i,j)
+ do k=1,kk
+ v(i,j,k,n) = v(i,j,k,n) - vtotij
+ enddo ! k
+ endif !rebalance v
+ enddo !i
+ enddo !j
+!$OMP END PARALLEL DO
+ endif !update dpu,dpv and rebalance u,v
+c
+c --- --------------------------------
+c --- thermal forcing of ocean surface
+c --- --------------------------------
+c
+ if (thermo .or. sstflg.gt.0 .or. srelax) then
+c
+ if (dswflg.eq.1 .and. dtime-dtime_diurnl.gt.1.0) then
+c --- update diurnal factor table
+ call forday(dtime,yrflag, iyear,iday,ihour)
+ day365 = mod(iday+364,365)
+ call thermf_diurnal(diurnl, day365)
+ dtime_diurnl = dtime
+cdiag if (mnproc.eq.1) then
+cdiag write (lp,'(a)') 'diurnl updated'
+cdiag endif !1st tile
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j)
+!$OMP& SHARED(m,n)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ call thermfj(m,n,dtime, j)
+ enddo
+!$OMP END PARALLEL DO
+c
+c --- smooth surface fluxes?
+c
+ if (flxsmo) then
+ call psmooth_ice(surflx, 0)
+ call psmooth_ice(salflx, 0)
+ endif
+c
+ if (nstep.eq.nstep1+1 .or. diagno) then
+ if (nstep.eq.nstep1+1) then
+ nm=m
+ else
+ nm=n
+ endif
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=temp(i,j,1,nm)*scp2(i,j)
+ util2(i,j)=saln(i,j,1,nm)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d1, util1,ip)
+ call xcsum(d2, util2,ip)
+ t1mean=d1
+ s1mean=d2
+c
+!$OMP PARALLEL DO PRIVATE(j,k,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ k=1
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)= dp(i,j,k,nm)*scp2(i,j)
+ util2(i,j)=temp(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ util3(i,j)=saln(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ util4(i,j)=th3d(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ enddo
+ enddo
+ do k=2,kk
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ util1(i,j)=util1(i,j)+ dp(i,j,k,nm)*scp2(i,j)
+ util2(i,j)=util2(i,j)+
+ & temp(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ util3(i,j)=util3(i,j)+
+ & saln(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ util4(i,j)=util4(i,j)+
+ & th3d(i,j,k,nm)*dp(i,j,k,nm)*scp2(i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ call xcsum(d1, util1,ip)
+ call xcsum(d2, util2,ip)
+ call xcsum(d3, util3,ip)
+ call xcsum(d4, util4,ip)
+ pmean=d1
+ tmean=d2/pmean
+ smean=d3/pmean
+ rmean=d4/pmean
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,3f9.3)')
+ & nstep,' mean basin temp, saln, dens ',
+ & tmean,smean,rmean+thbase
+ endif !1st tile
+ if (nstep.eq.nstep1+1) then
+c
+c --- save initial basin means.
+ tmean0=tmean
+ smean0=smean
+ rmean0=rmean
+ else
+c
+c --- diagnostic printout of fluxes.
+ rareac=1.0/(area*(nstep-nstep1))
+ runsec= baclin*(nstep-nstep1)
+ if (yrflag.eq.0) then
+ secpyr=360.00d0*86400.0d0
+ elseif (yrflag.lt.3) then
+ secpyr=366.00d0*86400.0d0
+ elseif (yrflag.ge.3) then
+ secpyr=365.25d0*86400.0d0
+ endif
+ if (mnproc.eq.1) then
+ write (lp,'(i9,a,2f9.3)')
+ & nstep,' mean surface temp and saln ',
+ & t1mean/area,s1mean/area
+ write (lp,'(i9,a,2f9.3,a)')
+ & nstep,' energy residual (atmos,tot) ',
+ & watcum*rareac,
+ & (tmean-tmean0)*(spcifh*avgbot*qthref)/runsec,
+ & ' (W/m^2)'
+c --- note that empcum is now salflx cum.
+ write (lp,'(i9,a,2f9.3,a)')
+ & nstep,' e - p residual (atmos,tot) ',
+ & empcum*(thref/saln0)*rareac*100.0*secpyr,
+ & (smean-smean0)/(saln0*runsec)*avgbot*100.0*secpyr,
+ & ' (cm/year)'
+ write (lp,'(i9,a,2f9.3)')
+ & nstep,' temp drift per century ',
+ & (watcum*rareac/(spcifh*avgbot*qthref))*(secpyr*100.0d0),
+ & (tmean-tmean0)*(secpyr*100.0d0)/runsec
+ write (lp,'(i9,a,2f9.3)')
+ & nstep,' saln drift per century ',
+ & (empcum*rareac/( avgbot*qthref))*(secpyr*100.0d0),
+ & (smean-smean0)*(secpyr*100.0d0)/runsec
+ write (lp,'(i9,a,9x,f9.3)')
+ & nstep,' dens drift per century ',
+ & (rmean-rmean0)*(secpyr*100.0d0)/runsec
+ endif !1st tile
+ call xcsync(flush_lp)
+ endif !master
+ endif !diagno
+c
+ endif ! thermo .or. sstflg.gt.0 .or. srelax
+c
+ return
+ end subroutine thermf
+c
+ subroutine thermfj(m,n,dtime, j)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n, j
+ real*8 dtime
+c
+c --- thermal forcing of ocean surface, for row j.
+c
+ integer i,ihr,ilat,l
+ real radfl,swfl,sstrlx,wind,airt,vpmx,prcp,xtau,ytau,
+ & evap,emnp,snsibl,dsgdt,tmn,smn,rmus,rmut
+ real cd0,clh,cl0,cl1,csh,
+ & rair,slat,ssen,tdif,tsur,wsph,
+ & tamts,q,qva,va
+ real swscl,xhr,xlat
+ real*8 dloc
+c
+c --- 'ustrmn' = minimum ustar
+c --- 'cormn4' = 4 times minimum coriolis magnitude
+c --- 'csubp' = specific heat of air at constant pressure (j/kg/deg)
+c --- 'evaplh' = latent heat of evaporation (j/kg)
+C --- 'csice' = ice-air sensible exchange coefficient
+c
+ real ustrmn,cormn4,csubp,evaplh,csice
+ parameter (ustrmn=1.0e-5,
+ & cormn4=4.0e-5, ! corio(4N) is about 1.e-5
+ & csubp =1005.7,
+ & evaplh=2.47e6,
+ & csice =0.0006)
+c
+c --- parameters primarily for flxflg=1 (ustflg=1)
+c --- 'airdns' = air density at sea level (kg/m**3)
+c --- 'cd' = drag coefficient
+c --- 'ctl' = thermal transfer coefficient (latent)
+c --- 'cts1' = thermal transfer coefficient (sensible, stable)
+c --- 'cts2' = thermal transfer coefficient (sensible, unstable)
+c
+ real airdns,cd,ctl,cts1,cts2
+ parameter (airdns=1.2)
+ parameter (cd =0.0013, ctl =0.0012,
+ & cts1=0.0012, cts2=0.0012)
+c
+c --- parameters primarily for flxflg=2 (ustflg=2)
+c --- 'pairc' = air pressure (mb) * 100
+c --- 'rgas' = gas constant (j/kg/k)
+c --- 'tzero' = celsius to kelvin temperature offset
+c --- 'clmin' = minimum allowed cl
+c --- 'clmax' = maximum allowed cl
+c --- 'wsmin' = minimum allowed wind speed (for cl and cd)
+c --- 'wsmax' = maximum allowed wind speed (for cl and cd)
+c
+ real pairc,rgas,tzero,clmin,clmax,wsmin,wsmax
+ parameter (pairc=1013.0*100.0,
+ & rgas =287.1, tzero=273.16,
+ & clmin=0.0003, clmax=0.002,
+ & wsmin=3.5, wsmax=27.5)
+c
+c --- parameters primarily for flxflg=4
+c --- 'lvtc' = include a virtual temperature correction
+c --- 'vamin' = minimum allowed wind speed (for cl)
+c --- 'vamax' = maximum allowed wind speed (for cl)
+c --- 'tdmin' = minimum allowed Ta-Ts (for cl)
+c --- 'tdmax' = maximum allowed Ta-Ts (for cl)
+c
+c --- 'as0_??' = stable Ta-Ts polynominal coefficients, va<=5m/s
+c --- 'as5_??' = stable Ta-Ts polynominal coefficients, va>=5m/s
+c --- 'au0_??' = unstable Ta-Ts polynominal coefficients, va<=5m/s
+c --- 'au5_??' = unstable Ta-Ts polynominal coefficients, va>=5m/s
+c --- 'an0_??' = neutral Ta-Ts polynominal coefficients, va<=5m/s
+c --- 'an5_??' = neutral Ta-Ts polynominal coefficients, va>=5m/s
+c --- 'ap0_??' = +0.75 Ta-Ts polynominal coefficients, va<=5m/s
+c --- 'ap5_??' = +0.75 Ta-Ts polynominal coefficients, va>=5m/s
+c --- 'am0_??' = -0.75 Ta-Ts polynominal coefficients, va<=5m/s
+c --- 'am5_??' = -0.75 Ta-Ts polynominal coefficients, va>=5m/s
+c
+ logical, parameter :: lvtc =.true.
+ real, parameter :: vamin= 1.2, vamax=40.0
+ real, parameter :: tdmin=-8.0, tdmax= 7.0
+c
+ real, parameter ::
+ & as0_00=-2.925e-4, as0_10= 7.272e-5, as0_20=-6.948e-6,
+ & as0_01= 5.498e-4, as0_11=-1.740e-4, as0_21= 1.637e-5,
+ & as0_02=-5.544e-5, as0_12= 2.489e-5, as0_22=-2.618e-6
+ real, parameter ::
+ & as5_00= 1.023e-3, as5_10=-2.672e-6, as5_20= 1.546e-6,
+ & as5_01= 9.657e-6, as5_11= 2.103e-4, as5_21=-6.228e-5,
+ & as5_02=-2.281e-8, as5_12=-5.329e-3, as5_22= 5.094e-4
+ real, parameter ::
+ & au0_00= 2.077e-3, au0_10=-2.899e-4, au0_20=-1.954e-5,
+ & au0_01=-3.933e-4, au0_11= 7.350e-5, au0_21= 5.483e-6,
+ & au0_02= 3.971e-5, au0_12=-6.267e-6, au0_22=-4.867e-7
+ real, parameter ::
+ & au5_00= 1.074e-3, au5_10= 6.912e-6, au5_20= 1.849e-7,
+ & au5_01= 5.579e-6, au5_11=-2.244e-4, au5_21=-2.167e-6,
+ & au5_02= 5.263e-8, au5_12=-1.027e-3, au5_22=-1.010e-4
+ real, parameter ::
+ & an0_00= 1.14086e-3, an5_00= 1.073e-3,
+ & an0_01=-3.120e-6, an5_01= 5.531e-6,
+ & an0_02=-9.300e-7, an5_02= 5.433e-8
+ real, parameter ::
+ & ap0_00= as0_00 + as0_10*0.75 + as0_20*0.75**2,
+ & ap0_01= as0_01 + as0_11*0.75 + as0_21*0.75**2,
+ & ap0_02= as0_02 + as0_12*0.75 + as0_22*0.75**2
+ real, parameter ::
+ & ap5_00= as5_00 + as5_10*0.75 + as5_20*0.75**2,
+ & ap5_01= as5_01,
+ & ap5_02= as5_02,
+ & ap5_11= as5_11*0.75 + as5_21*0.75**2,
+ & ap5_12= as5_12*0.75 + as5_22*0.75**2
+ real, parameter ::
+ & am0_00= au0_00 - au0_10*0.75 + au0_20*0.75**2,
+ & am0_01= au0_01 - au0_11*0.75 + au0_21*0.75**2,
+ & am0_02= au0_02 - au0_12*0.75 + au0_22*0.75**2
+ real, parameter ::
+ & am5_00= au5_00 - au5_10*0.75 + au5_20*0.75**2,
+ & am5_01= au5_01,
+ & am5_02= au5_02,
+ & am5_11= - au5_11*0.75 + au5_21*0.75**2,
+ & am5_12= - au5_12*0.75 + au5_22*0.75**2
+c
+ real qsatur
+ include 'stmt_fns.h'
+c
+c --- saturation mixing ratio (kg/kg), from a polynominal approximation
+c --- for saturation vapor pressure (lowe, j.appl.met., 16, 100-103, 1976)
+ qsatur(t)=.622e-3*(6.107799961e+00+t*(4.436518521e-01
+ & +t*(1.428945805e-02+t*(2.650648471e-04
+ & +t*(3.031240396e-06+t*(2.034080948e-08
+ & +t* 6.136820929e-11))))))
+c
+c --- salinity relaxation coefficient
+ rmus=1./(30.0*86400.0) !1/30 days
+c
+c --- temperature relaxation coefficient
+ rmut=1./(30.0*86400.0) !1/30 days
+c
+c --- ------------------------------------------------------
+c --- thermal forcing of ocean surface (positive into ocean)
+c --- ------------------------------------------------------
+c
+!DIR$ NO STREAM
+ do l=1,isp(j)
+c
+!DIR$ CONCURRENT
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (flxflg.gt.0) then
+c --- wind = wind speed (m/s)
+ wind=wndspd(i,j,l0)*w0+wndspd(i,j,l1)*w1
+ & +wndspd(i,j,l2)*w2+wndspd(i,j,l3)*w3
+c --- radfl= net radiative thermal flux (W/m^2) +ve into ocean/ice
+c --- = Qsw+Qlw across the atmosphere to ocean or sea-ice interface
+ radfl=radflx(i,j,l0)*w0+radflx(i,j,l1)*w1
+ & +radflx(i,j,l2)*w2+radflx(i,j,l3)*w3
+c --- swfl = shortwave radiative thermal flux (W/m^2) +ve into ocean/ice
+c --- Qsw includes the atmos. model's surface albedo,
+c --- i.e. it already allows for sea-ice&snow where it is observed.
+ swfl =swflx (i,j,l0)*w0+swflx (i,j,l1)*w1
+ & +swflx (i,j,l2)*w2+swflx (i,j,l3)*w3
+ if (dswflg.eq.1) then
+c --- daily to diurnal shortwave correction to swfl and radfl.
+ dloc = dtime + plon(i,j)/360.0
+ xhr = (dloc - int(dloc))*24.0 !local time of day
+ ihr = int(xhr)
+ xhr = xhr - ihr
+ if (plat(i,j).ge.0.0) then
+ ilat = int(plat(i,j))
+ xlat = plat(i,j) - ilat
+ else
+ ilat = int(plat(i,j)) - 1
+ xlat = plat(i,j) - ilat
+ endif
+ swscl = (1.0-xhr)*(1.0-xlat)*diurnl(ihr, ilat ) +
+ & (1.0-xhr)* xlat *diurnl(ihr, ilat+1) +
+ & xhr *(1.0-xlat)*diurnl(ihr+1,ilat ) +
+ & xhr * xlat *diurnl(ihr+1,ilat+1)
+ radfl = radfl - (1.0-swscl)*swfl
+ swfl = swscl *swfl
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write(lp,'(i9,a,2i5,2f8.5)')
+cdiag. nstep,', hr,lat =',ihr,ilat,xhr,xlat
+cdiag write(lp,'(i9,a,5f8.5)')
+cdiag. nstep,', swscl =',swscl,diurnl(ihr, ilat ),
+cdiag. diurnl(ihr, ilat+1),
+cdiag. diurnl(ihr+1,ilat ),
+cdiag. diurnl(ihr+1,ilat+1)
+cdiag call flush(lp)
+cdiag endif !test
+ endif !dswflg
+ if (lwflag.gt.0) then
+c --- over-ocean longwave correction to radfl (Qsw+Qlw).
+ tsur = temp(i,j,1,n)
+ if (lwflag.eq.1) then !from climatology
+ tdif = tsur -
+ & ( twall(i,j,1,lc0)*wc0+twall(i,j,1,lc1)*wc1
+ & +twall(i,j,1,lc2)*wc2+twall(i,j,1,lc3)*wc3)
+ else !w.r.t. atmospheric model's sst
+ tdif = tsur -
+ & ( surtmp(i,j,l0)*w0+surtmp(i,j,l1)*w1
+ & +surtmp(i,j,l2)*w2+surtmp(i,j,l3)*w3)
+ endif
+ !correction is blackbody radiation from tdif at tsur
+ radfl = radfl - (4.506+0.0554*tsur) * tdif
+ !count the correction as a relaxation term
+ sstflx(i,j) = - (4.506+0.0554*tsur) * tdif
+ else
+ sstflx(i,j) = 0.0
+ endif
+ if (pcipf) then
+c --- prcp = precipitation (m/sec; positive into ocean)
+c --- note that if empflg==3, this is actually P-E
+ prcp=precip(i,j,l0)*w0+precip(i,j,l1)*w1
+ & +precip(i,j,l2)*w2+precip(i,j,l3)*w3
+ endif
+ if (flxflg.ne.3) then
+c --- airt = air temperature (C)
+ airt=airtmp(i,j,l0)*w0+airtmp(i,j,l1)*w1
+ & +airtmp(i,j,l2)*w2+airtmp(i,j,l3)*w3
+c --- vpmx = water vapor mixing ratio (kg/kg)
+ vpmx=vapmix(i,j,l0)*w0+vapmix(i,j,l1)*w1
+ & +vapmix(i,j,l2)*w2+vapmix(i,j,l3)*w3
+ endif
+c --- ustar = U* (sqrt(N.m/kg))
+ if (ustflg.eq.3) then !ustar from input
+ ustar(i,j)=ustara(i,j,l0)*w0+ustara(i,j,l1)*w1
+ & +ustara(i,j,l2)*w2+ustara(i,j,l3)*w3
+ elseif (ustflg.eq.1) then !ustar from wndspd, constant cd
+ ustar(i,j)=sqrt(thref*cd*airdns)*wind
+ elseif (ustflg.eq.2) then !ustar from wndspd, variable cd
+ wsph = min( wsmax, max( wsmin, wind ) )
+ cd0 = 0.862e-3 + 0.088e-3 * wsph - 0.00089e-3 * wsph**2
+ rair = pairc / (rgas * ( tzero + airt ))
+ ustar(i,j)=sqrt(thref*cd0*rair)*wind
+ elseif (ustflg.eq.4) then !ustar from surface stress, see montum_hs
+ ustar(i,j)=sqrt(thref*sqrt(surtx(i,j)**2+surty(i,j)**2))
+ endif !ustflg
+ ustar( i,j)=max(ustrmn,ustar(i,j))
+ hekman(i,j)=ustar(i,j)*(cekman*4.0)/
+ & max( cormn4,
+ & abs(corio(i,j ))+abs(corio(i+1,j ))+
+ & abs(corio(i,j+1))+abs(corio(i+1,j+1)) )
+ else !flxlfg==0, i.e. no flux
+ swfl=0.0
+ ustar( i,j)=0.0
+ hekman(i,j)=0.0
+ endif !flxflg
+c
+ if (flxflg.eq.1) then
+c
+c --- MICOM bulk air-sea flux parameterization
+c --- (constant Cl and constant stable/unstable Cs)
+c
+ if (temp(i,j,1,n).lt.airt) then
+ csh=cts1 !stable
+ else
+ csh=cts2 !unstable
+ endif
+c --- evap = evaporation (W/m^2) into atmos from ocean.
+c --- snsibl = sensible heat flux into atmos from ocean.
+ evap =ctl*airdns*evaplh*wind*
+ & max(0.,0.97*qsatur(temp(i,j,1,n))-vpmx)
+ snsibl=csh*airdns*csubp*wind*(temp(i,j,1,n)-airt)
+c --- surflx = thermal energy flux (W/m^2) into ocean
+ surflx(i,j)=radfl - snsibl - evap
+ elseif (flxflg.eq.2) then
+c
+c --- Cl (and Cs) depend on wind speed and Ta-Ts.
+c --- Kara, A. B., P. A. Rochford, and H. E. Hurlburt, 2002:
+c --- Air-sea flux estimates and the 1997-1998 ENSO event.
+c --- Bound.-Layer Meteor., 103, 439-458.
+c --- http://www7320.nrlssc.navy.mil/pubs.php
+c
+ rair = pairc / (rgas * ( tzero + airt ))
+ slat = evaplh*rair
+ ssen = csubp *rair
+c
+ tdif = temp(i,j,1,n) - airt
+ wsph = min( wsmax, max( wsmin, wind ) )
+ cl0 = 0.885e-3 + 0.0748e-3 * wsph - 0.00143e-3 * wsph**2
+ cl1 = -0.113e-4 + 4.89e-4 / wsph
+ clh = min( clmax, max( clmin, cl0 + cl1 * tdif ) )
+ csh = 0.9554*clh
+c
+c --- evap = evaporation (W/m^2) into atmos from ocean.
+c --- snsibl = sensible heat flux (W/m^2) into atmos from ocean.
+c --- surflx = thermal energy flux (W/m^2) into ocean
+ evap = slat*clh*wind*(0.97*qsatur(temp(i,j,1,n))-vpmx)
+ snsibl = ssen*csh*wind* tdif
+ surflx(i,j) = radfl - snsibl - evap
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write(lp,'(i9,2i5,a,4f8.5)')
+cdiag. nstep,i0+i,j0+j,' cl0,cl,cs,cd = ',cl0,clh,csh,cd0
+cdiag write(lp,'(i9,2i5,a,2f8.2,f8.5)')
+cdiag. nstep,i0+i,j0+j,' wsph,tdif,ustar = ',wsph,tdif,ustar(i,j)
+cdiag call flush(lp)
+cdiag endif
+ elseif (flxflg.eq.4) then
+c
+c --- Similar to flxflg.eq.2, but with Cl based on an approximation
+c --- to values from the COARE 3.0 algorithm (Fairall et al., 2003),
+c --- for Cl over the global ocean in the range 1m/s <= Va <= 40m/s
+c --- and -8degC <= Ta-Ts <= 7degC, that is quadratic in Ta-Ts and
+c --- quadratic in either Va or 1/Va (Kara et al., 2005).
+c
+c --- Fairall, C. W., E. F. Bradley, J. E. Hare, A. A. Grachev, and J. B.
+c --- Edson, 2003: Bulk parameterization of air-sea fluxes: Updates
+c --- and verification for the COARE algorithm. J. Climate, 16, 571-591.
+c
+c --- Kara, A. B., H. E. Hurlburt, and A. J. Wallcraft, 2005:
+c --- Stability-dependent exchange coefficients for air-sea fluxes.
+c --- J. Atmos. Oceanic. Technol., 22, 1080-1094.
+c --- http://www7320.nrlssc.navy.mil/pubs.php
+c
+ rair = pairc / (rgas * ( tzero + airt ))
+ slat = evaplh*rair
+ ssen = csubp *rair
+c
+ tdif = temp(i,j,1,n) - airt
+ if (lvtc) then !include a virtual temperature correction
+ tamts = -tdif - 0.61*(airt+tzero)*(qsatur(airt)-vpmx)
+ tamts = min( tdmax, max( tdmin, tamts ) )
+ else
+ tamts = min( tdmax, max( tdmin, -tdif ) )
+ endif !lvtc:else
+ va = min( vamax, max( vamin, wind ) )
+ if (va.le.5.0) then
+ if (tamts.gt. 0.75) then !stable
+ clh = (as0_00 + as0_01* va + as0_02* va**2)
+ & + (as0_10 + as0_11* va + as0_12* va**2)*tamts
+ & + (as0_20 + as0_21* va + as0_22* va**2)*tamts**2
+ elseif (tamts.lt.-0.75) then !unstable
+ clh = (au0_00 + au0_01* va + au0_02* va**2)
+ & + (au0_10 + au0_11* va + au0_12* va**2)*tamts
+ & + (au0_20 + au0_21* va + au0_22* va**2)*tamts**2
+ elseif (tamts.ge.-0.098) then
+ q = (tamts-0.75)/0.848 !linear between 0.75 and -0.098
+ q = q**2 !favor 0.75
+ clh = (1.0-q)*(ap0_00 + ap0_01* va + ap0_02* va**2)
+ & + q *(an0_00 + an0_01* va + an0_02* va**2)
+ else
+ q = (tamts+0.75)/0.652 !linear between -0.75 and -0.098
+ q = q**2 !favor -0.75
+ clh = (1.0-q)*(am0_00 + am0_01* va + am0_02* va**2)
+ & + q *(an0_00 + an0_01* va + an0_02* va**2)
+ endif !tamts
+ else !va>5
+ qva = 1.0/va
+ if (tamts.gt. 0.75) then !stable
+ clh = (as5_00 + as5_01* va + as5_02* va**2)
+ & + (as5_10 + as5_11*qva + as5_12*qva**2)*tamts
+ & + (as5_20 + as5_21*qva + as5_22*qva**2)*tamts**2
+ elseif (tamts.lt.-0.75) then !unstable
+ clh = (au5_00 + au5_01* va + au5_02* va**2)
+ & + (au5_10 + au5_11*qva + au5_12*qva**2)*tamts
+ & + (au5_20 + au5_21*qva + au5_22*qva**2)*tamts**2
+ elseif (tamts.ge.-0.098) then
+ q = (tamts-0.75)/0.848 !linear between 0.75 and -0.098
+ q = q**2 !favor 0.75
+ clh = (1.0-q)*(ap5_00 + ap5_01* va + ap5_02* va**2
+ & + ap5_11*qva + ap5_12*qva**2)
+ & + q *(an5_00 + an5_01* va + an5_02* va**2)
+ else
+ q = (tamts+0.75)/0.652 !linear between -0.75 and -0.098
+ q = q**2 !favor -0.75
+ clh = (1.0-q)*(am5_00 + am5_01* va + am5_02* va**2
+ & + am5_11*qva + am5_12*qva**2)
+ & + q *(an5_00 + an5_01* va + an5_02* va**2)
+ endif !tamts
+ endif !va
+ csh = 0.9554*clh
+c
+c --- evap = evaporation (W/m^2) into atmos from ocean.
+c --- snsibl = sensible heat flux (W/m^2) into atmos from ocean.
+c --- surflx = thermal energy flux (W/m^2) into ocean
+ evap = slat*clh*wind*(0.97*qsatur(temp(i,j,1,n))-vpmx)
+ snsibl = ssen*csh*wind* tdif
+ surflx(i,j) = radfl - snsibl - evap
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag write(lp,'(i9,2i5,a,3f8.5)')
+cdiag. nstep,i0+i,j0+j,' cl,cs,cd = ',clh,csh,cd0
+cdiag write(lp,'(i9,2i5,a,2f8.2,f8.5)')
+cdiag. nstep,i0+i,j0+j,' va,tamst,ustar = ',va,tamts,ustar(i,j)
+cdiag call flush(lp)
+cdiag endif
+ elseif (flxflg.eq.3) then
+c
+c --- input radiation flux is the net flux.
+c
+ evap=0.0
+ surflx(i,j)=radfl
+ else ! no flux
+ evap=0.0
+ surflx(i,j)=0.0
+ endif ! flxflg
+c
+c --- add a time-invarient net heat flux offset
+ if (flxoff) then
+ surflx(i,j)=surflx(i,j)+offlux(i,j)
+ endif
+c
+c --- relax to surface temperature
+c --- use a reference relaxation thickness (min. mixed layer depth)
+c --- in shallow water, thkmlt is replaced by the total depth
+c --- actual e-folding time is (dpmixl(i,j,n)/(thkmlt*onem))/rmut
+c --- in shallow water this is (dpmixl(i,j,n)/p(i,j,kk+1) )/rmut
+ if (sstflg.eq.1) then !climatological sst
+ sstrlx=
+ & (rmut*spcifh*min(p(i,j,kk+1),thkmlt*onem)/g)*
+ & ( ( twall(i,j,1,lc0)*wc0+twall(i,j,1,lc1)*wc1
+ & +twall(i,j,1,lc2)*wc2+twall(i,j,1,lc3)*wc3) -
+ & temp(i,j,1,n) )
+ surflx(i,j)=surflx(i,j)+sstrlx
+ sstflx(i,j)=sstflx(i,j)+sstrlx
+ elseif (sstflg.gt.1) then !synoptic sst
+ sstrlx=
+ & (rmut*spcifh*min(p(i,j,kk+1),thkmlt*onem)/g)*
+ & ( ( seatmp(i,j,l0)*w0+seatmp(i,j,l1)*w1
+ & +seatmp(i,j,l2)*w2+seatmp(i,j,l3)*w3) -
+ & temp(i,j,1,n) )
+ surflx(i,j)=surflx(i,j)+sstrlx
+ sstflx(i,j)=sstflx(i,j)+sstrlx
+ endif
+c --- sswflx = shortwave radiative energy flux (W/m^2) into ocean
+ sswflx(i,j)=swfl
+c --- emnp = evaporation minus precipitation (m/sec) into atmos.
+ if (.not.pcipf) then
+ prcp = 0.0
+ emnp = 0.0 !no E-P
+ elseif (empflg.eq.3) then
+ emnp = -prcp !input prcp is P-E
+ else
+ emnp = evap*thref/evaplh - prcp !input prcp is P
+ endif
+c --- allow for rivers as a precipitation bogas
+ if (priver) then
+ emnp=emnp - ( rivers(i,j,lr0)*wr0+rivers(i,j,lr1)*wr1
+ & +rivers(i,j,lr2)*wr2+rivers(i,j,lr3)*wr3)
+ endif
+c --- salflx = salt flux (10**-3 kg/m**2/sec) into ocean
+ salflx(i,j)=emnp*(saln(i,j,1,n)*qthref)
+c --- relax to surface salinity
+ if (srelax) then
+c --- use a reference relaxation thickness (min. mixed layer depth)
+c --- in shallow water, thkmls is replaced by the total depth
+c --- actual e-folding time is (dpmixl(i,j,n)/(thkmls*onem))/rmus
+c --- in shallow water this is (dpmixl(i,j,n)/p(i,j,kk+1) )/rmus
+ sssflx(i,j)=
+ & (rmus*min(p(i,j,kk+1),thkmls*onem)/g)*
+ & ( ( swall(i,j,1,lc0)*wc0+swall(i,j,1,lc1)*wc1
+ & +swall(i,j,1,lc2)*wc2+swall(i,j,1,lc3)*wc3) -
+ & saln(i,j,1,n) )
+* salflx(i,j)=salflx(i,j)+sssflx(i,j) !update salflx in thermf_oi
+ else
+ sssflx(i,j)=0.0
+ endif !srelax
+ enddo !i
+ enddo !l
+ return
+ end subroutine thermfj
+
+ subroutine thermf_diurnal(diurnal, date)
+ implicit none
+c
+ real diurnal(0:24,-91:91),date
+c
+c --- Calculate a table of latitude vs hourly scale factors
+c --- for the distribution of daily averaged solar radiation
+c --- the clear sky insolation formula of Lumb (1964) is used with
+c --- correction for the seasonally varying earth-sun distance.
+c --- According to reed (1977) the lumb formula gives values in close
+c --- agreement with the daily mean values of the seckel and beaudry
+c --- (1973) formulae derived from data in the smithsonian
+c --- meteorological tables --- (list, 1958).
+c
+c --- Lumb, F. E., 1964: The influence of cloud on hourly amounts of
+c --- total solar radiation at sea surface.Quart. J. Roy. Meteor. Soc.
+c --- 90, pp43-56.
+c
+c --- date = julian type real date - 1.0 (range 0. to 365.),
+c --- where 00z jan 1 = 0.0.
+c
+c --- Base on "QRLUMB" created 2-4-81 by Paul J Martin. NORDA Code 322.
+c
+ real, parameter :: pi = 3.14159265
+ real, parameter :: raddeg = pi/180.0
+c
+ integer lat,ihr
+ real sindec,cosdec,alatrd,fd,ourang,sinalt,ri,qsum
+ real*8 sum
+c
+c calc sin and cosin of the declination angle of the sun.
+ call declin(date,sindec,cosdec)
+c
+c loop through latitudes
+ do lat= -90,90
+c calc latitude of site in radians.
+ alatrd = lat*raddeg
+c
+c loop through hours
+ sum = 0.0
+ do ihr= 0,23
+c calc hour angle of the sun (the angular distance of the sun
+c from the site, measured to the west) in radians.
+ fd = real(ihr)/24.0
+ ourang = (fd-0.5)*2.0*pi
+c calc sine of solar altitude.
+ sinalt = sin(alatrd)*sindec+cos(alatrd)*cosdec*cos(ourang)
+c
+c calc clear-sky solar insolation from lumb formula.
+ if (sinalt.le.0.0) then
+ diurnal(ihr,lat) = 0.0
+ else
+ ri=1.00002+.01671*cos(0.01720242*(date-2.1))
+ diurnal(ihr,lat) = 2793.0*ri*ri*sinalt*(.61+.20*sinalt)
+ endif
+ sum = sum + diurnal(ihr,lat)
+ enddo !ihr
+ if (sum.gt.0.0) then
+c rescale so that sum is 24.0 (daily average to diurnal factor)
+ qsum = 24.0/sum
+ do ihr= 0,23
+ diurnal(ihr,lat) = diurnal(ihr,lat)*qsum
+ enddo !ihr
+ endif
+ diurnal(24,lat) = diurnal(0,lat) !copy for table lookup
+ enddo !lat
+ do ihr= 0,24
+ diurnal(ihr,-91) = diurnal(ihr,-90) !copy for table lookup
+ diurnal(ihr, 91) = diurnal(ihr, 90) !copy for table lookup
+ enddo !ihr
+ return
+c
+ contains
+ subroutine declin(date,sindec,cosdec)
+ implicit none
+c
+ real date,sindec,cosdec
+c
+c subroutine to calc the sin and cosin of the solar declination angle
+c as a function of the date.
+c date = julian type real date - 1.0 (range 0. to 365.), where 00z
+c jan 1 = 0.0.
+c sindec = returned sin of the declination angle.
+c cosdec = returned cosin of the declination angle.
+c formula is from fnoc pe model.
+c created 10-7-81. paul j martin. norda code 322.
+c
+ real a
+c
+ a=date
+ sindec=.39785*sin(4.88578+.0172*a+.03342*sin(.0172*a)-
+ & .001388*cos(.0172*a)+.000348*sin(.0344*a)-.000028*cos(.0344*a))
+ cosdec=sqrt(1.-sindec*sindec)
+ return
+ end subroutine declin
+ end subroutine thermf_diurnal
+
+c
+c
+c> Revision history:
+c>
+c> Oct. 1999 - surface flux calculations modified for kpp mixed layer model,
+c> including penetrating solar radiation based on jerlov water type
+c> Apr. 2000 - conversion to SI units
+c> Oct 2000 - added thermfj to simplify OpenMP logic
+c> Dec 2000 - modified fluxes when ice is present
+c> Dec 2000 - added Kara bulk air-sea flux parameterization (flxflg=2)
+c> May 2002 - buoyfl now calculated in mixed layer routine
+c> Aug 2002 - added nested velocity relaxation
+c> Nov 2002 - separate sss and sst relaxation time scales (thkml[st])
+c> Nov 2002 - save sssflx and sstflx for diagnostics
+c> Mar 2003 - longwave radiation correction for model vs "longwave" SST
+c> May 2003 - use seatmp in place of twall.1, when available
+c> Mar 2003 - add option to smooth surface fluxes
+c> Mar 2004 - added epmass for treating E-P as a mass exchange
+c> Mar 2005 - limit thkml[st] to no more than the actual depth
+c> Mar 2005 - added empflg
+c> Mar 2005 - replaced qsatur with 97% of qsatur in evap calculation
+c> Mar 2005 - added ustflg
+c> Mar 2005 - added flxoff
+c> Apr 2005 - add a virtual temperature correction to Ta-Ts for flxflg=4.
+c> Jun 2006 - explicit separation of ocean and sea ice surface fluxes
+c> Jun 2007 - rebalance velocity after sidewall and nestwall relaxation
+c> Oct 2008 - add dswflg
diff --git a/src_2.2.18_3_one/trcupd.f b/src_2.2.18_3_one/trcupd.f
new file mode 100755
index 0000000..2c7d121
--- /dev/null
+++ b/src_2.2.18_3_one/trcupd.f
@@ -0,0 +1,1130 @@
+ subroutine initrc(mnth)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer mnth
+c
+c --- --------------------------
+c --- initializatize all tracers
+c --- --------------------------
+c
+ logical lpipe_initrc
+ parameter (lpipe_initrc=.false.)
+c
+ character ptxt*12,cformat*99
+ integer i,ibio,nbio,j,k,ktr,l
+ real bio_n,bio_p,zk
+ real pwij(kk+1),trwij(kk,ntracr),
+ & prij(kk+1),trcij(kk,ntracr)
+c
+ if (ntracr.eq.0) then
+ return ! no tracer
+ endif
+c
+c --- expand trcflg to allow for number of biology fields.
+c
+ nbio = 0
+ ibio = 0
+ do ktr= 1,ntracr+1
+ if (ktr.ne.ntracr+1 .and.
+ & trcflg(min(ktr,ntracr)).eq.9) then
+ if (ibio.eq.0) then !start biology
+ ibio = ktr
+ endif
+ elseif (ibio.ne.0) then !end biology
+ nbio = ktr-ibio
+ if (nbio.eq.3) then
+c --- Franks NPZ.
+ trcflg(ibio) = 903
+ trcflg(ibio+1) = -903
+ trcflg(ibio+2) = -903
+ ibio = 0
+ elseif (nbio.eq.3) then
+c --- Two Franks NPZ.
+ trcflg(ibio) = 903
+ trcflg(ibio+1) = -903
+ trcflg(ibio+2) = -903
+ trcflg(ibio+3) = 903
+ trcflg(ibio+4) = -903
+ trcflg(ibio+5) = -903
+ ibio = 0
+ elseif (nbio.eq.4) then
+c --- Lima/Idrisi NPZD.
+ trcflg(ibio) = 904
+ trcflg(ibio+1) = -904
+ trcflg(ibio+2) = -904
+ trcflg(ibio+3) = -904
+ ibio = 0
+ elseif (nbio.eq.7) then
+c --- Lima/Idrisi NPZD and Franks NPZ.
+ trcflg(ibio) = 904
+ trcflg(ibio+1) = -904
+ trcflg(ibio+2) = -904
+ trcflg(ibio+3) = -904
+ trcflg(ibio+4) = 903
+ trcflg(ibio+5) = -903
+ trcflg(ibio+6) = -903
+ ibio = 0
+ elseif (nbio.eq.8) then
+c --- Two Lima/Idrisi NPZD.
+ trcflg(ibio) = 904
+ trcflg(ibio+1) = -904
+ trcflg(ibio+2) = -904
+ trcflg(ibio+3) = -904
+ trcflg(ibio+4) = 904
+ trcflg(ibio+5) = -904
+ trcflg(ibio+6) = -904
+ trcflg(ibio+7) = -904
+ ibio = 0
+ elseif (nbio.eq.9) then
+c --- Chai 9-component.
+* trcflg(ibio) = 909
+* trcflg(ibio+1) = -909
+* trcflg(ibio+2) = -909
+* trcflg(ibio+3) = -909
+* trcflg(ibio+4) = -909
+* trcflg(ibio+5) = -909
+* trcflg(ibio+6) = -909
+* trcflg(ibio+7) = -909
+* trcflg(ibio+8) = -909
+* ibio = 0
+c --- not yet implemented
+ if (mnproc.eq.1) then
+ write(lp,'(/ 3a /)')
+ & 'error - trcflg=9 (standard biology) configured',
+ & ' with 9 consecutive tracers, but Chai scheme is',
+ & ' not yet implemented'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(trcini)')
+ stop '(trcini)'
+ else
+c --- unknown standard biology.
+ if (mnproc.eq.1) then
+ write(lp,'(/ 2a,i3 /)')
+ & 'error - trcflg=9 (standard biology) expects',
+ & ' 3/4/6/7/8 consecutive tracers but have',nbio
+* & ' 3/4/6/7/8/9 consecutive tracers but have',nbio
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(trcini)')
+ stop '(trcini)'
+ endif
+ endif
+ enddo
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ do k= 1,ntracr
+ write(lp,'(a,i3,i6)') 'initrc: k,trcflg =',k,trcflg(k)
+ enddo
+ write(lp,*)
+ endif !1st tile
+c
+ if (nbio.gt.0) then
+c
+c --- input bio-tracer parameters.
+c --- note that multiple sets of bio-tracers are allowed,
+c --- each is read from tracer.input in tracer order.
+c
+ open(unit=uoff+99,file=trim(flnminp)//'tracer.input')
+ do ktr= 1,ntracr
+ if (trcflg(ktr).eq.903) then
+c --- NPZ
+ call trcupd_903(1,2, -ktr)
+ elseif (trcflg(ktr).eq.904) then
+c --- NPZD
+ call trcupd_904(1,2, -ktr)
+* elseif (trcflg(ktr).eq.909) then
+* --- Chai 9-component.
+* call trcupd_909(1,2, -ktr)
+ endif
+ enddo
+ close(unit=uoff+99)
+ endif
+c
+ if (trcrin) then
+ return ! tracer from restart
+ endif
+c
+ margin = 0
+c
+ if (iniflg.eq.2) then ! use climatology
+ call rdrlax(mnth,1)
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,ktr,pwij,trwij,prij,trcij)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ prij(1)=0.0
+ do k=1,kk
+ prij(k+1)=prij(k)+dp(i,j,k,1)
+ pwij(k) =pwall(i,j,k,1)
+ do ktr= 1,ntracr
+ trwij(k,ktr)=trwall(i,j,k,1,ktr)
+ enddo !ktr
+ enddo !k
+ pwij(kk+1)=prij(kk+1)
+* call plctrc(trwij,pwij,kk,ntracr,
+* & trcij,prij,kk )
+ call plmtrc(trwij,pwij,kk,ntracr,
+ & trcij,prij,kk )
+ do k=1,kk
+ do ktr= 1,ntracr
+ tracer(i,j,k,1,ktr)=trcij(k,ktr)
+ tracer(i,j,k,2,ktr)=trcij(k,ktr)
+ enddo !ktr
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ else ! analytic inititalization
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,ktr)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ p(i,j,1)=0.0
+ do k=1,kk
+ p(i,j,k+1)=p(i,j,k)+dp(i,j,k,1)
+ do ktr= 1,ntracr
+ if (trcflg(ktr).eq.0) then !100% in the mixed layer
+ if (p(i,j,k).le.dpmixl(i,j,1)) then
+ tracer(i,j,k,1,ktr)=10.0
+ tracer(i,j,k,2,ktr)=10.0
+ else
+ tracer(i,j,k,1,ktr)=0.0
+ tracer(i,j,k,2,ktr)=0.0
+ endif
+ elseif (trcflg(ktr).eq.1) then !20 below euphotic zone
+ if (p(i,j,k)*betabl(jerlv0).lt.4.0) then
+ tracer(i,j,k,1,ktr)=0.0
+ tracer(i,j,k,2,ktr)=0.0
+ else
+ tracer(i,j,k,1,ktr)=20.0 ! mg/m^3
+ tracer(i,j,k,2,ktr)=20.0 ! mg/m^3
+ endif
+ elseif (trcflg(ktr).eq.2) then !temperature
+ tracer(i,j,k,1,ktr)=temp(i,j,k,1)
+ tracer(i,j,k,2,ktr)=temp(i,j,k,1)
+ elseif (trcflg(ktr).eq.3) then !fully passive
+ tracer(i,j,k,1,ktr)=0.0 !should never get here
+ tracer(i,j,k,2,ktr)=0.0 !should never get here
+ elseif (trcflg(ktr).eq.904 .or.
+ & trcflg(ktr).eq.903 ) then !NPZD or NPZ
+ zk = 0.5*(p(i,j,k+1)+p(i,j,k))*qonem
+ if (zk.le.300.0) then
+ ! 0.1 at 300m, 1.0 at 100m, 2.025 at 0m
+ bio_p = 0.1 + (300.0-zk)**2 * (0.9/200.0**2)
+ elseif (zk.le.900.0) then
+ ! 0.1 at 300m, 0.0 at 900m
+ bio_p = (900.0-zk) * 0.1/600.0
+ else
+ bio_p = 0.0
+ endif
+ if (temp(i,j,k,1).lt. 6.0) then
+ bio_n = 37.0
+ elseif (temp(i,j,k,1).gt.27.0) then
+ bio_n = 0.0
+ else
+* bio_n = (27.0-temp(i,j,k,1)) * 37.0/21.0
+ bio_n = 39.3116-1.335*temp(i,j,k,1)
+ endif
+ tracer(i,j,k,1,ktr )=bio_n !N
+ tracer(i,j,k,2,ktr )=bio_n
+ tracer(i,j,k,1,ktr+1)=bio_p !P
+ tracer(i,j,k,2,ktr+1)=bio_p
+ tracer(i,j,k,1,ktr+2)=bio_p !Z=P
+ tracer(i,j,k,2,ktr+2)=bio_p
+ if (trcflg(ktr).eq.904) then
+ tracer(i,j,k,1,ktr+3)=bio_p + 1.0 !D=P+1
+ tracer(i,j,k,2,ktr+3)=bio_p + 1.0
+ endif
+ endif !trcflg
+ enddo !ktr
+ enddo !k
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ endif !iniflg.eq.2:else
+c
+ if (lpipe .and. lpipe_initrc) then
+ do ktr= 1,ntracr
+ do k= 1,kk
+ write (ptxt,'(a4,i2.2,a3,i3)') 'trc.',ktr,' k=',k
+ call pipe_compare_sym1(tracer(1-nbdy,1-nbdy,k,1,ktr),
+ & ip,ptxt)
+ enddo !k
+ enddo !ktr
+ endif !lpipe.and.lpipe_initrc
+c
+ if (itest.gt.0 .and. jtest.gt.0) then
+ write(cformat,'(a,i2,a,i2,a)')
+ & '(i9,2i5,a,',ntracr,
+ & 'a / (23x,i3,2f8.2,', ntracr,'f8.4))'
+ write (lp,cformat)
+ & nstep,i0+itest,j0+jtest,
+ & ' istate: thkns dpth',
+ & (' tracer',ktr=1,ntracr),
+ & (k,
+ & dp(itest,jtest,k,1)*qonem,
+ & (p(itest,jtest,k+1)+p(itest,jtest,k))*0.5*qonem,
+ & (tracer(itest,jtest,k,1,ktr),ktr=1,ntracr),
+ & k=1,kk)
+ write(lp,'(23x,a,8x,f8.2)') 'bot',depths(itest,jtest)
+ endif !test tile
+ call xcsync(flush_lp)
+c
+ return
+ end
+
+ subroutine trcupd(m,n)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- -----------------------------------------------------------
+c --- tracer-specific operations (side-wall relaxation in thermf)
+c --- -----------------------------------------------------------
+c
+ integer i,j,k,ktr,l
+ real beta_b,pijk,pijkp,q
+c
+ margin = 0 ! no horizontal derivatives
+c
+ do ktr= 1,ntracr
+ if (trcflg(ktr).eq.0) then
+ if (trcrlx) then
+c --- tracer always trwall, when non-zero, at surface
+!$OMP PARALLEL DO PRIVATE(j,k,l,i,ktr,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ q = trwall(i,j,1,lc0,ktr)*wc0
+ & +trwall(i,j,1,lc1,ktr)*wc1
+ & +trwall(i,j,1,lc2,ktr)*wc2
+ & +trwall(i,j,1,lc3,ktr)*wc3
+ if (q.gt.0.0) then
+ tracer(i,j,1,n,ktr) = q
+ endif
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ elseif (.not. trcrlx) then
+c --- tracer always 10.0 at surface
+!$OMP PARALLEL DO PRIVATE(j,k,l,i,ktr)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ tracer(i,j,1,n,ktr) = 10.0
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ endif !trcrlx:else
+ elseif (trcflg(ktr).eq.1) then
+c --- psudo-silicate, half-life of 30 days in euphotic zone
+ q = 1.0-delt1/(30.0*86400.0)
+!$OMP PARALLEL DO PRIVATE(j,k,l,i,ktr,pijk,pijkp,beta_b)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0
+ & +akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2
+ & +akpar(i,j,lk3)*wk3)
+ else
+ beta_b = betabl(jerlov(i,j))
+ endif
+ pijkp=0.0
+ do k=1,kk
+ pijk = pijkp
+ pijkp = pijk+dp(i,j,k,n)
+ if (0.5*(pijk+pijkp)*beta_b.lt.4.0) then
+ tracer(i,j,k,n,ktr) = q*tracer(i,j,k,n,ktr)
+ else
+ exit !too deep
+ endif
+ enddo
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ elseif (trcflg(ktr).eq.2) then
+c --- temperature-like (do nothing, heat flux forcing in mixed layer)
+ elseif (trcflg(ktr).eq.3) then
+c --- fully passive (do nothing)
+ elseif (trcflg(ktr).eq.903) then
+c --- NPZ
+ call trcupd_903(m,n, ktr)
+ elseif (trcflg(ktr).eq.904) then
+c --- NPZD
+ call trcupd_904(m,n, ktr)
+* elseif (trcflg(ktr).eq.909) then
+* --- Chai 9-component.
+* call trcupd_909(m,n, ktr)
+ endif
+ enddo !ktr
+ return
+ end subroutine trcupd
+
+ subroutine trcupd_903(m,n, ibio)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n,ibio
+c
+c --- -------------------------------------------------
+c --- tracer-specific operations for Franks NPZ biology
+c --- -------------------------------------------------
+c
+ real, save, dimension(mxtrcr) ::
+ & bup, ! maximum growth rate of phytoplankton (1/d).
+ & bgz, ! maximum grazing rate of zooplankton (1/d).
+ & bdp, ! senescence (death) rate of phytoplankton (1/d).
+ & bdz, ! death rate of zooplankton (1/d).
+ & buk, ! = half-saturation coefficient for phytoplankton (mg/m^3)
+ & asim, ! assimilation efficiency of zooplankton.
+ & glam ! Ivlev parameter for grazing efficiency of zooplankton.
+c
+ integer i,j,k,l
+ real bm_n,bm_p,bm_z,bn_n,bn_p,bn_z,bu_n,bu_p,bu_z,
+ & uptake,grazin,pdeath,zdeath,
+ & pijk,pijkp,par,beta_b,frac_b
+c
+ if (ibio.lt.0) then !initialize only
+c
+c --- read from tracer_NN.input:
+c --- 'biotyp' = type (90X=std.bio,X=3,4,9) must be 903
+c --- 'bup ' = maximum growth rate of phytoplankton (1/d).
+c --- 'bgz ' = maximum grazing rate of zooplankton (1/d).
+c --- 'bdp ' = senescence (death) rate of phytoplankton (1/d).
+c --- 'bdz ' = death rate of zooplankton (1/d).
+c --- 'buk ' = half-saturation coefficient for phytoplankton (mg/m^3)
+c --- 'asim ' = assimilation efficiency of zooplankton.
+c --- 'glam ' = Ivlev parameter for grazing efficiency of zooplankton.
+c
+ i = -ibio
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3,a,i3,a)')
+ & 'Franks NPZ parameters for tracers',i,' to',i+2,':'
+ endif !1st tile
+c
+ call blkini(k, 'biotyp')
+ if (k.ne.903) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - biotyp must be 903'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(trcini)')
+ stop '(trcini)'
+ endif !biotyp.ne.903
+c
+ call blkinr(bup( i), 'bup ','(a6," =",f10.4," 1/d")')
+ call blkinr(bgz( i), 'bgz ','(a6," =",f10.4," 1/d")')
+ call blkinr(bdp( i), 'bdp ','(a6," =",f10.4," 1/d")')
+ call blkinr(bdz( i), 'bdz ','(a6," =",f10.4," 1/d")')
+ call blkinr(buk( i), 'buk ','(a6," =",f10.4," mg/m^3")')
+ call blkinr(asim( i), 'asim ','(a6," =",f10.4," ")')
+ call blkinr(glam( i), 'glam ','(a6," =",f10.4," ")')
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ return
+ endif !ibio.lt.0
+c
+c --- leapfrog time step.
+c
+ margin = 0 ! no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,pijk,pijkp,par,
+!$OMP& beta_b,frac_b,
+!$OMP& bm_n,bm_p,bm_z,bn_n,bn_p,bn_z,
+!$OMP& bu_n,bu_p,bu_z,
+!$OMP& uptake,grazin,pdeath,zdeath)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0
+ & +akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2
+ & +akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ else
+ beta_b = betabl(jerlov(i,j))
+ frac_b = 1.0 - redfac(jerlov(i,j))
+ endif
+ pijkp=0.0
+ do k=1,kk
+ pijk = pijkp
+ pijkp = pijk+dp(i,j,k,n)
+ par = frac_b*exp(-0.5*(pijk+pijkp)*beta_b)
+c
+ bm_n = tracer(i,j,k,m,ibio)
+ bm_p = tracer(i,j,k,m,ibio+1)
+ bm_z = tracer(i,j,k,m,ibio+2)
+ bn_n = tracer(i,j,k,n,ibio)
+ bn_p = tracer(i,j,k,n,ibio+1)
+ bn_z = tracer(i,j,k,n,ibio+2)
+c
+ uptake = bup(ibio)*bm_p*bm_n*par/(buk(ibio)+bm_n)
+ grazin = bgz(ibio)*bm_z*(1.0-exp(-glam(ibio)*bm_p))
+ pdeath = bdp(ibio)*bm_p
+ zdeath = bdz(ibio)*bm_z
+ ! limit negative terms to 10% of total per single time step
+ grazin = min(grazin,bn_p*0.2*86400.0/delt1)
+ uptake = min(uptake,bn_n*0.2*86400.0/delt1)
+c
+ bu_p = -grazin +uptake-pdeath
+ bu_z = asim(ibio) *grazin-zdeath
+ bu_n = (1.0-asim(ibio))*grazin+zdeath-uptake+pdeath
+c
+ tracer(i,j,k,n,ibio) = bn_n + delt1/86400.0 * bu_n
+ tracer(i,j,k,n,ibio+1) = bn_p + delt1/86400.0 * bu_p
+ tracer(i,j,k,n,ibio+2) = bn_z + delt1/86400.0 * bu_z
+c
+c --- fields must be non-negative
+c --- note: only round-off should make a field negative
+c
+ if (tracer(i,j,k,n,ibio+1).lt.0.0) then !PtoN
+ tracer(i,j,k,n,ibio) = tracer(i,j,k,n,ibio) -
+ & tracer(i,j,k,n,ibio+1)
+ tracer(i,j,k,n,ibio+1) = 0.0
+ endif
+ if (tracer(i,j,k,n,ibio+2).lt.0.0) then !ZtoN
+ tracer(i,j,k,n,ibio) = tracer(i,j,k,n,ibio) -
+ & tracer(i,j,k,n,ibio+2)
+ tracer(i,j,k,n,ibio+2) = 0.0
+ endif
+ if (tracer(i,j,k,n,ibio) .lt.0.0) then !NtoPZ (do last)
+ tracer(i,j,k,n,ibio+1) = tracer(i,j,k,n,ibio+1) -
+ & tracer(i,j,k,n,ibio)*0.5
+ tracer(i,j,k,n,ibio+2) = tracer(i,j,k,n,ibio+2) -
+ & tracer(i,j,k,n,ibio)*0.5
+ tracer(i,j,k,n,ibio) = 0.0
+ endif
+ enddo
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ return
+ end subroutine trcupd_903
+
+ subroutine trcupd_904(m,n, ibio)
+ use mod_xc ! HYCOM communication interface
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n,ibio
+c
+c --- -------------------------------------------------------
+c --- tracer-specific operations for Lima/Idrisi NPZD biology
+c --- -------------------------------------------------------
+c
+ real, save, dimension(mxtrcr) ::
+ & pp, ! zoopl: preference term for phytoplankton
+ & pz, ! zoopl: preference term for zooplankton
+ & pd, ! zoopl: preference term for detritus
+ & aa, ! zoopl: assimilation efficiency
+ & am, ! zoopl: metabolic efficiency
+ & fkz, ! zoopl: half-saturation coefficient (mg/m^3)
+ & gmax, ! zoopl: maximum growth rate (1/day)
+ & zmor ! zoopl: mortality (1/day)
+c
+ real, save, dimension(mxtrcr) ::
+* & ik, ! phyto: light absorption efficiency scalar (einst/m^2/h)
+ & fkp, ! phyto: half-saturation coefficient (mg/m^3)
+ & pmax, ! phyto: maximum growth rate (1/day)
+ & psen ! phyto: senescence (1/day)
+c
+ real, save, dimension(mxtrcr) ::
+ & remn ! detri: remineralization (1/day)
+c
+ integer, save, dimension(mxtrcr) ::
+ & spcflg ! tmpfn: species type (0=none,1=cold-water,2=warm-water)
+c
+ real, parameter :: ! temperature function for cold-water species
+ & ! thornton and lessem (1978)
+ & theta1 = 16.0, ! dependence on lower optimum temperature curve
+ & theta2 = 9.0, ! dependence on higher optimum temperature curve
+ & theta3 = 11.0, ! maximum temperature (upper tolerance level)
+ & q10l = 2.0, ! the metabolic q10 for temperature response
+ & xk1 = 0.5, ! scalar constant
+ & xk2 = 0.98, ! scalar constant
+ & xk3 = 0.01, ! scalar constant
+ & xk4 = 0.01 ! scalar constant
+c
+ real, parameter :: ! temperature function for warm-water species
+ & tmax = 27.0, ! Tfunc: maximum tolerated temperature
+ & topt = 25.0, ! Tfunc: optimum temperature
+ & q10w = 2.0 ! Tfunc: the metabolic q10 for temperature response
+c
+ integer i,j,k,l
+ real bm_n,bm_p,bm_z,bm_d,bn_n,bn_p,bn_z,bn_d,
+ & bu_n,bu_p,bu_z,bu_d,
+ & gamma1,gamma2,xnum,xkatheta,ynum,xkbtheta,
+ & tijk,tfn,vw,xw,yw,zw,
+ & pgrw,zgrw,pref,prf2,qprf,ztgx,dofz,pofz,zofz,
+ & pijk,pijkp,par,beta_b,frac_b
+c
+ if (ibio.lt.0) then !initialize only
+c
+c --- read from tracer.input:
+c --- 'biotyp' = type (90X=std.bio,X=3,4,9) must be 904
+c
+c --- 'pp ' = zoopl: preference term for phytoplankton
+c --- 'pz ' = zoopl: preference term for zooplankton
+c --- 'pd ' = zoopl: preference term for detritus
+c --- 'aa ' = zoopl: assimilation efficiency
+c --- 'am ' = zoopl: metabolic efficiency
+c --- 'fkz ' = zoopl: half-saturation coefficient (mg/m^3)
+c --- 'gmax ' = zoopl: maximum growth rate (1/day)
+c --- 'zmor ' = zoopl: mortality (1/day)
+c
+* --- 'ik ' = phyto: light absorption efficiency scalar (einst/m^2/h)
+c --- 'fkp ' = phyto: half-saturation coefficient (mg/m^3)
+c --- 'pmax ' = phyto: maximum growth rate (1/day)
+c --- 'psen ' = phyto: senescence (1/day)
+c
+c --- 'remn ' = detri: remineralization (1/day)
+c
+c --- 'spcflg' = tmpfn: species type (0=none,1=cold-water,2=warm-water)
+c
+ i = -ibio
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3,a,i3,a)')
+ & 'Lima/Idrisi NPZD parameters for tracers',i,' to',i+3,':'
+ endif !1st tile
+c
+ call blkini(k, 'biotyp')
+ if (k.ne.904) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a /)')
+ & 'error - biotyp must be 904'
+ call flush(lp)
+ endif !1st tile
+ call xcstop('(trcini)')
+ stop '(trcini)'
+ endif !biotyp.ne.904
+c
+ call blkinr(pp( i), 'pp ','(a6," =",f10.4," ")')
+ call blkinr(pz( i), 'pz ','(a6," =",f10.4," ")')
+ call blkinr(pd( i), 'pd ','(a6," =",f10.4," ")')
+ call blkinr(aa( i), 'aa ','(a6," =",f10.4," ")')
+ call blkinr(am( i), 'am ','(a6," =",f10.4," ")')
+ call blkinr(fkz( i), 'fkz ','(a6," =",f10.4," mg/m^3")')
+ call blkinr(gmax( i), 'gmax ','(a6," =",f10.4," 1/day")')
+ call blkinr(zmor( i), 'zmor ','(a6," =",f10.4," 1/day")')
+c
+ call blkinr(fkp( i), 'fkp ','(a6," =",f10.4," mg/m^3")')
+ call blkinr(pmax( i), 'pmax ','(a6," =",f10.4," 1/day")')
+ call blkinr(psen( i), 'psen ','(a6," =",f10.4," 1/day")')
+c
+ call blkinr(remn( i), 'remn ','(a6," =",f10.4," 1/day")')
+c
+ call blkini(spcflg(i),'spcflg')
+c
+ if (mnproc.eq.1) then
+ write(lp,*)
+ endif !1st tile
+ return
+ endif !ibio.lt.0
+c
+c --- leapfrog time step.
+c
+ margin = 0 ! no horizontal derivatives
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,k,pijk,pijkp,par,
+!$OMP& beta_b,frac_b,
+!$OMP& bm_n,bm_p,bm_z,bm_d,bn_n,bn_p,bn_z,bn_d,
+!$OMP& bu_n,bu_p,bu_z,bu_d,
+!$OMP& gamma1,gamma2,xnum,xkatheta,ynum,xkbtheta,
+!$OMP& tijk,tfn,vw,xw,yw,zw,
+!$OMP& pgrw,zgrw,pref,prf2,qprf,ztgx,dofz,pofz,zofz)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (jerlv0.eq.0) then
+ beta_b = qonem*( akpar(i,j,lk0)*wk0
+ & +akpar(i,j,lk1)*wk1
+ & +akpar(i,j,lk2)*wk2
+ & +akpar(i,j,lk3)*wk3)
+ frac_b = max( 0.27, 0.695 - 5.7*onem*beta_b )
+ else
+ beta_b = betabl(jerlov(i,j))
+ frac_b = 1.0 - redfac(jerlov(i,j))
+ endif
+ pijkp=0.0
+ do k=1,kk
+ pijk = pijkp
+ pijkp = pijk+dp(i,j,k,n)
+ par = frac_b*exp(-0.5*(pijk+pijkp)*beta_b)
+c
+ bm_n = tracer(i,j,k,m,ibio)
+ bm_p = tracer(i,j,k,m,ibio+1)
+ bm_z = tracer(i,j,k,m,ibio+2)
+ bm_d = tracer(i,j,k,m,ibio+3)
+ bn_n = tracer(i,j,k,n,ibio)
+ bn_p = tracer(i,j,k,n,ibio+1)
+ bn_z = tracer(i,j,k,n,ibio+2)
+ bn_d = tracer(i,j,k,n,ibio+3)
+c
+ if (spcflg(ibio).eq.1) then
+c --- cold-water species temperature dependance
+ tijk = temp(i,j,k,n)
+ gamma1 = 1.0/(theta2-q10l) *
+ & log((xk2*(1.0-xk1))/(xk1*(1.0-xk2)))
+ gamma2 = 1.0/(theta1-theta3) *
+ & log((xk2*(1.0-xk3))/(xk4*(1.0-xk2)))
+ xnum = exp(gamma1*(tijk-q10l))
+ xkatheta = (xk1*xnum)/(1.0+xk1*(xnum-1.0))
+ ynum = exp(gamma2*(theta1-tijk))
+ xkbtheta = (xk4*ynum)/(1.0+xk3*(ynum-1.0))
+ tfn = xkatheta*xkbtheta
+ elseif (spcflg(ibio).eq.2) then
+c --- warm-water species temperature dependance
+ tijk = temp(i,j,k,n)
+ if (tijk.le.tmax) then
+ vw = (tmax-tijk)/(tmax-topt)
+ yw = log(q10w)*(tmax-topt+2.0)
+ zw = log(q10w)*(tmax-topt)
+ xw = (zw**2 * (1.0+sqrt(1.0+40.0/yw))**2)/400.0
+ tfn = vw**xw * exp(xw*(1.0-vw))
+ else
+ tfn=0.0
+ endif
+ else
+c --- no temperature dependance
+ tfn=1.0
+ endif !spcflg
+c
+ pref = pp(ibio)*bm_p +
+ & pd(ibio)*bm_d +
+ & pz(ibio)*bm_z
+ prf2 = pp(ibio)*bm_p**2 +
+ & pd(ibio)*bm_d**2 +
+ & pz(ibio)*bm_z**2
+ qprf = 1.0/(fkz(ibio)*pref + prf2 + epsil) !epsil prevents 1/0
+ ztgx = bm_z*tfn*gmax(ibio)
+c
+ pgrw = bm_p*tfn*pmax(ibio)*bm_n*par/(fkp(ibio)+bm_n)
+ zgrw = ztgx*(prf2 *qprf)*aa(ibio)*am(ibio)
+ pofz = ztgx*(pp(ibio)*bm_p**2*qprf)
+ zofz = ztgx*(pz(ibio)*bm_z**2*qprf)
+ dofz = ztgx*(pd(ibio)*bm_d**2*qprf)
+c
+ ! limit negative terms to 10% of total per single time step
+ pgrw = min(pgrw,bn_n*0.2*86400.0/delt1)
+ zgrw = min(zgrw,bn_n*0.2*86400.0/delt1)
+ pofz = min(pofz,bn_p*0.2*86400.0/delt1)
+ zofz = min(zofz,bn_z*0.2*86400.0/delt1)
+ dofz = min(dofz,bn_d*0.2*86400.0/delt1)
+c
+ bu_p = pgrw
+ & - pofz
+ & - bm_p*psen(ibio)
+ bu_z = zgrw
+ & - zofz
+ & - bm_z*zmor(ibio)
+ bu_d = bm_p*psen(ibio)
+ & + bm_z*zmor(ibio)
+ & + (pofz+zofz+dofz)*(1.0-aa(ibio))
+ & - dofz
+ & - bm_d*remn(ibio)
+ bu_n = bm_d*remn(ibio)
+ & + (pofz+zofz+dofz)* aa(ibio)
+ & - zgrw
+ & - pgrw
+c
+ tracer(i,j,k,n,ibio) = bn_n + delt1/86400.0 * bu_n
+ tracer(i,j,k,n,ibio+1) = bn_p + delt1/86400.0 * bu_p
+ tracer(i,j,k,n,ibio+2) = bn_z + delt1/86400.0 * bu_z
+ tracer(i,j,k,n,ibio+3) = bn_d + delt1/86400.0 * bu_d
+c
+c --- fields must be non-negative
+c --- note: only round-off should make a field negative
+c
+ if (tracer(i,j,k,n,ibio+1).lt.0.0) then !PtoN
+ tracer(i,j,k,n,ibio) = tracer(i,j,k,n,ibio) -
+ & tracer(i,j,k,n,ibio+1)
+ tracer(i,j,k,n,ibio+1) = 0.0
+ endif
+ if (tracer(i,j,k,n,ibio+2).lt.0.0) then !ZtoN
+ tracer(i,j,k,n,ibio) = tracer(i,j,k,n,ibio) -
+ & tracer(i,j,k,n,ibio+2)
+ tracer(i,j,k,n,ibio+2) = 0.0
+ endif
+ if (tracer(i,j,k,n,ibio+3).lt.0.0) then !DtoN
+ tracer(i,j,k,n,ibio) = tracer(i,j,k,n,ibio) -
+ & tracer(i,j,k,n,ibio+3)
+ tracer(i,j,k,n,ibio+3) = 0.0
+ endif
+ if (tracer(i,j,k,n,ibio) .lt.0.0) then !NtoD (do last)
+ tracer(i,j,k,n,ibio+3) = tracer(i,j,k,n,ibio+3) -
+ & tracer(i,j,k,n,ibio)
+ tracer(i,j,k,n,ibio) = 0.0
+ endif
+ enddo
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ return
+ end subroutine trcupd_904
+
+ subroutine pcmtrc(si,pi,ki,ks, so,po,ko)
+ implicit none
+c
+ integer ki,ks,ko
+ real si(ki,ks),pi(ki+1),
+ & so(ko,ks),po(ko+1)
+c
+c**********
+c*
+c 1) remap from one set of vertical cells to another.
+c method: piecewise constant across each input cell
+c the output is the average of the interpolation
+c profile across each output cell.
+c
+c 2) input arguments:
+c si - scalar fields in pi-layer space
+c pi - layer interface depths (non-negative m)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c ki - 1st dimension of si (number of input layers)
+c ks - 2nd dimension of si,so (number of fields)
+c po - target interface depths (non-negative m)
+c po(k+1) >= po(k)
+c ko - 1st dimension of so (number of output layers)
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) except at data voids, must have:
+c pi( 1) == zero (surface)
+c pi( l+1) >= pi(l)
+c pi(ki+1) == bathymetry
+c 0 <= po(k) <= po(k+1)
+c output layers completely below the bathymetry inherit values
+c from the layer above.
+c
+c 5) Alan J. Wallcraft, Naval Research Laboratory, Sep. 2002 (Aug. 2005).
+c*
+c**********
+c
+ real thin
+ parameter (thin=1.e-6) ! minimum layer thickness (no division by 0.0)
+c
+ integer i,k,l,lf
+ real q,zb,zt,sok(ks)
+c
+ lf=1
+ zb=po(1)
+ do k= 1,ko
+ zt = zb
+ zb = po(k+1)
+* WRITE(6,*) 'k,zt,zb = ',k,zt,zb
+ if (zb-zt.lt.thin .or. zt.ge.pi(ki+1)) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else
+c
+c form layer averages.
+c
+ if (pi(lf).gt.zt) then
+ WRITE(6,*) 'bad lf = ',lf
+ stop
+ endif
+ do i= 1,ks
+ sok(i) = 0.0
+ enddo !i
+ do l= lf,ki
+ if (pi(l).gt.zb) then
+* WRITE(6,*) 'l,lf= ',l,lf,l-1
+ lf = l-1
+ exit
+ elseif (pi(l).ge.zt .and. pi(l+1).le.zb) then
+c
+c the input layer is completely inside the output layer
+c
+ q = max(pi(l+1)-pi(l),thin)/(zb-zt)
+ do i= 1,ks
+ sok(i) = sok(i) + q*si(l,i)
+ enddo !i
+* WRITE(6,*) 'L,q = ',l,q
+ else
+c
+c the input layer is partially inside the output layer
+c
+ q = max(min(pi(l+1),zb)-max(pi(l),zt),thin)/(zb-zt)
+ do i= 1,ks
+ sok(i) = sok(i) + q*si(l,i)
+ enddo !i
+* WRITE(6,*) 'l,q = ',l,q
+ endif
+ enddo !l
+ do i= 1,ks
+ so(k,i) = sok(i)
+ enddo !i
+ endif
+ enddo !k
+ return
+ end subroutine pcmtrc
+
+ subroutine plmtrc(si,pi,ki,ks, so,po,ko)
+ implicit none
+c
+ integer ki,ks,ko
+ real si(ki,ks),pi(ki+1),
+ & so(ko,ks),po(ko+1),flag
+c
+c**********
+c*
+c 1) remap from one set of vertical cells to another.
+c method: piecewise linear across each input cell
+c the output is the average of the interpolation
+c profile across each output cell.
+c
+c 2) input arguments:
+c si - scalar fields in pi-layer space
+c pi - layer interface depths (non-negative m)
+c pi( 1) is the surface
+c pi(ki+1) is the bathymetry
+c ki - 1st dimension of si (number of input layers)
+c ks - 2nd dimension of si,so (number of fields)
+c po - target interface depths (non-negative m)
+c po(k+1) >= po(k)
+c ko - 1st dimension of so (number of output layers)
+c flag - data void (land) marker
+c
+c 3) output arguments:
+c so - scalar fields in po-layer space
+c
+c 4) except at data voids, must have:
+c pi( 1) == zero (surface)
+c pi( l+1) >= pi(l)
+c pi(ki+1) == bathymetry
+c 0 <= po(k) <= po(k+1)
+c output layers completely below the bathymetry inherit values
+c from the layer above.
+c
+c 5) Tim Campbell, Mississippi State University, October 2002.
+C Alan J. Wallcraft, Naval Research Laboratory, Aug. 2005.
+c*
+c**********
+c
+ real,parameter :: thin=1.e-6 !minimum layer thickness
+c
+ integer i,k,l,lf
+ real q,qc,zb,zc,zt,sok(ks)
+ real sis(ki,ks),pit(ki+1)
+c
+c --- compute PLM slopes for input layers
+ do k=1,ki
+ pit(k)=max(pi(k+1)-pi(k),thin)
+ enddo
+ call plmtrcx(pit,si,sis,ki,ks)
+c --- compute output layer averages
+ lf=1
+ zb=po(1)
+ do k= 1,ko
+ zt = zb
+ zb = po(k+1)
+* WRITE(6,*) 'k,zt,zb = ',k,zt,zb
+ if (zb-zt.lt.thin .or. zt.ge.pi(ki+1)) then
+c
+c --- thin or bottomed layer, values taken from layer above
+c
+ do i= 1,ks
+ so(k,i) = so(k-1,i)
+ enddo !i
+ else
+c
+c form layer averages.
+c
+ if (pi(lf).gt.zt) then
+ WRITE(6,*) 'bad lf = ',lf
+ stop
+ endif
+ do i= 1,ks
+ sok(i) = 0.0
+ enddo !i
+ do l= lf,ki
+ if (pi(l).gt.zb) then
+* WRITE(6,*) 'l,lf= ',l,lf,l-1
+ lf = l-1
+ exit
+ elseif (pi(l).ge.zt .and. pi(l+1).le.zb) then
+c
+c the input layer is completely inside the output layer
+c
+ q = max(pi(l+1)-pi(l),thin)/(zb-zt)
+ do i= 1,ks
+ sok(i) = sok(i) + q*si(l,i)
+ enddo !i
+* WRITE(6,*) 'L,q = ',l,q
+ else
+c
+c the input layer is partially inside the output layer
+c average of linear profile is its center value
+c
+ q = max( min(pi(l+1),zb)-max(pi(l),zt), thin )/(zb-zt)
+ zc = 0.5*(min(pi(l+1),zb)+max(pi(l),zt))
+ qc = (zc-pi(l))/pit(l) - 0.5
+ do i= 1,ks
+ sok(i) = sok(i) + q*(si(l,i) + qc*sis(l,i))
+ enddo !i
+* WRITE(6,*) 'l,q,qc = ',l,q,qc
+ endif
+ enddo !l
+ do i= 1,ks
+ so(k,i) = sok(i)
+ enddo !i
+ endif
+ enddo !k
+ return
+ end subroutine plmtrc
+
+ subroutine plmtrcx(pt, s,ss,ki,ks)
+ implicit none
+c
+ integer ki,ks
+ real pt(ki+1),s(ki,ks),ss(ki,ks)
+c
+c**********
+c*
+c 1) generate a monotonic PLM interpolation of a layered field
+c
+c 2) input arguments:
+c pt - layer interface thicknesses (non-zero)
+c s - scalar fields in layer space
+c ki - 1st dimension of s (number of layers)
+c ks - 2nd dimension of s (number of fields)
+c
+c 3) output arguments:
+c ss - scalar field slopes for PLM interpolation
+c
+c 4) except at data voids, must have:
+c pi( 1) == zero (surface)
+c pi( l+1) >= pi(:,:,l)
+c pi(ki+1) == bathymetry
+c
+c 5) Tim Campbell, Mississippi State University, September 2002.
+c*
+c**********
+c
+ integer l
+ real ql(ki),qc(ki),qr(ki)
+c
+ !compute grid spacing ratios for slope computations
+ ql(1)=0.0
+ qc(1)=0.0
+ qr(1)=0.0
+ do l=2,ki-1
+ ql(l)=2.0*pt(l)/(pt(l-1)+pt(l))
+ qc(l)=2.0*pt(l)/(pt(l-1)+2.0*pt(l)+pt(l+1))
+ qr(l)=2.0*pt(l)/(pt(l)+pt(l+1))
+ enddo
+ ql(ki)=0.0
+ qc(ki)=0.0
+ qr(ki)=0.0
+ !compute normalized layer slopes
+ do l=1,ks
+ call plmtrcs(ql,qc,qr,s(1,l),ss(1,l),ki)
+ enddo
+ return
+ end subroutine plmtrcx
+
+ subroutine plmtrcs(rl,rc,rr,a,s,n)
+ implicit none
+c
+ integer,intent(in) :: n
+ real, intent(in) :: rl(n),rc(n),rr(n),a(n)
+ real, intent(out) :: s(n)
+c
+c**********
+c*
+c 1) generate slopes for monotonic piecewise linear distribution
+c
+c 2) input arguments:
+c rl - left grid spacing ratio
+c rc - center grid spacing ratio
+c rr - right grid spacing ratio
+c a - scalar field zone averages
+c n - number of zones
+c
+c 3) output arguments:
+c s - zone slopes
+c
+c 4) Tim Campbell, Mississippi State University, September 2002.
+c*
+c**********
+c
+ integer,parameter :: ic=2, im=1, imax=100
+ real,parameter :: fracmin=1e-6, dfac=0.5
+c
+ integer i,j
+ real sl,sc,sr
+ real dnp,dnn,dl,dr,ds,frac
+c
+c Compute zone slopes
+c Campbell Eq(15) -- nonuniform grid
+c
+ s(1)=0.0
+ do j=2,n-1
+ sl=rl(j)*(a(j)-a(j-1))
+ sr=rr(j)*(a(j+1)-a(j))
+ if (sl*sr.gt.0.) then
+ s(j)=sign(min(abs(sl),abs(sr)),sl)
+ else
+ s(j)=0.0
+ endif
+ enddo
+ s(n)=0.0
+c
+c Minimize discontinuities between zones
+c Apply single pass discontinuity minimization: Campbell Eq(19)
+c
+ do j=2,n-1
+ if(s(j).ne.0.0) then
+ dl=-0.5*(s(j)+s(j-1))+a(j)-a(j-1)
+ dr=-0.5*(s(j+1)+s(j))+a(j+1)-a(j)
+ ds=sign(min(abs(dl),abs(dr)),dl)
+ s(j)=s(j)+2.0*ds
+ endif
+ enddo
+ return
+ end subroutine plmtrcs
+c
+c
+c> Revision history:
+c>
+c> Aug 2002 - new routine to put all tracer interactions in one place
+c> Dec. 2003 - inforce non-negative bio-tracers
+c> Aug. 2005 - interpolate trwall to actual layer structure
diff --git a/src_2.2.18_3_one/tsadvc.f b/src_2.2.18_3_one/tsadvc.f
new file mode 100755
index 0000000..cfff935
--- /dev/null
+++ b/src_2.2.18_3_one/tsadvc.f
@@ -0,0 +1,1999 @@
+ module mod_advem
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ implicit none
+c --- module for advem only
+ private !! default is private
+ public :: advem
+c
+ integer, public, save, dimension (0:4) ::
+ & mbdy_advtyp = (/ 2, !PCM
+ & 5, !MPDATA
+ & 5, !FCT2
+ & 0, !N/A
+ & 5 /) !FCT4
+c
+ logical, parameter :: lpipe_advem=.false. !extra checking (when pipe on)
+ logical, parameter :: lconserve =.false. !explicitly conserve the field
+c
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & fmx,fmn ! local max,min
+ & ,flx,fly ! fluxes
+ & ,fldlo ! lo order solution
+ & ,fmxlo,fmnlo ! local min
+ & ,fax,fay ! fluxes
+ & ,rp,rm ! FCT/MPDATA terms
+ & ,flxdiv ! flux divergence
+ & ,tx1,ty1 ! MPDATA terms
+ & ,fldao,fldan ! total field quantity (old/center, new)
+
+ contains
+
+ subroutine advem(advtyp,fld,fldc,u,v,fco,fcn,posdef,
+ & scal,scali,dt2)
+ implicit none
+c
+ integer, intent(in) :: advtyp
+ real, intent(in) :: posdef,dt2
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: fld
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: fldc,u,v,fco,fcn,scal,scali
+c
+c --- wrapper for advection schemes
+c
+c --- a recent text on advection schemes is:
+c --- D.R. Durran (1999): Numerical Methods for wave equations in
+c --- geophysical fluid dynamics, Springer.
+c
+c --- advtyp= 0 for 1st order PCM (Donor Cell)
+c --- advtyp= 1 for 2nd order MPDATA (old to new, as in 2.1.03)
+c --- advtyp= 2 for 2nd order FCT (Leapfrog time step)
+c --- advtyp= 4 for 4th order FCT (Leapfrog time step)
+c
+c --- time steps are "old", "center" and "new".
+c
+c --- fld - scalar field, at old time step on input but new on output
+c --- fldc - scalar field, at center time step
+c --- u,v - mass fluxes satisfying continuity equation (old to new)
+c --- fco - thickness of the layer at old time step
+c --- fcn - thickness of the layer at new time step
+c --- posdef - offset for MPDATA to make the field positive
+c --- scal - spatial increments (squared)
+c --- scali - inverse of scal
+c --- dt2 - temporal increment (from old to new, i.e. two time steps)
+c
+c on return, fld's valid halo will be 0 wide.
+c
+ real offset
+ real*8 sumold,sumnew,sumcor
+ integer i,j,l
+c
+ if (advtyp.eq.0) then
+ call advem_pcm( fld, u,v,fco,fcn, scal,scali,dt2)
+ elseif (advtyp.eq.1) then
+ call advem_mpdata(fld, u,v,fco,fcn,posdef,scal,scali,dt2)
+ elseif (advtyp.eq.2) then
+ call advem_fct2( fld,fldc,u,v,fco,fcn, scal,scali,dt2)
+ elseif (advtyp.eq.4) then
+ call advem_fct4( fld,fldc,u,v,fco,fcn, scal,scali,dt2)
+ else
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i4 /)')
+ & 'error: advem called with advtyp =',advtyp
+ endif
+ call xcstop('advem')
+ stop 'advem'
+ endif
+c
+ if (lconserve) then !usually .false.
+c
+c --- explicit conservation of tracer (should not be needed).
+c
+ call xcsum(sumold, fldao,ip)
+ call xcsum(sumnew, fldan,ip)
+c
+ if (sumnew.ne.0.0) then
+ offset = (sumold-sumnew)/sumnew
+ else
+ offset = 0.0
+ endif
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,offset)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ fld(i,j)=fld(i,j)*(1.0+offset)
+c
+cdiag fldan(i,j) = fld(i,j)*fcn(i,j)*scal(i,j)
+ enddo
+ enddo
+ enddo
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(fld, ip,'ad:oset:fld ')
+ endif
+c
+cdiag call xcsum(sumcor, fldan,ip)
+cdiag if (mnproc.eq.1) then
+cdiag write(lp,'(a,1p4e16.8)')
+cdiag& 'advem: ',sumold,sumnew,sumcor,offset
+cdiag endif
+ endif !lconserve
+ return
+ end subroutine advem
+
+ subroutine advem_mpdata(fld,u,v,fco,fcn,posdef,scal,scali,dt2)
+ implicit none
+c
+ real, intent(in) :: posdef,dt2
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: fld
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: u,v,scal,scali,fco,fcn
+c
+c LeapFrog 2nd order MPDATA.
+c combined monotone scheme, for details see section 3.3 (eqs. 34 to 37)
+c in smolarkiewicz and clark, 1986, j.comput.phys.,67,no 2, p. 396-438
+c and smolarkiewicz and grabowski, 1989, j.comput.phys. and recently
+c P.K. Smolarkiewicz and L.J. Margolin (1998): MPDATA: A finite
+c difference solver for geophysical flows, J.Comput.Phys. 140 459-480.
+c
+c time steps are "old", "center" and "new".
+c
+c fld - scalar field, must be >0, old input but new output
+c u,v - mass fluxes satisfying continuity equation (old to new)
+c fco - thickness of the layer at old time step
+c fcn - thickness of the layer at new time step
+c posdef - offset to make the field positive
+c scal - spatial increments (squared)
+c scali - inverse of scal
+c dt2 - temporal increment (from old to new)
+c
+c on return, fld's valid halo will be 0 wide.
+c
+ real, parameter :: onemu=9806.e-12 !very small layer thickness
+c
+ real fcn2,fco2,flxdn,flxdp,flydn,flydp,q
+ integer i,j,l,ia,ib,ja,jb,mbdy_a
+c
+ integer itest,jtest,ittest,jttest
+ common/testpt/itest,jtest,ittest,jttest
+ save /testpt/
+c
+ mbdy_a = mbdy_advtyp(1) ! = 5
+c
+c --- compute low-order and part of antidiffusive fluxes
+c
+c --- rhs: u, v, fld+
+c --- lhs: flx, fly, fmx, fmn
+c
+ margin = mbdy_a - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q,jb,ja,ib,ia)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ tx1(i,j)=.5*abs(u(i,j))*(fld(i,j)-fld(i-1,j))
+ if (u(i,j).ge.0.0) then
+ q=fld(i-1,j)
+ else
+ q=fld(i ,j)
+ endif
+ flx(i,j)=u(i,j)*(q+posdef)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ ty1(i,j)=.5*abs(v(i,j))*(fld(i,j)-fld(i,j-1))
+ if (v(i,j).ge.0.0) then
+ q=fld(i,j-1)
+ else
+ q=fld(i,j )
+ endif
+ fly(i,j)=v(i,j)*(q+posdef)
+ enddo !i
+ enddo !l
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fmx(i,j)=max(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))+posdef
+ fmn(i,j)=min(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))+posdef
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(tx1, iu,'ad:11:tx1 ',
+ & ty1, iv,'ad:11:ty1 ')
+ call pipe_compare_sym2(flx, iu,'ad:11:flx ',
+ & fly, iv,'ad:11:fly ')
+ call pipe_compare_sym1(fmx, ip,'ad:11:fmx ')
+ call pipe_compare_sym1(fmn, ip,'ad:11:fmn ')
+ endif
+c
+c --- rhs: u, v, fld+
+c --- lhs: flx, fly, fmx, fmn
+c
+ margin = mbdy_a - 1
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ flx(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ flx(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !l
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fly(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fly(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:22:flx ',
+ & fly, iv,'ad:33:fly ')
+ endif
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(a,2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag. 1pe9.2,0pf9.3/1pe39.2/0pf39.3)')
+cdiag. 'advem (1)',i+i0,j+j0,
+cdiag. fld(i-1,j),u(i,j),fld(i,j-1),v(i,j),
+cdiag. fld(i,j),v(i,j+1),fld(i,j+1),u(i+1,j),fld(i+1,j)
+cdiag endif
+c
+c --- rhs: flx+, fly+, fco, fmn, fmx, fcn
+c --- lhs: fld
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+!...........lo order Donor Cell step
+ flxdiv(i,j)=((flx(i+1,j)-flx(i,j))+
+ & (fly(i,j+1)-fly(i,j)) )*dt2*scali(i,j)
+ q=(fld(i,j)+posdef)*(fco(i,j)+onemu)-flxdiv(i,j)
+ !max,min should only be active for very thin layers
+ fldlo(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & q/(fcn(i,j)+onemu) ))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(fldlo, ip,'ad:610:fldlo')
+ call pipe_compare_sym1(flxdiv, ip,'ad:610:flxdv')
+ endif
+c
+c --- finish computation of antidiffusive fluxes
+c
+c --- rhs: tx1, u, ty1, v, flxdiv+, fco+, fcn+
+c --- lhs: flx, fly
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,fcn2,fco2)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ fco2=0.0
+ fcn2=0.0
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ fco2=fco(i,j)+fco(i-1,j) ! inforce order on flx calc
+ fcn2=fcn(i,j)+fcn(i-1,j) ! inforce order on flx calc
+ flx(i,j)=tx1(i,j)-u(i,j)*(flxdiv(i,j)+flxdiv(i-1,j))
+ & /((fco2+fcn2)+onemu)
+ enddo !i
+ enddo !l
+ if (fco2*fcn2.eq.1.e30) flx(1-nbdy,j)=0.0 ! prevent removal of fc*2
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ fco2=fco(i,j)+fco(i,j-1) ! inforce order on fly calc
+ fcn2=fcn(i,j)+fcn(i,j-1) ! inforce order on fly calc
+ fly(i,j)=ty1(i,j)-v(i,j)*(flxdiv(i,j)+flxdiv(i,j-1))
+ & /((fco2+fcn2)+onemu)
+ enddo !i
+ enddo !l
+ if (fco2*fcn2.eq.1.e30) flx(1-nbdy,j)=0.0 ! prevent removal of fc*2
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad: 8:flx ',
+ & fly, iv,'ad: 8:fly ')
+ endif
+c
+c --- limit antidiffusive fluxes
+c --- rp and rm used to be called flp and fln
+c
+c --- rhs: fmx, fmn, fldlo, fcn, flx+, fly+
+c --- lhs: rp, rm
+c
+ margin = mbdy_a - 3
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,flxdn,flxdp,flydn,flydp)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ flxdp=min(0.0,flx(i+1,j))-max(0.0,flx(i,j))
+ flxdn=max(0.0,flx(i+1,j))-min(0.0,flx(i,j))
+ flydp=min(0.0,fly(i,j+1))-max(0.0,fly(i,j))
+ flydn=max(0.0,fly(i,j+1))-min(0.0,fly(i,j))
+ rp(i,j)=(fmx(i,j)-fldlo(i,j))*(fcn(i,j)*scal(i,j))/
+ & ((onemu-(flxdp+flydp))*dt2)
+ rm(i,j)=(fldlo(i,j)-fmn(i,j))*(fcn(i,j)*scal(i,j))/
+ & ((onemu+(flxdn+flydn))*dt2)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(rp, ip,'ad:16:flp ')
+ call pipe_compare_sym1(rm, ip,'ad:16:fln ')
+ endif
+c
+c --- rhs: flx, fly, rp+, rm+
+c --- lhs: flx, fly
+c
+ margin = mbdy_a - 4
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ flx(i,j)=max(0.0,flx(i,j))*min(1.0,rp(i,j),rm(i-1,j))
+ & +min(0.0,flx(i,j))*min(1.0,rp(i-1,j),rm(i,j))
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ fly(i,j)=max(0.0,fly(i,j))*min(1.0,rp(i,j),rm(i,j-1))
+ & +min(0.0,fly(i,j))*min(1.0,rp(i,j-1),rm(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:18:flx ',
+ & fly, iv,'ad:18:fly ')
+ endif
+c
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(''advem (2)'',2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag.1pe9.2,0pf9.3/1pe39.2/0pf39.3)') i,j,fldlo(i-1,j),u(i,j),fldlo(i,j-1),
+cdiag.v(i,j),fldlo(i,j),v(i,j+1),fldlo(i,j+1),u(i+1,j),fldlo(i+1,j)
+c
+c --- rhs: flx+, fly+, fldlo, fcn, fmx
+c --- lhs: flxdiv, fld
+c
+ margin = mbdy_a - 5
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ fldao(i,j) = fld(i,j)*fco(i,j)*scal(i,j)
+c
+!...........apply antidiffusive flux correction
+ flxdiv(i,j)=((flx(i+1,j)-flx(i,j))+
+ & (fly(i,j+1)-fly(i,j)) )*dt2*scali(i,j)
+ !max,min should only be active for very thin layers
+ fld(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & fldlo(i,j)-flxdiv(i,j)/(fcn(i,j)+onemu) ))
+ fld(i,j)=fld(i,j)-posdef
+c
+ fldan(i,j) = fld(i,j)*fcn(i,j)*scal(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(flxdiv, ip,'ad:620:flxdv')
+ call pipe_compare_sym1(fld, ip,'ad:1620:fld ')
+ endif
+ return
+ end subroutine advem_mpdata
+
+ subroutine advem_pcm(fld,u,v,fco,fcn,scal,scali,dt2)
+ implicit none
+c
+ real, intent(in) :: dt2
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: fld
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: u,v,scal,scali,fco,fcn
+c
+c Piecewise Constant Method (Donor Cell, Upwind)
+c Over two time steps (may require half the normal time step for stability).
+c
+c time steps are "old", "center" and "new".
+c
+c fld - scalar field, need not be >0, old input but new output
+c u,v - mass fluxes satisfying continuity equation (old to new)
+c fco - thickness of the layer at old time step
+c fcn - thickness of the layer at new time step
+c scal - spatial increments (squared)
+c scali - inverse of scal
+c dt2 - temporal increment (from old to new)
+c
+c on return, fld's valid halo will be 0 wide.
+c
+ real, parameter :: onemu=9806.e-12 !very small layer thickness
+ real, parameter :: onecm=98.06 !one cm in pressure units
+c
+ real q
+ integer i,j,l,ia,ib,ja,jb,mbdy_a
+c
+ integer itest,jtest,ittest,jttest
+ common/testpt/itest,jtest,ittest,jttest
+ save /testpt/
+c
+c --- rhs: u, v, fld+
+c --- lhs: flx, fly
+c
+ mbdy_a = mbdy_advtyp(0) ! = 2
+c
+ margin = mbdy_a - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (u(i,j).ge.0.0) then
+ q=fld(i-1,j)
+ else
+ q=fld(i ,j)
+ endif
+ flx(i,j)=u(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (v(i,j).ge.0.0) then
+ q=fld(i,j-1)
+ else
+ q=fld(i,j )
+ endif
+ fly(i,j)=v(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fmx(i,j)=max(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ fmn(i,j)=min(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:11:flx ',
+ & fly, iv,'ad:11:fly ')
+ endif
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ flx(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ flx(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !l
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fly(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fly(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:22:flx ',
+ & fly, iv,'ad:33:fly ')
+ endif
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(a,2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag. 1pe9.2,0pf9.3/1pe39.2/0pf39.3)')
+cdiag. 'advem (1)',i+i0,j+j0,
+cdiag. fld(i-1,j),u(i,j),fld(i,j-1),v(i,j),
+cdiag. fld(i,j),v(i,j+1),fld(i,j+1),u(i+1,j),fld(i+1,j)
+cdiag endif
+c
+c --- rhs: flx+, fly+, fld, fco, fcn
+c --- lhs: flxdiv, fld
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ fldao(i,j) = fld(i,j)*fco(i,j)*scal(i,j)
+c
+ flxdiv(i,j)=((flx(i+1,j)-flx(i,j))+
+ & (fly(i,j+1)-fly(i,j)) )*dt2*scali(i,j)
+ q=fld(i,j)*(fco(i,j)+onemu)-flxdiv(i,j)
+ !max,min should only be active for very thin layers
+ fld(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & q/(fcn(i,j)+onemu) ))
+c
+ fldan(i,j) = fld( i,j)*fcn(i,j)*scal(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(fld, ip,'ad:610:fld ')
+ call pipe_compare_sym1(flxdiv, ip,'ad:610:flxdv')
+ endif
+c
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(''advem (2)'',2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag.1pe9.2,0pf9.3/1pe39.2/0pf39.3)') i,j,fld(i-1,j),u(i,j),fld(i,j-1),
+cdiag.v(i,j),fld(i,j),v(i,j+1),fld(i,j+1),u(i+1,j),fld(i+1,j)
+ return
+ end subroutine advem_pcm
+
+ subroutine advem_fct2(fld,fldc,u,v,fco,fcn,scal,scali,dt2)
+ implicit none
+c
+ real, intent(in) :: dt2
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: fld
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: fldc,u,v,scal,scali,fco,fcn
+c
+c Leapfrog 2nd order FCT
+c S.T. Zalesak (1979): Fully multidimensional flux-corrected
+c transport algorithms for fluids, J.Comput.Phys. 31 335-362.
+c
+c time steps are "old", "center" and "new".
+c
+c fld - scalar field, need not be >0, old input but new output
+c fldc - scalar field at center time step
+c u,v - mass fluxes satisfying continuity equation (old to new)
+c fco - thickness of the layer at old time step
+c fcn - thickness of the layer at new time step
+c scal - spatial increments (squared)
+c scali - inverse of scal
+c dt2 - temporal increment (from old to new)
+c
+c on return, fld's valid halo will be 0 wide.
+c
+ real, parameter :: onemu=9806.e-12 !very small layer thickness
+ real, parameter :: epsil=1.e-20
+c
+ real flxdn,flxdp,flydn,flydp,q
+ integer i,j,l,ia,ib,ja,jb,mbdy_a
+c
+ integer itest,jtest,ittest,jttest
+ common/testpt/itest,jtest,ittest,jttest
+ save /testpt/
+c
+ real :: fhx, fhy, fqmax, fqmin, famax, famin
+ real :: qdt2, qp, qm, fact
+
+ mbdy_a = mbdy_advtyp(2) ! = 5
+c
+c --- compute low-order and part of antidiffusive fluxes
+c
+c --- rhs: u, v, fld+
+c --- lhs: flx, fly, fmx, fmn
+c
+ margin = mbdy_a - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q,jb,ja,ib,ia)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (u(i,j).ge.0.0) then
+ q=fld(i-1,j)
+ else
+ q=fld(i ,j)
+ endif
+ flx(i,j)=u(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (v(i,j).ge.0.0) then
+ q=fld(i,j-1)
+ else
+ q=fld(i,j )
+ endif
+ fly(i,j)=v(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fmx(i,j)=max(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ fmn(i,j)=min(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+! call pipe_compare_sym2(tx1, iu,'ad:11:tx1 ',
+! & ty1, iv,'ad:11:ty1 ')
+! call pipe_compare_sym2(flx, iu,'ad:11:flx ',
+! & fly, iv,'ad:11:fly ')
+ endif
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ flx(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ flx(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !i
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fly(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fly(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:22:flx ',
+ & fly, iv,'ad:33:fly ')
+ endif
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(a,2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag. 1pe9.2,0pf9.3/1pe39.2/0pf39.3)')
+cdiag. 'advem (1)',i+i0,j+j0,
+cdiag. fld(i-1,j),u(i,j),fld(i,j-1),v(i,j),
+cdiag. fld(i,j),v(i,j+1),fld(i,j+1),u(i+1,j),fld(i+1,j)
+cdiag endif
+c
+c --- rhs: flx+, fly+, fld, fmx, fmn, fco, fcn
+c --- lhs: fldlo, fmxlo, fmnlo, flxdiv
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+!...........lo order Donor Cell step
+ flxdiv(i,j)=((flx(i+1,j)-flx(i,j))+
+ & (fly(i,j+1)-fly(i,j)) )*dt2*scali(i,j)
+ q=fld(i,j)*(fco(i,j)+onemu)-flxdiv(i,j)
+ !max,min should only be active for very thin layers
+ fldlo(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & q/(fcn(i,j)+onemu) ))
+ fmxlo(i,j) = max(fld(i,j),fldc(i,j),fldlo(i,j))
+ fmnlo(i,j) = min(fld(i,j),fldc(i,j),fldlo(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(fldlo, ip,'ad:610:fldlo')
+ call pipe_compare_sym1(flxdiv, ip,'ad:610:flxdv')
+ endif
+c
+!.....Leapfrog step using high order scheme
+c
+c --- rhs: u, v, fld+, flx, fly
+c --- lhs: fax, fay
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q,jb,ja,ib,ia,fhx,fhy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ fhx=u(i,j)*0.5*(fldc(i,j)+fldc(i-1,j)) ! 2nd order in space
+ fax(i,j)= fhx-flx(i,j) ! anti-diffusion x-flux
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ fhy=v(i,j)*0.5*(fldc(i,j)+fldc(i,j-1)) ! 2nd order in space
+ fay(i,j)= fhy-fly(i,j) ! anti-diffusion y-flux
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ fax(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ fax(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !l
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fay(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fay(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+!========================================================
+c
+c --- finish computation of antidiffusive fluxes
+c
+c --- rhs: fmnlo+,fmxlo+,fax+,fay+,fldlo,fcn,scal
+c --- lhs: rp, rm
+c
+ margin = mbdy_a - 3
+c
+ qdt2 = 1.0/dt2
+!$OMP PARALLEL DO PRIVATE(j,l,i,ia,ib,ja,jb,
+!$OMP& fqmax,fqmin,famax,famin,qp,qm)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fqmax = max(fmxlo(i,j),fmxlo(ia,j),fmxlo(ib,j),
+ & fmxlo(i,ja),fmxlo(i,jb))
+ fqmin = min(fmnlo(i,j),fmnlo(ia,j),fmnlo(ib,j),
+ & fmnlo(i,ja),fmnlo(i,jb))
+ famax = max(0.0,fax(i, j) ) - min(0.0,fax(ib,j) ) +
+ & max(0.0,fay(i, j) ) - min(0.0,fay(i, jb))
+ famin = max(0.0,fax(ib,j) ) - min(0.0,fax(i, j) ) +
+ & max(0.0,fay(i, jb)) - min(0.0,fay(i, j) )
+ if (famax > 0.0) then
+ qp = (fqmax-fldlo(i,j)) *fcn(i,j)*scal(i,j)*qdt2
+ rp(i,j) = min(1.0, qp/famax)
+ else
+ rp(i,j) = 0.0
+ endif
+ if (famin > 0.0) then
+ qm = (fldlo(i,j)-fqmin) *fcn(i,j)*scal(i,j)*qdt2
+ rm(i,j) = min(1.0, qm/famin)
+ else
+ rm(i,j) = 0.0
+ endif
+ fmx(i,j) = fqmax !less restrictive maximum
+ fmn(i,j) = fqmin !less restrictive minimum
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+c --- rhs: rp+, rm+
+c --- lhs: fax, fay
+c
+ margin = mbdy_a - 4
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,fact)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (fax(i,j) < 0.0) then
+ fact = min(rp(i-1,j),rm(i,j))
+ else
+ fact = min(rp(i,j),rm(i-1,j))
+ endif
+ fax(i,j) = fact*fax(i,j)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (fay(i,j) < 0.0) then
+ fact = min(rp(i,j-1),rm(i,j))
+ else
+ fact = min(rp(i,j),rm(i,j-1))
+ endif
+ fay(i,j) = fact*fay(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:18:flx ',
+ & fly, iv,'ad:18:fly ')
+ endif
+c
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(''advem (2)'',2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag.1pe9.2,0pf9.3/1pe39.2/0pf39.3)') i,j,fldlo(i-1,j),u(i,j),fldlo(i,j-1),
+cdiag.v(i,j),fldlo(i,j),v(i,j+1),fldlo(i,j+1),u(i+1,j),fldlo(i+1,j)
+c
+c --- rhs: fax+, fay+, fld, fcn, fmx, fmn
+c --- lhs: fld
+c
+ margin = mbdy_a - 5
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ fldao(i,j) = fld(i,j)*fco(i,j)*scal(i,j)
+c
+!...........apply antidiffusive flux correction
+ flxdiv(i,j)=((fax(i+1,j)-fax(i,j))+
+ & (fay(i,j+1)-fay(i,j)) )*dt2*scali(i,j)
+ !max,min should only be active for very thin layers
+ fld(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & fldlo(i,j)-flxdiv(i,j)/(fcn(i,j)+onemu) ))
+c
+ fldan(i,j) = fld(i,j)*fcn(i,j)*scal(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(flxdiv, ip,'ad:620:flxdv')
+ call pipe_compare_sym1(fld, ip,'ad:1620:fld ')
+ endif
+ return
+ end subroutine advem_fct2
+
+ subroutine advem_fct4(fld,fldc,u,v,fco,fcn,scal,scali,dt2)
+ implicit none
+c
+ real, intent(in) :: dt2
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(inout) :: fld
+ real, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & intent(in) :: fldc,u,v,scal,scali,fco,fcn
+c
+c Leapfrog 4th order FCT
+c S.T. Zalesak (1979): Fully multidimensional flux-corrected
+c transport algorithms for fluids, J.Comput.Phys. 31 335-362.
+c
+c time steps are "old", "center" and "new".
+c
+c fld - scalar field, need not be >0, old input but new output
+c fldc - scalar field at center time step
+c u,v - mass fluxes satisfying continuity equation (old to new)
+c fco - thickness of the layer at old time step
+c fcn - thickness of the layer at new time step
+c scal - spatial increments (squared)
+c scali - inverse of scal
+c dt2 - temporal increment (from old to new)
+c
+c on return, fld's valid halo will be 0 wide.
+c
+ real, parameter :: onemu=9806.e-12 !very small layer thickness
+ real, parameter :: epsil=1.e-20
+c
+ real, parameter :: ft14= 7.0/12.0, !4th centered inner coeff
+ & ft24=-1.0/12.0 !4th centered outer coeff
+c
+ real flxdn,flxdp,flydn,flydp,q
+ integer i,j,l,ia,ib,ja,jb,mbdy_a
+c
+ integer itest,jtest,ittest,jttest
+ common/testpt/itest,jtest,ittest,jttest
+ save /testpt/
+c
+ real :: fhx, fhy, fqmax, fqmin, famax, famin
+ real :: qdt2, qp, qm, fact
+
+ mbdy_a = mbdy_advtyp(4) ! = 5
+c
+c --- compute low-order and part of antidiffusive fluxes
+c
+c --- rhs: u, v, fld+
+c --- lhs: flx, fly, fmx, fmn
+c
+ margin = mbdy_a - 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q,fhx,fhy,jb,ja,ib,ia)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+c
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (u(i,j).ge.0.0) then
+ q=fld(i-1,j)
+ else
+ q=fld(i ,j)
+ endif
+ flx(i,j)=u(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (v(i,j).ge.0.0) then
+ q=fld(i,j-1)
+ else
+ q=fld(i,j )
+ endif
+ fly(i,j)=v(i,j)*q
+ enddo !i
+ enddo !l
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fmx(i,j)=max(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ fmn(i,j)=min(fld(i,j),fld(ia,j),fld(ib,j),
+ & fld(i,ja),fld(i,jb))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+! call pipe_compare_sym2(tx1, iu,'ad:11:tx1 ',
+! & ty1, iv,'ad:11:ty1 ')
+! call pipe_compare_sym2(flx, iu,'ad:11:flx ',
+! & fly, iv,'ad:11:fly ')
+ endif
+c
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ flx(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ flx(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !i
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fly(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fly(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:22:flx ',
+ & fly, iv,'ad:33:fly ')
+ endif
+cdiag if (itest.gt.0 .and. jtest.gt.0) then
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(a,2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag. 1pe9.2,0pf9.3/1pe39.2/0pf39.3)')
+cdiag. 'advem (1)',i+i0,j+j0,
+cdiag. fldc(i-1,j),u(i,j),fldc(i,j-1),v(i,j),
+cdiag. fldc(i,j),v(i,j+1),fldc(i,j+1),u(i+1,j),fldc(i+1,j)
+cdiag endif
+c
+c --- rhs: flx+, fly+, fld, fmx, fmn, fco, fcn, flxdiv
+c --- lhs: fldlo, fmxlo, fmnlo, flxdiv
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+!...........lo order Donor Cell step
+ flxdiv(i,j)=((flx(i+1,j)-flx(i,j))+
+ & (fly(i,j+1)-fly(i,j)) )*dt2*scali(i,j)
+ q=fld(i,j)*(fco(i,j)+onemu)-flxdiv(i,j)
+ !max,min should only be active for very thin layers
+ fldlo(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & q/(fcn(i,j)+onemu) ))
+ fmxlo(i,j) = max(fld(i,j),fldc(i,j),fldlo(i,j))
+ fmnlo(i,j) = min(fld(i,j),fldc(i,j),fldlo(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(fldlo, ip,'ad:610:fldlo')
+ call pipe_compare_sym1(flxdiv, ip,'ad:610:flxdv')
+ endif
+c
+!.....Leapfrog step using high order scheme
+c
+c --- rhs: u, v, fldi++, flx, fly
+c --- lhs: fax, fay
+c
+ margin = mbdy_a - 2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,q,jb,ja,ib,ia,fhx,fhy)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (i.eq.ifu(j,l) .or. i.eq.ilu(j,l)) then
+ ! 2nd order time centered
+ fhx=u(i,j)*0.5*(fldc(i,j)+fldc(i-1,j))
+ else
+ ! 4th order time centered
+ fhx=u(i,j)*(ft14*(fldc(i, j)+fldc(i-1,j))+
+ & ft24*(fldc(i+1,j)+fldc(i-2,j)) )
+ endif
+ fax(i,j)= fhx-flx(i,j) ! anti-diffusion x-flux
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (i.eq.ifv(j,l) .or. i.eq.ilv(j,l)) then
+ ! 2nd order time centered
+ fhy=v(i,j)*0.5*(fldc(i,j)+fldc(i,j-1))
+ else
+ ! 4th order time centered
+ fhy=v(i,j)*(ft14*(fldc(i,j) +fldc(i,j-1))+
+ & ft24*(fldc(i,j+1)+fldc(i,j-2)) )
+ endif
+ fay(i,j)= fhy-fly(i,j) ! anti-diffusion y-flux
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ if (ifp(j,l).ge. 1-margin) then
+ fax(ifp(j,l) ,j)=0.0
+ endif
+ if (ilp(j,l).lt.ii+margin) then
+ fax(ilp(j,l)+1,j)=0.0
+ endif
+ enddo !l
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsp(i)
+ if (jfp(i,l).ge. 1-margin) then
+ fay(i,jfp(i,l) )=0.0
+ endif
+ if (jlp(i,l).lt.jj+margin) then
+ fay(i,jlp(i,l)+1)=0.0
+ endif
+ enddo !l
+ enddo !i
+!========================================================
+c
+c --- finish computation of antidiffusive fluxes
+c
+c --- rhs: fmnlo+,fmxlo+,fax+,fay+,fldlo,fcn,scal
+c --- lhs: rp, rm
+c
+ margin = mbdy_a - 3
+c
+ qdt2 = 1.0/dt2
+!$OMP PARALLEL DO PRIVATE(j,l,i,ia,ib,ja,jb,
+!$OMP& fqmax,fqmin,famax,famin,qp,qm)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ ia=i-1; if (ip(ia,j).eq.0) ia=i
+ ib=i+1; if (ip(ib,j).eq.0) ib=i
+ ja=j-1; if (ip(i,ja).eq.0) ja=j
+ jb=j+1; if (ip(i,jb).eq.0) jb=j
+ fqmax = max(fmxlo(i,j),fmxlo(ia,j),fmxlo(ib,j),
+ & fmxlo(i,ja),fmxlo(i,jb))
+ fqmin = min(fmnlo(i,j),fmnlo(ia,j),fmnlo(ib,j),
+ & fmnlo(i,ja),fmnlo(i,jb))
+ famax = max(0.0,fax(i, j) ) - min(0.0,fax(ib,j) ) +
+ & max(0.0,fay(i, j) ) - min(0.0,fay(i, jb))
+ famin = max(0.0,fax(ib,j) ) - min(0.0,fax(i, j) ) +
+ & max(0.0,fay(i, jb)) - min(0.0,fay(i, j) )
+ if (famax > 0.0) then
+ qp = (fqmax-fldlo(i,j)) *fcn(i,j)*scal(i,j)*qdt2
+ rp(i,j) = min(1.0, qp/famax)
+ else
+ rp(i,j) = 0.0
+ endif
+ if (famin > 0.0) then
+ qm = (fldlo(i,j)-fqmin) *fcn(i,j)*scal(i,j)*qdt2
+ rm(i,j) = min(1.0, qm/famin)
+ else
+ rm(i,j) = 0.0
+ endif
+ fmx(i,j) = fqmax !less restrictive maximum
+ fmn(i,j) = fqmin !less restrictive minimum
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+c --- rhs: rp+, rm+
+c --- lhs: fax, fay
+c
+ margin = mbdy_a - 4
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,fact)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ if (fax(i,j) < 0.0) then
+ fact = min(rp(i-1,j),rm(i,j))
+ else
+ fact = min(rp(i,j),rm(i-1,j))
+ endif
+ fax(i,j) = fact*fax(i,j)
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ if (fay(i,j) < 0.0) then
+ fact = min(rp(i,j-1),rm(i,j))
+ else
+ fact = min(rp(i,j),rm(i,j-1))
+ endif
+ fay(i,j) = fact*fay(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym2(flx, iu,'ad:18:flx ',
+ & fly, iv,'ad:18:fly ')
+ endif
+c
+cdiag i=itest
+cdiag j=jtest
+cdiag write (lp,'(''advem (2)'',2i5,f22.3/1pe39.2/0pf21.3,1pe9.2,0pf9.3,
+cdiag.1pe9.2,0pf9.3/1pe39.2/0pf39.3)') i,j,fldlo(i-1,j),u(i,j),fldlo(i,j-1),
+cdiag.v(i,j),fldlo(i,j),v(i,j+1),fldlo(i,j+1),u(i+1,j),fldlo(i+1,j)
+c
+c --- rhs: fax+, fay+, fld, fcn, fmx, fmn
+c --- lhs: fld
+c
+ margin = mbdy_a - 5
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ fldao(i,j) = fld(i,j)*fco(i,j)*scal(i,j)
+c
+!...........apply antidiffusive flux correction
+ flxdiv(i,j)=((fax(i+1,j)-fax(i,j))+
+ & (fay(i,j+1)-fay(i,j)) )*dt2*scali(i,j)
+ !max,min should only be active for very thin layers
+ fld(i,j)=max( fmn(i,j), min( fmx(i,j),
+ & fldlo(i,j)-flxdiv(i,j)/(fcn(i,j)+onemu) ))
+c
+ fldan(i,j) = fld( i,j)*fcn(i,j)*scal(i,j)
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+ if (lpipe .and. lpipe_advem) then
+c --- compare two model runs.
+ call pipe_compare_sym1(flxdiv, ip,'ad:620:flxdv')
+ call pipe_compare_sym1(fld, ip,'ad:1620:fld ')
+ endif
+ return
+ end subroutine advem_fct4
+c
+ end module mod_advem
+
+ subroutine tsadvc(m,n)
+ use mod_xc ! HYCOM communication interface
+ use mod_pipe ! HYCOM debugging interface
+ use mod_advem ! defined above
+ implicit none
+c
+ include 'common_blocks.h'
+c
+ integer m,n
+c
+c --- ---------------------------------------------------
+c --- thermodynamic variable(s): advection and diffusion.
+c --- ---------------------------------------------------
+c
+ logical, parameter :: lpipe_tsadvc=.false. !extra checking (when pipe on)
+c
+ real, parameter :: onemu=9806.e-12 !very small layer thickness
+c
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy) ::
+ & sold,told,q2old,q2lold
+ real, save, dimension (1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy,mxtrcr) ::
+ & trold
+c
+ logical latemp,lath3d,ldtemp,ldth3d
+ integer i,isave,j,jsave,k,ktr,l,ia,ib,ja,jb,mbdy,mdf
+ real sminn,smaxx,flxdiv,th3d_t
+ & ,factor,pold,pmid,pnew,wts2dp
+ real xmin(kdm),xmax(kdm)
+ real sminny(jdm),smaxxy(jdm)
+c
+ character*12 text,textu,textv
+c
+c --- for mpdata, select posdef:
+c --- 1. as a power of 2
+c --- 2. so that the ratio of the standard deviation to the mean of
+c --- each field is approximately the same:
+c --- 0 for -saln-, 256 for -temp-, 32 for -th3d-,
+c --- 0 for -tracer-, 1 for -q2-
+ real pdzero,pdtemp,pdth3d,pdq2
+ parameter (pdzero=0.0, pdtemp=256.0, pdth3d=32.0, pdq2=1.0)
+c
+ real harmon,a,b
+ include 'stmt_fns.h'
+c
+c --- harmonic mean
+ harmon(a,b)=2.*a*b/(a+b)
+c
+ mbdy = mbdy_advtyp(abs(advtyp)) ! 2-8 depending on advection scheme
+c
+ if (nbdy.lt.mbdy) then
+ if (mnproc.eq.1) then
+ write(lp,'(/ a,i3,a /)')
+ & 'error: nbdy (dimensions.h) must be at least',
+ & mbdy,' for the advection scheme indicated by advtyp'
+ endif
+ call xcstop('tsadvc')
+ stop 'tsadvc'
+ endif
+c
+ l = mbdy
+ call xctilr(saln( 1-nbdy,1-nbdy,1,1),1,2*kk, l,l, halo_ps)
+ call xctilr(temp( 1-nbdy,1-nbdy,1,1),1,2*kk, l,l, halo_ps)
+ call xctilr(th3d( 1-nbdy,1-nbdy,1,1),1,2*kk, l,l, halo_ps)
+ call xctilr(dp( 1-nbdy,1-nbdy,1,1),1,2*kk, l,l, halo_ps)
+ call xctilr(dpold( 1-nbdy,1-nbdy,1 ),1, kk, l,l, halo_ps)
+ call xctilr(uflx( 1-nbdy,1-nbdy,1 ),1, kk, l,l, halo_uv)
+ call xctilr(vflx( 1-nbdy,1-nbdy,1 ),1, kk, l,l, halo_vv)
+ do ktr= 1,ntracr
+ call xctilr(tracer( 1-nbdy,1-nbdy,1,1,ktr),1,2*kk, l,l, halo_ps)
+ enddo !ktr
+ if (mxlmy) then
+ call xctilr(q2( 1-nbdy,1-nbdy,0,1),1,2*kk+2, l,l, halo_ps)
+ call xctilr(q2l( 1-nbdy,1-nbdy,0,1),1,2*kk+2, l,l, halo_ps)
+ endif
+c
+ do 81 k=1,kk
+c
+c --- ---------------------------------------------------
+c --- advection of thermodynamic variable(s) (and tracer)
+c --- ---------------------------------------------------
+c
+c --- for isopycnic vertical coordinates:
+c --- advect -th3d- and -saln- in the mixed layer (layer 1),
+c --- advect -saln- only in all other layers
+c --- for hybrid vertical coordinates:
+c --- advect -temp- and -saln- in all layers if advflg==0,
+c --- advect -th3d- and -saln- in all layers if advflg==1
+c
+ latemp = k.le.nhybrd .and. advflg.eq.0 ! advect temp
+ lath3d = (k.le.nhybrd .and. advflg.eq.1) .or.
+ & (k.eq.1 .and. isopyc ) ! advect th3d
+c
+c --- smooth mixed-layer mass fluxes in lateral direction
+ if(isopyc .and. k.eq.1) then
+c
+c --- rhs: vflx+, uflx+
+c --- lhs: vflux, uflux
+c
+ margin = mbdy - 1
+c
+ do j=1-margin,jj+margin
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ ia=max(i-1,ifv(j,l))
+ ib=min(i+1,ilv(j,l))
+ vflux(i,j)=.5*vflx(i,j,1)+.25*(vflx(ia,j,1)+vflx(ib,j,1))
+ enddo !i
+ enddo !l
+ enddo !j
+c
+ do i=1-margin,ii+margin
+ do l=1,jsu(i)
+ do j=max(1-margin,jfu(i,l)),min(jj+margin,jlu(i,l))
+ ja=max(j-1,jfu(i,l))
+ jb=min(j+1,jlu(i,l))
+ uflux(i,j)=.5*uflx(i,j,1)+.25*(uflx(i,ja,1)+uflx(i,jb,1))
+ enddo !j
+ enddo !l
+ enddo !i
+ endif
+c
+c --- rhs: temp, saln, uflux+, vflux+, dp
+c --- lhs: told, sold, util1, util2, util3, temp, th3d
+c
+c --- util1 = fco = thickness of the layer at old time step
+c --- util2 = fcn = thickness of the layer at new time step
+c
+ margin = mbdy - 1 ! util[12] at mbdy-2
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,ktr,flxdiv)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+c
+c --- save for time smoothing
+ if (latemp) then
+ told(i,j)=temp(i,j,k,n)
+ elseif (lath3d) then
+ told(i,j)=th3d(i,j,k,n)
+ endif
+ sold(i,j)=saln(i,j,k,n)
+ do ktr= 1,ntracr
+ trold(i,j,ktr)=tracer(i,j,k,n,ktr)
+ enddo
+ if (mxlmy) then
+ q2old( i,j)=q2( i,j,k,n)
+ q2lold(i,j)=q2l(i,j,k,n)
+ endif
+c
+c --- before calling 'advem', make sure (a) mass fluxes are consistent
+c --- with layer thickness change, and (b) all fields are positive-definite
+ if(isopyc .and. k.eq.1) then
+ flxdiv=((uflux(i+1,j) -uflux(i,j) )
+ & +(vflux(i,j+1) -vflux(i,j) ))*delt1*scp2i(i,j)
+ else
+ flxdiv=((uflx( i+1,j,k)-uflx( i,j,k))
+ & +(vflx( i,j+1,k)-vflx( i,j,k)))*delt1*scp2i(i,j)
+ endif
+ util1(i,j)=max(dp(i,j,k,n)+flxdiv,0.0) !old
+ util2(i,j)=max(dp(i,j,k,n), 0.0) !new
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write(text,'(a10,i2)') '49:sold,k=',k
+ call pipe_compare_sym1(sold,ip,text)
+ write(text,'(a10,i2)') '49:told,k=',k
+ call pipe_compare_sym1(told,ip,text)
+ write(text,'(a10,i2)') '49:utl1,k=',k
+ call pipe_compare_sym1(util1,ip,text)
+ write(text,'(a10,i2)') '49:utl2,k=',k
+ call pipe_compare_sym1(util2,ip,text)
+ write (textu,'(a9,i3)') 'uflx k=',k
+ write (textv,'(a9,i3)') 'vflx k=',k
+ call pipe_compare_sym2(uflx(1-nbdy,1-nbdy,k), iu,textu,
+ & vflx(1-nbdy,1-nbdy,k), iv,textv)
+ write (text,'(a9,i3)') 'temp.n k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'saln.n k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'th3d.n k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,n),ip,text)
+ endif
+c
+c --- rhs: temp.[mn], th3d.[mn], saln.[mn], uflx, vflx, util[12]
+c --- lhs: temp.n, th3d.n, saln.n
+c
+ if (latemp) then
+ call advem(advtyp,temp( 1-nbdy,1-nbdy,k,n),
+ & temp( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdtemp, scp2,scp2i,delt1)
+ call advem(advtyp,saln( 1-nbdy,1-nbdy,k,n),
+ & saln( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdzero, scp2,scp2i,delt1)
+ elseif (lath3d .and. hybrid) then
+ call advem(advtyp,th3d( 1-nbdy,1-nbdy,k,n),
+ & th3d( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdth3d, scp2,scp2i,delt1)
+ call advem(advtyp,saln( 1-nbdy,1-nbdy,k,n),
+ & saln( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdzero, scp2,scp2i,delt1)
+ elseif (lath3d .and. isopyc) then ! MICOM-like upper layer
+ call advem(advtyp,th3d( 1-nbdy,1-nbdy,k,n),
+ & th3d( 1-nbdy,1-nbdy,k,m),
+ & uflux,
+ & vflux,
+ & util1,util2,
+ & pdth3d, scp2,scp2i,delt1)
+ call advem(advtyp,saln( 1-nbdy,1-nbdy,k,n),
+ & saln( 1-nbdy,1-nbdy,k,m),
+ & uflux,
+ & vflux,
+ & util1,util2,
+ & pdzero, scp2,scp2i,delt1)
+ else ! exactly isopycnal layer
+ call advem(advtyp,saln( 1-nbdy,1-nbdy,k,n),
+ & saln( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdzero, scp2,scp2i,delt1)
+ endif
+ do ktr= 1,ntracr
+ if (trcflg(ktr).eq.2) then !temperature tracer
+ call advem(advtyp,tracer(1-nbdy,1-nbdy,k,n,ktr),
+ & tracer(1-nbdy,1-nbdy,k,m,ktr),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdtemp, scp2,scp2i,delt1)
+ else
+ call advem(advtyp,tracer(1-nbdy,1-nbdy,k,n,ktr),
+ & tracer(1-nbdy,1-nbdy,k,m,ktr),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdzero, scp2,scp2i,delt1)
+ endif !trcflg
+ enddo !ktr
+ if (mxlmy) then
+ call advem(advtyp,q2( 1-nbdy,1-nbdy,k,n),
+ & q2( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdq2, scp2,scp2i,delt1)
+ call advem(advtyp,q2l( 1-nbdy,1-nbdy,k,n),
+ & q2l( 1-nbdy,1-nbdy,k,m),
+ & uflx( 1-nbdy,1-nbdy,k),
+ & vflx( 1-nbdy,1-nbdy,k),
+ & util1,util2,
+ & pdq2, scp2,scp2i,delt1)
+ endif
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'temp.n k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'saln.n k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'th3d.n k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,n),ip,text)
+ endif
+c
+c --- rhs: temp.n, th3d.n, saln.n, dpold, dp.m, dp.n, sold, told
+c --- lhs: temp.n, th3d.n, dp.m, saln.m, temp.m, th3d.m
+c
+ margin = 0 !after advem
+c
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,ktr,pold,pmid,pnew,wts2dp) !NOCSD
+!$OMP& SCHEDULE(STATIC,jblk) !NOCSD
+ do j=1-margin,jj+margin
+ sminny(j)= 999. !simplifies OpenMP parallelization
+ smaxxy(j)=-999. !simplifies OpenMP parallelization
+ do l=1,isp(j)
+!DIR$ PREFERVECTOR
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (dp(i,j,k,n).gt.onemm) then
+ sminny(j)=min(sminny(j),saln(i,j,k,n))
+ smaxxy(j)=max(smaxxy(j),saln(i,j,k,n))
+ endif
+c
+c --- Asselin time smoothing of thickness field
+ pold=max(0.0,dpold(i,j,k))
+ pmid=max(0.0,dp(i,j,k,m))
+ pnew=max(0.0,dp(i,j,k,n))
+ dp(i,j,k,m)=pmid*wts1+(pold+pnew)*wts2
+c --- Asselin time smoothing of thermodynamic variables (and tracer)
+c --- Note that this is conservative (i.e. smoothing dp * scalar)
+ pmid=max(0.0,dp(i,j,k,m))
+ wts2dp=wts2/(pmid+onemu)
+ saln(i,j,k,m)=saln(i,j,k,m)
+ & +wts2dp*(pold*(sold(i,j) -saln(i,j,k,m))+
+ & pnew*(saln(i,j,k,n)-saln(i,j,k,m)) )
+ if (latemp) then
+ temp(i,j,k,m)=temp(i,j,k,m)
+ & +wts2dp*(pold*(told(i,j) -temp(i,j,k,m))+
+ & pnew*(temp(i,j,k,n)-temp(i,j,k,m)) )
+ th3d(i,j,k,m)=sig(temp(i,j,k,m),saln(i,j,k,m))-thbase
+c --- update dependent thermodynamic variable after advection
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ elseif (lath3d) then
+ th3d(i,j,k,m)=th3d(i,j,k,m)
+ & +wts2dp*(pold*(told(i,j) -th3d(i,j,k,m))+
+ & pnew*(th3d(i,j,k,n)-th3d(i,j,k,m)) )
+ temp(i,j,k,m)=tofsig(th3d(i,j,k,m)+thbase,saln(i,j,k,m))
+c --- update dependent thermodynamic variable after advection
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ else ! exactly isopycnal layer
+ th3d(i,j,k,m)=theta(i,j,k)
+ temp(i,j,k,m)=tofsig(th3d(i,j,k,m)+thbase,saln(i,j,k,m))
+c --- update dependent thermodynamic variable after advection
+ th3d(i,j,k,n)=theta(i,j,k)
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,saln(i,j,k,n))
+ endif
+ do ktr= 1,ntracr
+ tracer(i,j,k,m,ktr)=tracer(i,j,k,m,ktr)
+ & +wts2dp*(pold*( trold(i,j, ktr)-tracer(i,j,k,m,ktr))+
+ & pnew*(tracer(i,j,k,n,ktr)-tracer(i,j,k,m,ktr)) )
+ enddo !ktr
+ if (mxlmy) then
+ q2( i,j,k,m)=q2( i,j,k,m)
+ & +wts2dp*(pold*(q2old( i,j) -q2( i,j,k,m))+
+ & pnew*(q2( i,j,k,n) -q2( i,j,k,m)) )
+ q2l(i,j,k,m)=q2l(i,j,k,m)
+ & +wts2dp*(pold*(q2lold(i,j) -q2l(i,j,k,m))+
+ & pnew*(q2l(i,j,k,n) -q2l(i,j,k,m)) )
+ endif
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO !NOCSD
+c
+ xmin(k) = minval(sminny(1:jj))
+ xmax(k) = maxval(smaxxy(1:jj))
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'temp.m k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,m),ip,text)
+ write (text,'(a9,i3)') 'temp.n k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'sold k=',k
+ call pipe_compare_sym1(sold,ip,text)
+ write (text,'(a9,i3)') 'saln.m k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,m),ip,text)
+ write (text,'(a9,i3)') 'saln.n k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'told k=',k
+ call pipe_compare_sym1(told,ip,text)
+ write (text,'(a9,i3)') 'th3d.m k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,m),ip,text)
+ write (text,'(a9,i3)') 'th3d.n k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,n),ip,text)
+ endif
+c
+cdiag if (itest.gt.0.0and.jtest.gt.0)
+cdiag.write (lp,'(i9,2i5,i3,'' th,s,dp after advection '',2f9.3,f8.2)')
+cdiag.nstep,itest,jtest,k,temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag.dp(itest,jtest,k,n)*qonem
+c
+ 81 continue ! k=1,kk
+c
+ call pipe_comparall(m,n, 'advem, step')
+c
+c --- check for negative scalar fields.
+c
+ 101 format (i9,' i,j,k =',2i5,i3,a,2f8.2)
+c
+ if (mod(nstep,3).eq.0 .or. diagno) then
+ call xcminr(xmin(1:kk))
+ call xcmaxr(xmax(1:kk))
+c
+ do k= 1,kk
+ sminn=xmin(k)
+ smaxx=xmax(k)
+c
+ if (sminn.lt.0.0) then
+ do j=1,jj
+ do l=1,isp(j)
+ do i=max(1,ifp(j,l)),min(ii,ilp(j,l))
+ if (saln(i,j,k,n).eq.sminn) then
+ write (lp,101) nstep,i+i0,j+j0,k,
+ & ' neg. saln after advem call ',
+ & saln(i,j,k,n)
+ endif
+ enddo !i
+ enddo !l
+ enddo !j
+ call xcsync(flush_lp)
+ endif
+c
+ if (diagno) then
+ if (mnproc.eq.1) then
+ write (lp,'(i9,i3, a,2f7.3, a,1pe9.2,a)')
+ & nstep,k,
+ & ' min/max of s after advection:',sminn,smaxx,
+ & ' (range:',smaxx-sminn,')'
+ call flush(lp)
+ endif
+ endif
+ enddo !k
+ endif !every 3 time steps or diagno
+c
+c --- --------------------------------------
+c --- diffusion of thermodynamic variable(s)
+c --- --------------------------------------
+c
+ if (temdf2.gt.0.0) then
+ mdf = 2 !Laplacian
+ call xctilr(saln( 1-nbdy,1-nbdy,1,n),1,kk, mdf,mdf, halo_ps)
+ call xctilr(temp( 1-nbdy,1-nbdy,1,n),1,kk, mdf,mdf, halo_ps)
+ call xctilr(th3d( 1-nbdy,1-nbdy,1,n),1,kk, mdf,mdf, halo_ps)
+ if (mxlmy) then
+ call xctilr(q2( 1-nbdy,1-nbdy,0,n),1,kk+1, mdf,mdf, halo_ps)
+ call xctilr(q2l(1-nbdy,1-nbdy,0,n),1,kk+1, mdf,mdf, halo_ps)
+ endif
+ do ktr= 1,ntracr
+ call xctilr(tracer(1-nbdy,1-nbdy,1,n,ktr),
+ & 1,kk, mdf,mdf, halo_ps)
+ enddo !ktr
+c
+ do k=1,kk
+c
+c --- for isopycnic vertical coordinates:
+c --- diffuse -th3d- and -saln- in the mixed layer (layer 1),
+c --- diffuse -saln- only in all other layers
+c --- for hybrid vertical coordinates:
+c --- diffuse -saln- in all layers
+c --- diffuse -temp- in all layers if temdfc < 0.0
+c --- diffuse -th3d- in all layers if temdfc < 1.0
+c --- if 0.0 < temdfc < 1.0:
+c --- combine -temp- and -th3d- diffusion in density space
+c
+ ldtemp = k.le.nhybrd .and. temdfc.gt.0.0 ! diffus temp
+ ldth3d = (k.le.nhybrd .and. temdfc.lt.1.0) .or.
+ & (k.eq.1 .and. isopyc ) ! diffus th3d
+ if (ldtemp .and. ldth3d) then ! diffus temp and th3d
+ call tsdff_2x(th3d(1-nbdy,1-nbdy,k,n),
+ & temp(1-nbdy,1-nbdy,k,n))
+ call tsdff_1x(saln(1-nbdy,1-nbdy,k,n))
+ elseif (ldtemp) then ! diffus temp
+ call tsdff_2x(temp(1-nbdy,1-nbdy,k,n),
+ & saln(1-nbdy,1-nbdy,k,n))
+ elseif (ldth3d) then ! diffus th3d
+ call tsdff_2x(th3d(1-nbdy,1-nbdy,k,n),
+ & saln(1-nbdy,1-nbdy,k,n))
+ else ! exactly isopycnal layer
+ call tsdff_1x(saln(1-nbdy,1-nbdy,k,n))
+ endif
+ if (mxlmy) then
+ call tsdff_2x(q2( 1-nbdy,1-nbdy,k,n),
+ & q2l( 1-nbdy,1-nbdy,k,n))
+ endif !mxlmy
+ do ktr= 1,ntracr,2
+ if (ktr+1.le.ntracr) then
+ call tsdff_2x(tracer(1-nbdy,1-nbdy,k,n,ktr),
+ & tracer(1-nbdy,1-nbdy,k,n,ktr+1))
+ else
+ call tsdff_1x(tracer(1-nbdy,1-nbdy,k,n,ktr))
+ endif
+ enddo !ktr
+ enddo !k
+c
+c non-independent thermodynamic variable
+c
+ margin = 0
+!$OMP PARALLEL DO PRIVATE(j,k,l,i,ldtemp,ldth3d,th3d_t)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do k=1,kk
+ ldtemp = k.le.nhybrd .and. temdfc.gt.0.0 ! diffus temp
+ ldth3d = (k.le.nhybrd .and. temdfc.lt.1.0) .or.
+ & (k.eq.1 .and. isopyc ) ! diffus th3d
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ if (ldtemp .and. ldth3d) then
+c --- combine -temp- and -th3d- diffusion in density space
+ th3d_t =sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ th3d(i,j,k,n)=(1.0-temdfc)*th3d(i,j,k,n) +
+ & temdfc *th3d_t
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,
+ & saln(i,j,k,n))
+ elseif (ldtemp) then
+ th3d(i,j,k,n)=sig(temp(i,j,k,n),saln(i,j,k,n))-thbase
+ elseif (ldth3d) then
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,
+ & saln(i,j,k,n))
+ else ! exactly isopycnal layer
+ th3d(i,j,k,n)=theta(i,j,k)
+ temp(i,j,k,n)=tofsig(th3d(i,j,k,n)+thbase,
+ & saln(i,j,k,n))
+ endif
+ enddo !i
+ enddo !l
+ enddo !k
+ enddo !j
+!$OMP END PARALLEL DO
+ endif !temdf2.gt.0.0
+c
+ do k=1,kk
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'util1 k=',k
+ call pipe_compare_sym1(util1,ip,text)
+ write (text,'(a9,i3)') 'util2 k=',k
+ call pipe_compare_sym1(util2,ip,text)
+ write (text,'(a9,i3)') 'temp.n k=',k
+ call pipe_compare_sym1(temp(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'saln.n k=',k
+ call pipe_compare_sym1(saln(1-nbdy,1-nbdy,k,n),ip,text)
+ write (text,'(a9,i3)') 'th3d.n k=',k
+ call pipe_compare_sym1(th3d(1-nbdy,1-nbdy,k,n),ip,text)
+ endif
+c
+cdiag if (itest.gt.0.and.jtest.gt.0) then
+cdiag& write (lp,'(i9,2i5,i3,a,2f9.3,f8.2)')
+cdiag& nstep,itest+i0,jtest+j0,k,
+cdiag& ' t,s,dp after isopyc.mix.',
+cdiag& temp(itest,jtest,k,n),saln(itest,jtest,k,n),
+cdiag& dp(itest,jtest,k,n)*qonem
+cdiag& call flush(lp)
+cdiag& endif
+c
+ enddo !k
+
+ return
+
+ contains
+c
+ subroutine tsdff_2x(fld1,fld2)
+ real fld1(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy),
+ & fld2(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- Laplacian diffusion for two scalar fields
+c
+ margin = 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,factor)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ factor=temdf2*aspux(i,j)*
+ & scuy(i,j)*harmon(max(dp(i-1,j,k,n),onemu)
+ & ,max(dp(i ,j,k,n),onemu))
+ uflux (i,j)=factor*(fld1(i-1,j)-fld1(i,j))
+ uflux2(i,j)=factor*(fld2(i-1,j)-fld2(i,j))
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ factor=temdf2*aspvy(i,j)*
+ & scvx(i,j)*harmon(max(dp(i,j-1,k,n),onemu)
+ & ,max(dp(i,j ,k,n),onemu))
+ vflux (i,j)=factor*(fld1(i,j-1)-fld1(i,j))
+ vflux2(i,j)=factor*(fld2(i,j-1)-fld2(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (textu,'(a9,i3)') 'uflux k=',k
+ write (textv,'(a9,i3)') 'vflux k=',k
+ call pipe_compare_sym2(uflux, iu,textu,
+ & vflux, iv,textv)
+ write (textu,'(a9,i3)') 'uflux2 k=',k
+ write (textv,'(a9,i3)') 'vflux2 k=',k
+ call pipe_compare_sym2(uflux2,iu,textu,
+ & vflux2,iv,textv)
+ endif
+c
+c --- rhs: dp.n, uflux+, vflux+, uflux2+, vflux2+
+c --- lhs: saln.n, temp.n, th3d.n
+c
+ margin = 0
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,factor)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ factor=-delt1/(scp2(i,j)*max(dp(i,j,k,n),onemu))
+ util1(i,j)=((uflux (i+1,j)-uflux (i,j))
+ & +(vflux (i,j+1)-vflux (i,j)))*factor
+ fld1(i,j)=fld1(i,j)+util1(i,j)
+ util2(i,j)=((uflux2(i+1,j)-uflux2(i,j))
+ & +(vflux2(i,j+1)-vflux2(i,j)))*factor
+ fld2(i,j)=fld2(i,j)+util2(i,j)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag if (1.le.i .and. i.le.ii .and.
+cdiag. 1.le.j .and. j.le.jj ) then
+cdiag. write (lp,100) nstep,i+i0,j+j0,k,'t,s,dt,ds',
+cdiag. fld1(i,j),fld2(i,j),util1(i,j),util2(i,j)
+cdiag. call flush(lp)
+cdiag. endif
+cdiag. endif
+c
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'util1 k=',k
+ call pipe_compare_sym1(util1,ip,text)
+ write (text,'(a9,i3)') 'util2 k=',k
+ call pipe_compare_sym1(util2,ip,text)
+ write (text,'(a9,i3)') 'fld1.n k=',k
+ call pipe_compare_sym1(fld1(1-nbdy,1-nbdy),ip,text)
+ write (text,'(a9,i3)') 'fld2.n k=',k
+ call pipe_compare_sym1(fld2(1-nbdy,1-nbdy),ip,text)
+ endif
+c
+ return
+ end subroutine tsdff_2x
+c
+ subroutine tsdff_1x(fld1)
+ real fld1(1-nbdy:idm+nbdy,1-nbdy:jdm+nbdy)
+c
+c --- Laplacian diffusion for a single scalar field
+c
+ margin = 1
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,factor)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isu(j)
+ do i=max(1-margin,ifu(j,l)),min(ii+margin,ilu(j,l))
+ factor=temdf2*aspux(i,j)*
+ & scuy(i,j)*harmon(max(dp(i-1,j,k,n),onemu)
+ & ,max(dp(i ,j,k,n),onemu))
+ uflux (i,j)=factor*(fld1(i-1,j)-fld1(i,j))
+ enddo !i
+ enddo !l
+ do l=1,isv(j)
+ do i=max(1-margin,ifv(j,l)),min(ii+margin,ilv(j,l))
+ factor=temdf2*aspvy(i,j)*
+ & scvx(i,j)*harmon(max(dp(i,j-1,k,n),onemu)
+ & ,max(dp(i,j ,k,n),onemu))
+ vflux (i,j)=factor*(fld1(i,j-1)-fld1(i,j))
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (textu,'(a9,i3)') 'uflux k=',k
+ write (textv,'(a9,i3)') 'vflux k=',k
+ call pipe_compare_sym2(uflux, iu,textu,
+ & vflux, iv,textv)
+ endif
+c
+c --- rhs: dp.n, uflux+, vflux+, uflux2+, vflux2+
+c --- lhs: saln.n, temp.n, th3d.n
+c
+ margin = 0
+c
+!$OMP PARALLEL DO PRIVATE(j,l,i,factor)
+!$OMP& SCHEDULE(STATIC,jblk)
+ do j=1-margin,jj+margin
+ do l=1,isp(j)
+ do i=max(1-margin,ifp(j,l)),min(ii+margin,ilp(j,l))
+ factor=-delt1/(scp2(i,j)*max(dp(i,j,k,n),onemu))
+ util1(i,j)=((uflux (i+1,j)-uflux (i,j))
+ & +(vflux (i,j+1)-vflux (i,j)))*factor
+ fld1(i,j)=fld1(i,j)+util1(i,j)
+c
+cdiag if (i.eq.itest.and.j.eq.jtest) then
+cdiag if (1.le.i .and. i.le.ii .and.
+cdiag. 1.le.j .and. j.le.jj ) then
+cdiag. write (lp,100) nstep,i+i0,j+j0,k,'t,s,dt,ds',
+cdiag. fld1(i,j),0.0,util1(i,j),0.0
+cdiag. call flush(lp)
+cdiag. endif
+cdiag. endif
+c
+ enddo !i
+ enddo !l
+ enddo !j
+!$OMP END PARALLEL DO
+c
+ if (lpipe .and. lpipe_tsadvc) then
+c --- compare two model runs.
+ write (text,'(a9,i3)') 'util1 k=',k
+ call pipe_compare_sym1(util1,ip,text)
+ write (text,'(a9,i3)') 'fld1.n k=',k
+ call pipe_compare_sym1(fld1(1-nbdy,1-nbdy),ip,text)
+ endif
+c
+ return
+ end subroutine tsdff_1x
+
+c-----end contains
+
+ end subroutine tsadvc
+c
+c Revision history:
+c
+c> June 1995 - eliminated setting of salinity in massless layers (loop 46)
+c> (this is now done in mxlayr.f)
+c> Aug. 1995 - omitted t/s/dp time smoothin, case of abrupt mxlayr.thk.change
+c> Sep. 1995 - increased temdf2 if mixed layer occupies >90% of column
+c> Mar. 2000 - removed 'cushn' and added logic to assure global conservation
+c> Apr. 2000 - conversion to SI units
+c> Apr. 2000 - changed i/j loop nesting to j/i
+c> Aug. 2000 - temp advection and diffusion only for hybrid vertical coordinate
+c> Nov. 2000 - nhybrd T&S advection layers, kdm-nhybrd S advection layers
+c> Nov. 2000 - T&S or th&S advection/diffusion based on advflg
+c> Feb. 2001 - placed advem in a module
+c> May 2002 - diffusion coefficent based on max(sc?x,sc?y)
+c> Aug. 2003 - separate PCM and MPDATA versions (advtyp)
+c> Aug. 2003 - added FCT2 and UTOPIA advection options.
+c> Nov. 2003 - per layer diffusion routine for 1 or 2 scalar fields
+c> Feb. 2008 - fixed famin,famax bugs in FCT2/4
diff --git a/src_2.2.18_3_one/unit_offset.h b/src_2.2.18_3_one/unit_offset.h
new file mode 100755
index 0000000..e6b12e1
--- /dev/null
+++ b/src_2.2.18_3_one/unit_offset.h
@@ -0,0 +1,4 @@
+c
+c --- uoff= offset for all unit numbers (in module mod_xc)
+ integer uoff
+ parameter (uoff=2000)
diff --git a/src_2.2.18_3_one/wtime.F b/src_2.2.18_3_one/wtime.F
new file mode 100755
index 0000000..f9198f1
--- /dev/null
+++ b/src_2.2.18_3_one/wtime.F
@@ -0,0 +1,87 @@
+#if defined(AIX)
+ REAL*8 FUNCTION WTIME_DUMMY()
+ IMPLICIT NONE
+C
+C USE A C-ROUTINE, SEE machi_c.c.
+C
+ WTIME_DUMMY = 0.0
+ RETURN
+C END OF WTIME_DUMMY.
+ END
+#elif defined(MPI)
+ REAL*8 FUNCTION WTIME()
+ IMPLICIT NONE
+C
+C USE THE MPI FUNCTION MPI_WTIME TO RETURN WALL TIME.
+C
+ DOUBLE PRECISION MPI_WTIME
+C
+ WTIME = MPI_WTIME()
+ RETURN
+C END OF WTIME.
+ END
+#else
+ REAL*8 FUNCTION WTIME()
+ IMPLICIT NONE
+C
+C USE THE F90 INTRINSIC SYSTEM_CLOCK TO RETURN WALL TIME.
+C
+C WILL FAIL IF THE COUNT IS EVER NEGATIVE, BUT THE STANDARD
+C SAYS THAT IT IS AWAYS NON-NEGATIVE IF A CLOCK EXISTS.
+C NOT THREAD-SAFE, UNLESS LCOUNT AND IOVER ARE THREADPRIVATE.
+C
+ REAL*8 ZERO,ONE
+ PARAMETER (ZERO=0.0, ONE=1.0)
+C
+ INTEGER COUNT, MCOUNT, RATE
+C
+ REAL*8 OFFSEC, OFFSET, PERSEC
+ INTEGER ICOUNT, IOVER, LCOUNT, NCOUNT
+ SAVE OFFSEC, OFFSET, PERSEC
+ SAVE ICOUNT, IOVER, LCOUNT, NCOUNT
+C
+ DATA IOVER, LCOUNT / -1, -1 /
+C
+ CALL SYSTEM_CLOCK(COUNT)
+C
+ IF (COUNT.LT.LCOUNT) THEN
+C
+C COUNT IS SUPPOSED TO BE NON-DECREASING EXCEPT WHEN IT WRAPS,
+C BUT SOME IMPLEMENTATIONS DON''T DO THIS. SO IGNORE ANY
+C DECREASE OF LESS THAN ONE PERCENT OF THE RANGE.
+C
+ IF (LCOUNT-COUNT.LT.NCOUNT) THEN
+ COUNT = LCOUNT
+ ELSE
+ IOVER = IOVER + 1
+ OFFSET = OFFSET + OFFSEC
+ ENDIF
+ ENDIF
+ LCOUNT = COUNT
+C
+ IF (IOVER.EQ.0) THEN
+C
+C FIRST CYCLE, FOR ACCURACY WITH 64-BIT COUNTS.
+C
+ WTIME = (COUNT - ICOUNT) * PERSEC
+ ELSEIF (IOVER.GT.0) THEN
+C
+C ALL OTHER CYCLES.
+C
+ WTIME = COUNT * PERSEC + OFFSET
+ ELSE
+C
+C INITIALIZATION.
+C
+ CALL SYSTEM_CLOCK(ICOUNT, RATE, MCOUNT)
+ NCOUNT = MCOUNT/100
+ PERSEC = ONE/RATE
+ OFFSEC = MCOUNT * PERSEC
+ OFFSET = -ICOUNT * PERSEC
+ IOVER = 0
+ WTIME = ZERO
+ ENDIF
+ RETURN
+C END OF WTIME.
+ END
+#endif /* MPI:else */
diff --git a/topo/depth_BB86_01.a b/topo/depth_BB86_01.a
new file mode 100755
index 0000000..1cb7da1
Binary files /dev/null and b/topo/depth_BB86_01.a differ
diff --git a/topo/depth_BB86_01.b b/topo/depth_BB86_01.b
new file mode 100755
index 0000000..810e3d6
--- /dev/null
+++ b/topo/depth_BB86_01.b
@@ -0,0 +1,6 @@
+Bathymetry
+i/jdm = 101 101
+
+
+
+min,max depth = 5000.00000 5000.00000
diff --git a/topo/regional.grid.BB86.a b/topo/regional.grid.BB86.a
new file mode 100755
index 0000000..20c2348
Binary files /dev/null and b/topo/regional.grid.BB86.a differ
diff --git a/topo/regional.grid.BB86.b b/topo/regional.grid.BB86.b
new file mode 100755
index 0000000..cab8aef
--- /dev/null
+++ b/topo/regional.grid.BB86.b
@@ -0,0 +1,22 @@
+ 101 'idm ' = longitudinal array size
+ 101 'jdm ' = latitudinal array size
+ 0 'mapflg' = map flag (0=mercator,10=panam,12=ulon-panam)
+plon: min,max = 0.00000 20.00000
+plat: min,max = 0.00000 20.00000
+qlon: min,max = -0.10000 19.90000
+qlat: min,max = -0.10000 19.90000
+ulon: min,max = -0.10000 19.90000
+ulat: min,max = 0.00000 20.00000
+vlon: min,max = 0.00000 20.00000
+vlat: min,max = -0.10000 19.90000
+pang: min,max = 0.00000 0.00000
+pscx: min,max = 20000.00000 20000.00000
+pscy: min,max = 20000.00000 20000.00000
+qscx: min,max = 20000.00000 20000.00000
+qscy: min,max = 20000.00000 20000.00000
+uscx: min,max = 20000.00000 20000.00000
+uscy: min,max = 20000.00000 20000.00000
+vscx: min,max = 20000.00000 20000.00000
+vscy: min,max = 20000.00000 20000.00000
+cori: min,max = 7.34000E-05 1.13400E-04
+pasp: min,max = 1.00000 1.00000