SUBROUTINE BLOKINIT( 1,52BLOKINIT.3
C BLOKINIT.4
CLL==================================================================== BLOKINIT.5
CLL BLOKINIT.6
CLL Subroutine : BLOKINIT BLOKINIT.7
CLL BLOKINIT.8
CLL Author : R.Hill BLOKINIT.9
CLL BLOKINIT.10
CLL Date : 01.09.94 BLOKINIT.11
CLL BLOKINIT.12
CLL Reviewer : BLOKINIT.13
CLL BLOKINIT.14
CLL Version : 3.4 BLOKINIT.15
CLL BLOKINIT.16
CLL Purpose: Carries out the initialisation of arrays local to BLOKINIT.17
CLL blocks of rows. Once this is done, BLOKCALC is called ORH5F401.3
CLL which is the main row by row calculation. BLOKINIT.19
! Modification History: ORH1F305.3794
! Version Date Details ORH1F305.3795
! ------- ------- ------------------------------------------ ORH1F305.3796
! 3.5 16.01.95 Remove *IF dependency. R.Hill ORH1F305.3797
! 4.3 Compute RHOSRN to be passed from BLOKINIT to ORH6F404.751
! ROWCALC for mpp code use. ORH6F404.752
! Also Bug fix for when L_OEXTRAP is defined. ORH6F404.753
! R. Hill ORH6F404.754
! 4.4 14.08.97 General tidy up to ease maintenance, ORH6F404.755
! readability and future development. R.Hill ORH6F404.756
! ORH6F404.757
! 4.4 15/08/97 Remove SKIPLAND code. R. Hill ORH7F404.77
CLL 4.4 15/06/97 Initialise barotropic mode for free surface ORL1F404.770
CLL solution. R.Lenton ORL1F404.771
! 4.5 05/08/97 Changes for open boundary code. M.Bell/S.I. OSI1F405.99
CLL 4.5 3.11.98 Read in row j+2 data (TPP etc) if required OOM3F405.300
CLL Calculate row j+2 total velocity and save OOM3F405.301
CLL row j+2 baroclinic velocity. OOM3F405.302
CLL Calculate biharmonic mom diff variables D2U, OOM3F405.303
CLL D2V. M. Roberts OOM3F405.304
CLL 4.5 3.11.98 Call OUTFL_BC to set up boundary conditions on OOM2F405.138
CLL velocities for Med/Hud outflow M. Roberts OOM2F405.139
CLL 4.5 10/11/98 Call CALCDIFF instead of CALCESAV if new OOM1F405.305
CLL isopycnal diffusion required. OOM1F405.306
CLL Initialise variables used in new isopycnal OOM1F405.307
CLL diffusion and GM schemes. M. Roberts OOM1F405.308
!LL 4.5 17/09/98 Update calls to timer, required because of GPB8F405.72
!LL new barrier inside timer. P.Burton GPB8F405.73
CLL 4.5 26/01/98 Change variable names and logicals for use with ODC1F405.19
CLL the freedrift scheme for sea-ice advection. D.Cresswell. ODC1F405.20
! 4.5 5/6/97 Introduce a call to ADV_SOURCE (and a new OSY1F405.13
! logical L_BOOTSTRAP) to calculate FLUXST for OSY1F405.14
! the first row of the block. Redefine FVST to OSY1F405.15
! be equal to the south face velocity with no OSY1F405.16
! grid-spacing factors etc. as previously. OSY1F405.17
! D.Storkey OSY1F405.18
CLL BLOKINIT.20
CLL Calling Routine : BLOKCNTL BLOKINIT.21
CLL BLOKINIT.22
C======================================================================= BLOKINIT.23
CL Argument list BLOKINIT.24
*CALL ARGSIZE 
BLOKINIT.25
*CALL ARGD1 BLOKINIT.26
*CALL ARGDUMO BLOKINIT.27
*CALL ARGPTRO BLOKINIT.28
*CALL ARGOCALL BLOKINIT.29
*CALL ARGOINDX ORH7F402.313
*CALL COCAROWS BLOKINIT.30
&,ISX, ISY, WSX_LEADS, WSY_LEADS OLA0F404.11
&,TTN BLOKINIT.32
&,TMT, BLOKINIT.34
*CALL COCAWRKA BLOKINIT.35
*CALL ARGOC2DG OOM1F405.438
&,L_OBULKRI,L_OWINDMIX,L_OBULKMAXMLD OOM1F405.439
&,CARYSALT,CARYHEAT,FLXTOICE,LAMBDA_LARGE OOM1F405.440
&,co2_tot BLOKINIT.37
&,LL_ASS_BTRP,DU_ASS_BTRP,DV_ASS_BTRP ORH1F305.3798
&,rxp,ry,rrzp,esav ORH7F402.316
&,VISOPN OLA0F401.104
&,drhob1p,drhob2p OLA0F401.105
&,MLDSAV,RHOSRN,RHOSRNA,RHOSRNB OOM1F405.441
&,IMT_IPD_NOMIX_ARG ORH1F305.3799
&) BLOKINIT.46
C BLOKINIT.47
IMPLICIT NONE BLOKINIT.48
C BLOKINIT.49
C--------------------------------------------------------------------- BLOKINIT.50
C DEFINE GLOBAL DATA BLOKINIT.51
C--------------------------------------------------------------------- BLOKINIT.52
C BLOKINIT.53
*CALL OARRYSIZ ORH6F401.32
*CALL TYPSIZE BLOKINIT.54
*CALL TYPD1 BLOKINIT.55
*CALL TYPDUMO BLOKINIT.56
*CALL TYPPTRO BLOKINIT.57
*CALL TYPOINDX PXORDER.5
*CALL TYPOCALL BLOKINIT.58
*CALL COCTROWS BLOKINIT.59
*CALL COCTWRKA BLOKINIT.60
*CALL CNTLOCN ORH1F305.3800
*CALL OTIMER ORH1F305.3802
C BLOKINIT.61
REAL BLOKINIT.62
& TMT(JMT,KM) ! Meridional mass transport BLOKINIT.63
&,co2_tot ! Total net air-sea flux of CO2 BLOKINIT.65
&,TTN(8,JMT,NTMIN2) ! N'ward trnspt of tracers ORH1F305.3803
&,rxp(IMT_IPD,KM_IPD) ! OUT delta-rho x dirn row J+1 (E face) ORH1F305.3804
&,ry(IMT_IPD,KM_IPD) ! OUT delta-rho y dirn row J (N face) ORH1F305.3805
&,rrzp(IMT_IPD,KMP1_IPD) ! OUT delta-rho z dirn row J+1 (top face) ORH1F305.3806
&,esav(IMT_IPD,KM_IPD,NT_IPD) ! OUT initial e(I,K,2) for IPDFXCL ORH1F305.3807
&,VISOPN(IMT_GM,KM_GM) ! G&McW v* at north face of T gridbox OLA0F401.106
&,drhob1p(IMT_GM),drhob2p(IMT_GM,2) OLA0F401.107
*CALL TYPOC2DG OOM1F405.445
&,mldsav(IMT_IPD_MIX,JMT_IPD_MIX) ! IN from previous timestep ORH1F305.3808
&,CARYSALT(IMT,JMT),CARYHEAT(IMT,JMT),FLXTOICE(IMT,JMT) ! IN ICE OOM1F405.442
REAL OLA0F404.12
& ISX(IMT _idr,JMTM1_idr) ! IN Stress under sea ice ODC1F405.21
&,ISY(IMT_idr,JMTM1_idr) ! fraction ODC1F405.22
&,WSX_LEADS(IMT_idr,JMTM1_idr) ! IN Stress under leads ODC1F405.23
&,WSY_LEADS(IMT_idr,JMTM1_idr) ! fraction ODC1F405.24
C BLOKINIT.77
C variables related to Griffies GM implementation OOM1F405.1896
REAL OOM1F405.1897
& adv_vetiso(imt_gmm,km_gmm), OOM1F405.1898
& adv_vbtiso(imt_gmm,0:km_gmm),adv_fbiso(imt_gmm,0:km_gmm) OOM1F405.1899
OOM1F405.1900
C BLOKINIT.78
*IF DEF,MPP ORH9F402.147
! Variables required in message passing ORH9F402.154
INTEGER PE_SEND, PE_RECV, INFO ORH9F402.155
*ENDIF ORH9F402.156
INTEGER BLOKINIT.79
& IMT_IPD_NOMIX_ARG ! for dynamic allocation ORH7F402.317
C BLOKINIT.82
REAL BLOKINIT.84
& DV_ASS_BTRP(IMT_ASM,JMT_ASM) ORH1F305.3810
&,DU_ASS_BTRP(IMT_ASM,JMT_ASM) ORH1F305.3811
LOGICAL BLOKINIT.86
& LL_ASS_BTRP BLOKINIT.87
C BLOKINIT.89
CL ------------------------------------------------------------------ BLOKINIT.90
C DEFINE LOCAL VARIABLES BLOKINIT.91
C--------------------------------------------------------------------- BLOKINIT.92
INTEGER I, ! Grid point index (Zonal) BLOKINIT.93
& J, ! Grid point index (Meridional) BLOKINIT.94
& K, ! Grid point index (Vertical) BLOKINIT.95
& L, ! Ocean segment loop control BLOKINIT.96
& M, ! Tracer indicator BLOKINIT.97
& N, ! Control index BLOKINIT.98
& JJ, ! Meridional grid pt index BLOKINIT.99
& LL, ! Loop control for energy components BLOKINIT.100
& KMP, ! KM + 1 BLOKINIT.104
& JTO ORH0F405.5
&, JREAD ! The value of J to use when reading BLOKINIT.111
! data from disk for bootstrapping BLOKINIT.112
REAL DIAG1 ! Temporary storage of diagonal diff ORH0F405.6
&, DIAG2 ! " " " " " BLOKINIT.116
&, FX ! Temporary value BLOKINIT.117
&, FXA ! Temporary value BLOKINIT.125
&, FXB ! Temporary value BLOKINIT.126
& ,pt1,pt2,pt3 ! temporary variables OOM3F405.305
&, SFUBM(IMT) ! SFUB at J - 1 BLOKINIT.128
&, SFVBM(IMT) ! SFVB at J - 1 BLOKINIT.129
&, RHOSM(IMT,KM) ! RHOS at J - 1 BLOKINIT.130
&, RHOSM2(IMT,KM) ! RHOS at J - 2 BLOKINIT.131
&,RHOSRN(IMT,KM),RHOSRNA(IMT,KM+1),RHOSRNB(IMT,KM+1) OOM1F405.443
C FOR ROW JMTM1_GLOBAL OOM1F405.444
&, fxe ! local constant BLOKINIT.132
&, tempa(IMT,KMP1) ! workspace BLOKINIT.133
&, tempb(IMT,KMP1) ! workspace BLOKINIT.134
C local variables related to Griffies isopycnal diffusion + GM scheme OOM1F405.1901
REAL at,bt,ab,bb,epsln,ath0,sc,absstn,abssbn, OOM1F405.1902
& p5,c0,c1,slmxr,dtxsqr(km),top_bc(km),bot_bc(km), OOM1F405.1903
c & athkdftu_bi(imt_gmm,km_gmm),athkdftv_bi(imt_gmm,km_gmm), OOM1F405.1904
& stn_d2(imt,km),sbn_d2(imt,km) OOM1F405.1905
OOM1F405.1906
REAL part1, part2, Ath0_j, Ath0_jp1 OOM1F405.1907
OOM1F405.1908
REAL athkdftu_bi,athkdftv_bi,athstn,athsbn OOM1F405.1909
REAL athkdftu_mom(imt_gmm,km_gmm),athkdftv_mom(imt_gmm,km_gmm) OOM1F405.1910
OOM1F405.1911
REAL tanh_temp(imt*2) OOM1F405.1912
OOM1F405.1913
OOM1F405.1914
INTEGER km1,kp1 OOM1F405.1915
OOM1F405.1916
REAL WATERFLUX_ICE(IMT) ! WATER FLUX DUE TO ICE, ROW J OOM1F405.446
&, LAMBDA_LARGE ! IN VALUE USED IN CALCULATING MINIMUM MLD OOM1F405.447
LOGICAL L_OBULKRI,L_OWINDMIX,L_OBULKMAXMLD OOM1F405.448
REAL WSXM(IMT),WSYM(IMT) ! wind stress on row j-1 OLA3F403.156
REAL WSX_LEADSM(IMT),WSY_LEADSM(IMT), ODC1F405.37
& !wind stress on leads on row j-1 ODC1F405.38
& ISXM(IMT),ISYM(IMT) !ocean-ice stress on row j-1 ODC1F405.39
*IF DEF,MPP PXBLOKIN.1
REAL UBTBBCJ(IMT) !\ barotropic velocities for points ORL1F404.772
& ,VBTBBCJ(IMT) !/ outside standard halo. ORL1F404.773
*ENDIF PXBLOKIN.2
ORL1F404.774
LOGICAL OSY1F405.19
& L_BOOTSTRAP ! =.true. For call to ADV_SOURCE. OSY1F405.20
C dummy local variables used in call to ADV_SOURCE OSY1F405.21
REAL tempmed(imt,km),temptend(km,nt,4) OSY1F405.22
INTEGER OLA0F404.17
& J_idr,J_idrM1 ! value dependent on L_ICEFREEDR ODC1F405.25
INTEGER top_flow OOM2F405.140
C BLOKINIT.135
C This condition is not currently allowed in the UM but BLOKINIT.137
C is catered for in the subroutine TRACER so for the sake BLOKINIT.138
C of consistency it's definition is included here. BLOKINIT.139
REAL DIAG_MLD(IMT_IPD_NOMIX_ARG) ORH1F305.3812
*CALL UMSCALAR BLOKINIT.142
C BLOKINIT.143
C======================================================================= BLOKINIT.144
C BEGIN EXECUTABLE CODE BLOKINIT.145
C======================================================================= BLOKINIT.146
IF (L_OTIMER) CALL TIMER('BLOKINIT',3) ORH1F305.3813
C BLOKINIT.150
*IF DEF,MPP OOM1F405.449
CALL SWAPBOUNDS(CARYSALT,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OOM1F405.450
CALL SWAPBOUNDS(CARYHEAT,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OOM1F405.451
CALL SWAPBOUNDS(FLXTOICE,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OOM1F405.452
CALL SWAPBOUNDS(OCEANHEATFLUX,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OOM1F405.453
*ENDIF OOM1F405.454
OOM1F405.455
IF (L_OISOPYC.AND.(.NOT.L_OMIXLAY)) THEN ORH1F305.3814
C This condition is not currently allowed in the UMUI but ORH6F404.758
C is catered for in the subroutine TRACER so for the sake BLOKINIT.153
C of consistency it is initialised to zero here also. BLOKINIT.154
DO I = 1,IMT ORH6F404.759
DIAG_MLD(I) = 0.0 ORH6F404.760
ENDDO ORH6F404.761
ENDIF ORH1F305.3815
C BLOKINIT.159
KMP = KM + 1 BLOKINIT.160
C BLOKINIT.161
*IF DEF,MPP ORH9F402.58
JREAD = J_2 ORH9F402.59
! MPP version of code J_FROM_LOC is always 1 and J_TO_LOC is always ORH9F402.60
! equivalent to local version of JMT. This allows us to initialise ORH9F402.61
! full (local) domains of arrays, including halo areas ORH9F402.62
J_FROM_LOC = 1 ORH9F402.63
J_TO_LOC = JMT ORH9F402.64
*ELSE ORH9F402.65
IF (JST.EQ.1) THEN ORH9F402.66
JREAD=2 ORH9F402.67
ELSE ORH9F402.68
JREAD=JST ORH9F402.69
ENDIF ORH9F402.70
ORH9F402.71
J_FROM_LOC = JST ORH9F402.72
ORH9F402.73
IF (JFIN.GE.JMTM1_GLOBAL) THEN ORH9F402.74
J_TO_LOC = JMT ORH9F402.75
ELSE ORH9F402.76
J_TO_LOC = JFIN ORH9F402.77
ENDIF ORH9F402.78
*ENDIF ORH9F402.79
C======================================================================= BLOKINIT.176
CL Set up pointers to find u,v in slabs and UOVER,UUNDER,VOVER,VUNDER BLOKINIT.177
C======================================================================= BLOKINIT.178
CL BLOKINIT.179
C BLOKINIT.180
DO K=1,KM BLOKINIT.181
DO I=1,IMT BLOKINIT.182
DXTQ (I,K)=DXT (I) BLOKINIT.183
DXT4RQ(I,K)=DXT4R(I) BLOKINIT.184
DXUQ (I,K)=DXU (I) BLOKINIT.185
DXU2RQ(I,K)=DXU2R(I) BLOKINIT.186
DZZQ (I,K)=DZZ (K) BLOKINIT.187
DZ2RQ (I,K)=DZ2R (K) BLOKINIT.188
DZZ2RQ(I,K)=DZZ2R(K) BLOKINIT.189
C2DZQ (I,K)=C2DZ (K) BLOKINIT.190
ENDDO ! Over I BLOKINIT.197
ENDDO ! Over K BLOKINIT.198
IF (.NOT.L_ORICHARD) THEN ORH1F305.3816
DO K=1,KM ORH1F305.3817
DO I=1,IMT ORH1F305.3818
EEHQ (I,K)=EEH (K) ORH1F305.3819
EEMQ (I,K)=EEM (K) ORH1F305.3820
FFHQ (I,K)=FFH (K) ORH1F305.3821
FFMQ (I,K)=FFM (K) ORH1F305.3822
ENDDO ! over I ORH1F305.3823
ENDDO ! over K ORH1F305.3824
ENDIF ORH1F305.3825
C BLOKINIT.199
C BLOKINIT.200
EKTOT=0.0 BLOKINIT.201
co2_tot = 0.0 BLOKINIT.203
BUOY=0.0 ORH6F404.762
C BLOKINIT.205
DO M=1,NT BLOKINIT.206
DTABS(M)=0.0 ORH6F404.763
TVAR(M)=0.0 ORH6F404.764
DO LL=1,6 ORH6F404.765
TTDTOT(LL,M)=0.0 ORH6F404.766
ENDDO ! Over LL ORH6F404.767
ENDDO ! Over M BLOKINIT.209
C BLOKINIT.210
DO LL=1,8 ORH6F404.768
ENGINT(LL)=0.0 ORH6F404.769
IF (NERGY.EQ.1) THEN ORH6F404.770
DO J=J_FROM_LOC,J_TO_LOC ORH6F404.771
DO I=1,IMT ORH6F404.772
ZUENG(I,LL,J)=0.0 ORH6F404.773
ZVENG(I,LL,J)=0.0 ORH6F404.774
ENDDO ! Over I ORH6F404.775
ENDDO ! Over J ORH6F404.776
ENDIF ORH6F404.777
ENDDO ! Over LL ORH6F404.778
C BLOKINIT.214
ORH6F404.779
IF(NERGY.EQ.1) THEN ORH6F404.780
DO J=J_FROM_LOC,J_TO_LOC ORH6F404.781
IF (.NOT.L_OHMEAD) THEN ORH6F404.782
DO M=1,NTMIN2 ORH6F404.783
DO LL=1,8 ORH6F404.784
TTN(LL,J,M)=0.0 ORH6F404.785
ENDDO ! Over LL ORH6F404.786
ENDDO ! Over M ORH6F404.787
ENDIF ORH6F404.788
C BLOKINIT.226
DO K=1,KM ORH6F404.789
TMT(J,K)=0.0 ORH6F404.790
ENDDO ! Over K ORH6F404.791
ENDDO ! Over J ORH6F404.792
ENDIF BLOKINIT.246
C BLOKINIT.247
C--------------------------------------------------------------------- BLOKINIT.248
C INITIALISE CERTAIN VARIABLES TO ZERO EVERY TIMESTEP BLOKINIT.249
C TO AVOID AN "UNINITIALISED VARIABLE" TYPE OF ERROR BLOKINIT.250
C LATER WHERE, FOR PURPOSES OF VECTORISATION, BLOKINIT.251
C THE COMPUTATION PROCEEDS ACROSS LAND POINTS BLOKINIT.252
C--------------------------------------------------------------------- BLOKINIT.253
C BLOKINIT.254
C BLOKINIT.255
DO I=1,IMT BLOKINIT.256
UUNDER(I)=0.0 BLOKINIT.257
VUNDER(I)=0.0 BLOKINIT.258
ENDDO ! Over I BLOKINIT.259
C BLOKINIT.260
! Initialisation of ZTD could take place prior to calling ORH9F402.89
! this subroutine. However, the thinking behind doing it here ORH9F402.90
! is to try to make the most of parallelism when the code ORH9F402.91
! is autotasked, so that only part of the array is dealt ORH9F402.92
! with by each processor. ORH9F402.93
C BLOKINIT.263
IF ((.NOT.L_ONOCLIN).AND.(.NOT.L_OFREESFC)) THEN ORL1F404.775
DO J=J_FROM_LOC,J_TO_LOC ORH9F402.94
DO I=1,IMT ORH9F402.95
ZTD(I,J)=0.0 ORH9F402.96
ENDDO ORH9F402.97
ENDDO ORH9F402.98
ORH9F402.99
ENDIF ORH1F305.3829
C BLOKINIT.271
IF (L_OVISBECK) THEN OLA2F403.251
c Initialise tmin1 OLA2F403.252
DO J=J_FROM_LOC,J_TO_LOC OLA2F403.253
DO I=1,IMT OLA2F403.254
tmin1(i,j)=0.0 OLA2F403.255
ENDDO OLA2F403.256
ENDDO OLA2F403.257
ENDIF OLA2F403.258
C BLOKINIT.272
DO M=1,NT BLOKINIT.273
DO K=1,KMP2 BLOKINIT.274
DO I=1,IMT BLOKINIT.275
TDIF(I,K,M)=0.0 BLOKINIT.276
ENDDO ! Over I BLOKINIT.277
ENDDO ! Over K BLOKINIT.278
ENDDO ! Over M BLOKINIT.279
IF (L_OVARYT) THEN ORH1F305.3830
C BLOKINIT.281
C------------------------------------------------------------- BLOKINIT.282
C Set variable timestep with depth BLOKINIT.283
C------------------------------------------------------------- BLOKINIT.284
C BLOKINIT.285
DO K=1,KM ORH6F404.793
DTTSA(K)=C2DTTS*RAT(K) ORH6F404.794
ENDDO ! Over K ORH6F404.795
ENDIF ORH1F305.3831
C BLOKINIT.290
C======================================================================= BLOKINIT.291
C BEGIN A BOOTSTRAP PROCEDURE TO PREPARE FOR THE ===================== BLOKINIT.292
C ROW-BY-ROW COMPUTATION OF PROGNOSTIC VARIABLES ===================== BLOKINIT.293
C======================================================================= BLOKINIT.294
C BLOKINIT.295
C--------------------------------------------------------------------- BLOKINIT.296
C READ SLAB DATA FOR ROW JREAD FROM DUMP BLOKINIT.297
C--------------------------------------------------------------------- BLOKINIT.298
C BLOKINIT.299
CALL UMREAD( BLOKINIT.300
*CALL ARGSIZE BLOKINIT.301
*CALL ARGD1 BLOKINIT.302
*CALL ARGDUMO BLOKINIT.303
*CALL ARGPTRO BLOKINIT.304
& LABS(NDISKB),JREAD,TBP BLOKINIT.305
&, NDISKB,NDISK,NDISKA,FKMP,FKMQ ) OSI0F402.133
CALL UMREAD( BLOKINIT.307
*CALL ARGSIZE BLOKINIT.308
*CALL ARGD1 BLOKINIT.309
*CALL ARGDUMO BLOKINIT.310
*CALL ARGPTRO BLOKINIT.311
& LABS(NDISK),JREAD,TP BLOKINIT.312
&, NDISKB,NDISK,NDISKA,FKMP,FKMQ ) OSI0F402.134
IF (L_OBIMOM.or.L_OBIHARMGM) then OOM3F405.306
C Read slab data for row JREAD+1 from dump if biharmonic OOM3F405.307
CALL UMREAD( OOM3F405.308
*CALL ARGSIZE OOM3F405.309
*CALL ARGD1 OOM3F405.310
*CALL ARGDUMO OOM3F405.311
*CALL ARGPTRO OOM3F405.312
& LABS(NDISKB),JREAD+1,TBPP ! read j=3, t-1 timestep OOM3F405.313
&, NDISKB,NDISK,NDISKA,FKMP,FKMQ ) OOM3F405.314
C OOM3F405.315
CALL UMREAD( OOM3F405.316
*CALL ARGSIZE OOM3F405.317
*CALL ARGD1 OOM3F405.318
*CALL ARGDUMO OOM3F405.319
*CALL ARGPTRO OOM3F405.320
& LABS(NDISK),JREAD+1,TPP ! read j=3, t timestep OOM3F405.321
&, NDISKB,NDISK,NDISKA,FKMP,FKMQ ) OOM3F405.322
C OOM3F405.323
ENDIF ! L_OBIMOM or L_OBIHARMGM OOM3F405.324
OOM3F405.325
C BLOKINIT.314
C set up the advective velocities for the new Med outflow scheme OOM2F405.141
C need to add the extra velocity into U here, as well as UP, since OOM2F405.142
C we might be initialising a block boundary OOM2F405.143
OOM2F405.144
IF (L_OMEDADV) THEN OOM2F405.145
top_flow=med_topflow OOM2F405.146
CALL OUTFL_BC(JREAD,J_OFFSET,imout,jmout, OOM2F405.147
& U,UB,UP,UBP,med_in,med_out,lev_med,top_flow,imt,km, OOM2F405.148
& L_OTIMER,L_OBIMOM,L_OBIHARMGM,UPP,UBPP) OOM2F405.149
OOM2F405.150
IF (L_OHUDOUT) THEN OOM2F405.151
top_flow=lev_hud-1 OOM2F405.152
CALL OUTFL_BC(JREAD,J_OFFSET,imout_hud,jmout_hud, OOM2F405.153
& U,UB,UP,UBP,hud_in,hud_out,lev_hud,top_flow,imt,km, OOM2F405.154
& L_OTIMER,L_OBIMOM,L_OBIHARMGM,UPP,UBPP) OOM2F405.155
ENDIF OOM2F405.156
OOM2F405.157
ENDIF ! L_OMEDADV OOM2F405.158
OOM2F405.159
C--------------------------------------------------------------------- BLOKINIT.315
C READ IN MAXIMUM LEVEL INDICATORS FOR ROW JREAD DIRECTLY FROM ARRAYS BLOKINIT.316
C EQUIVALENCED TO OFLDS LOCATIONS AND CONVERT TO INTEGER BLOKINIT.317
C--------------------------------------------------------------------- BLOKINIT.318
C BLOKINIT.319
DO I=1,IMT BLOKINIT.320
KMT (I)=FKMP(I,JREAD - 1) ORH6F404.796
KMU (I)=FKMQ(I,JREAD - 1) ORH6F404.797
KMTP(I)=FKMP(I,JREAD) ORH6F404.798
KMUP(I)=FKMQ(I,JREAD) ORH6F404.799
KMTPP(I)=FKMP(I,JREAD+1) ORH6F404.800
ENDDO ! Over I BLOKINIT.323
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.326
C define the j+2 no of levels at each point OOM3F405.327
DO I=1,IMT OOM3F405.328
KMUPP(I)=FKMQ(I,JREAD+1) OOM3F405.329
ENDDO ! Over I OOM3F405.330
ENDIF OOM3F405.331
C BLOKINIT.324
C--------------------------------------------------------------------- BLOKINIT.325
C MOVE TAU-1 DATA TO TAU LEVEL ON A MIXING TIMESTEP BLOKINIT.326
C--------------------------------------------------------------------- BLOKINIT.327
C BLOKINIT.328
IF(MIX.EQ.1) THEN BLOKINIT.329
DO M=1,NT ORH6F404.801
DO K=1,KM ORH6F404.802
DO I=1,IMT ORH6F404.803
TBP(I,K,M)=TP(I,K,M) ORH6F404.804
ENDDO ! Over I ORH6F404.805
ENDDO ! Over K ORH6F404.806
ENDDO ! Over M ORH6F404.807
C copy data in tpp to tbpp etc on mixing timestep OOM3F405.332
IF (L_OBIMOM.or.L_OBIHARMGM) then OOM3F405.333
DO M=1,NT OOM3F405.334
DO K=1,KM OOM3F405.335
DO I=1,IMT OOM3F405.336
TBPP(I,K,M)=TPP(I,K,M) OOM3F405.337
ENDDO OOM3F405.338
ENDDO OOM3F405.339
ENDDO OOM3F405.340
ENDIF ! L_OBIMOM or L_OBIHARMGM OOM3F405.341
DO K=1,KM ORH6F404.808
DO I=1,IMT ORH6F404.809
UBP(I,K)=UP(I,K) ORH6F404.810
VBP(I,K)=VP(I,K) ORH6F404.811
ENDDO ! Over I ORH6F404.812
ENDDO ! Over K ORH6F404.813
IF (L_OBIMOM.or.L_OBIHARMGM) then OOM3F405.342
DO K=1,KM OOM3F405.343
DO I=1,IMT OOM3F405.344
UBPP(I,K)=UPP(I,K) OOM3F405.345
VBPP(I,K)=VPP(I,K) OOM3F405.346
ENDDO OOM3F405.347
ENDDO OOM3F405.348
ENDIF ! L_OBIMOM or L_OBIHARMGM OOM3F405.349
C BLOKINIT.343
C--------------------------------------------------------------------- BLOKINIT.344
C We must also mix other tracer rows as appropriate BLOKINIT.345
C--------------------------------------------------------------------- BLOKINIT.346
C BLOKINIT.347
DO M=1,NT ORH6F404.815
DO K=1,KM ORH6F404.816
DO I=1,IMT ORH6F404.817
TB (I,K,M)=T (I,K,M) ORH6F404.818
TBM(I,K,M)=TM(I,K,M) ORH6F404.819
ENDDO ! Over I ORH6F404.820
ENDDO ! Over K ORH6F404.821
ENDDO ! Over M ORH6F404.822
DO K=1,KM ORH6F404.823
DO I=1,IMT ORH6F404.824
UB (I,K)=U (I,K) ORH6F404.825
VB (I,K)=V (I,K) ORH6F404.826
UBM(I,K)=UM(I,K) ORH6F404.827
VBM(I,K)=VM(I,K) ORH6F404.828
ENDDO ! Over I ORH6F404.829
ENDDO ! Over K ORH6F404.830
ENDIF ! If a mixing timestep BLOKINIT.366
C BLOKINIT.367
C--------------------------------------------------------------------- BLOKINIT.368
C INITIALIZE ARRAYS FOR FIRST CALLS TO CLINIC AND TRACER BLOKINIT.369
C--------------------------------------------------------------------- BLOKINIT.370
C BLOKINIT.371
IF (JST.EQ.1) THEN ! This is the first block of rows BLOKINIT.372
!===================================================================== ORH0F401.4
! ORH0F401.5
! If this is the first block of rows, the main loop of ROWCALC ORH0F401.6
! runs from J = 2. However, this loop in ROWCALC needs values of ORH0F401.7
! TB and T for J = 1. (These values will be zero) - assign them here. ORH0F401.8
! ORH0F401.9
!===================================================================== ORH0F401.10
ORH0F401.11
IF( .NOT. L_OBDY_TRACER .OR. .NOT. L_OBDY_SOUTH) THEN OSI1F405.100
DO M=1,NT ORH0F401.12
DO K=1,KM ORH0F401.13
DO I=1,IMT ORH0F401.14
T (I,K,M)=0.0 ORH0F401.15
TB (I,K,M)=0.0 ORH0F401.16
ENDDO ! Over I ORH0F401.17
ENDDO ! Over K ORH0F401.18
ENDDO ! Over M ORH0F401.19
END IF OSI1F405.101
IF( .NOT. L_OBDY_UV ) THEN OSI1F405.102
DO K=1,KM ORH0F401.20
DO I=1,IMT ORH0F401.21
U (I,K) = 0.0 ORH0F401.22
V (I,K) = 0.0 ORH0F401.23
UB(I,K) = 0.0 ORH0F401.24
VB(I,K) = 0.0 ORH0F401.25
ENDDO ! Over I ORH0F401.26
ENDDO ! Over K ORH0F401.27
END IF OSI1F405.103
DO M=1,NT OSY1F405.23
DO K=1,KM OSY1F405.24
DO I=1,IMT OSY1F405.25
FLUXST(I,K,M)=0. OSY1F405.26
ENDDO OSY1F405.27
ENDDO OSY1F405.28
ENDDO OSY1F405.29
OSY1F405.30
C BLOKINIT.373
IF (L_OBIMOM.or.L_OBIHARMGM) then OOM3F405.350
C initialise d2v,d2u OOM3F405.351
DO K=1,KM OOM3F405.352
DO I=1,IMT OOM3F405.353
D2U(I,K,1)=0.0 OOM3F405.354
D2V(I,K,1)=0.0 OOM3F405.355
D2U(I,K,2)=0.0 OOM3F405.356
D2V(I,K,2)=0.0 OOM3F405.357
ENDDO OOM3F405.358
ENDDO OOM3F405.359
ENDIF ! L_OBIMOM or L_OBIHARMGM OOM3F405.360
OOM3F405.361
IF ( L_OBDY_SOUTH .AND. L_OGILL_LBCS ) THEN OSI1F405.116
C BLOKINIT.375
C "Row 1" velocities are set equal to Row 2 velocities BLOKINIT.376
C in the initialization of the arrays for the 1st calls to BLOKINIT.377
C CLINIC and TRACER. BLOKINIT.378
C BLOKINIT.379
DO K=1,KM ORH6F404.833
DO I=1,IMT ORH6F404.834
U(I,K)=UP(I,K) ORH6F404.835
V(I,K)=VP(I,K) ORH6F404.836
UB(I,K)=UBP(I,K) ORH6F404.837
VB(I,K)=VBP(I,K) ORH6F404.838
ENDDO ! Over I ORH6F404.839
ENDDO ! Over K ORH6F404.840
ENDIF ORH6F404.841
ORH6F404.842
FX=DYU2R(JREAD)*CSR(JREAD)*CST(JREAD)*0.5 ORH6F404.843
ORH6F404.844
DO K=1,KM ORH6F404.845
DO I=1,IMT ORH6F404.846
FVST(I,K)=0.0 ORH6F404.847
RHOS(I,K)=0.0 ORH6F404.848
FMM (I,K)=0.0 ORH6F404.849
FM (I,K)=0.0 ORH6F404.850
C--------------------------------------------------------------------- BLOKINIT.400
C CONSTRUCT MASK ARRAY FOR ROW JREAD TRACERS BLOKINIT.401
C--------------------------------------------------------------------- BLOKINIT.402
IF(KMTP(I).GE.KAR(K)) THEN ORH6F404.851
FMP(I,K)=1.0 ORH6F404.852
ELSE ORH6F404.853
FMP(I,K)=0.0 ORH6F404.854
ENDIF ORH6F404.855
C--------------------------------------------------------------------- BLOKINIT.415
C SAVE INTERNAL MODE VELOCITIES FOR ROW JREAD AND COMPUTE BLOKINIT.416
C ADVECTIVE COEFFICIENT FOR SOUTH FACE OF ROW JREAD U,V BOXES BLOKINIT.417
C--------------------------------------------------------------------- BLOKINIT.418
UCLIN(I,K)=UP(I,K) BLOKINIT.424
VCLIN(I,K)=VP(I,K) BLOKINIT.425
FVSU(I,K)=(VP(I,K)+V(I,K))*FX BLOKINIT.426
ENDDO ! Over I BLOKINIT.427
ENDDO ! Over K ORH6F404.856
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.362
DO K=1,KM OOM3F405.363
DO I=1,IMT OOM3F405.364
IF (KMTPP(I).GE.KAR(K)) THEN OOM3F405.365
FMPP(I,K)=1.0 OOM3F405.366
ELSE OOM3F405.367
FMPP(I,K)=0.0 OOM3F405.368
ENDIF OOM3F405.369
ENDDO OOM3F405.370
ENDDO OOM3F405.371
C Save external mode velocities for row JREAD+1 OOM3F405.372
DO K=1,KM OOM3F405.373
DO I=1,IMT OOM3F405.374
UCLINP(I,K)=UPP(I,K) OOM3F405.375
VCLINP(I,K)=VPP(I,K) OOM3F405.376
ENDDO OOM3F405.377
ENDDO OOM3F405.378
ENDIF ! L_OBIMOM.or.L_OBIHARMGM OOM3F405.379
OOM3F405.380
C OSI1F405.104
C Set FM land / sea mask for row 2 if southern row is an open OSI1F405.105
C boundary. Mask for row 1 is assumed to be the same as row 1. OSI1F405.106
C OSI1F405.107
IF ( L_OBDY_TRACER .AND. L_OBDY_SOUTH) THEN OSI1F405.108
DO K=1,KM OSI1F405.109
DO I=1,IMT OSI1F405.110
FM(I,K) = FMP(I,K) OSI1F405.111
ENDDO ! Over I OSI1F405.112
ENDDO ! Over K OSI1F405.113
END IF ! L_OBDY_ conditions OSI1F405.114
OSI1F405.115
C BLOKINIT.429
ELSE ! This is not the first block of rows BLOKINIT.430
C BLOKINIT.431
C--------------------------------------------------------------------- BLOKINIT.432
C Set up values for FMP and FM for 1st row in this block BLOKINIT.433
C also FMM required for use in calculation of ry BLOKINIT.434
C--------------------------------------------------------------------- BLOKINIT.435
C BLOKINIT.436
DO K=1,KM ORH6F404.857
DO I=1,IMT ORH6F404.858
! JREAD - 2 is outside the range of the halos ORH6F404.859
! so we refer to a full global copy of this array ORH6F404.860
IF (FKMP_GLOBAL(I,JREAD-2+J_OFFSET).GE.KAR(K)) THEN ORH6F404.861
FMM(I,K) = 1.0 ORH6F404.862
ELSE ORH6F404.863
FMM(I,K) = 0.0 ORH6F404.864
ENDIF ORH6F404.865
C BLOKINIT.444
IF (FKMP(I,JREAD-1).GE.KAR(K)) THEN ORH6F404.866
FM(I,K) = 1.0 ORH6F404.867
ELSE ORH6F404.868
FM(I,K) = 0.0 ORH6F404.869
ENDIF ORH6F404.870
C BLOKINIT.450
IF (FKMP(I,JREAD).GE.KAR(K)) THEN ORH6F404.871
FMP(I,K) = 1.0 ORH6F404.872
ELSE ORH6F404.873
FMP(I,K) = 0.0 ORH6F404.874
ENDIF ORH6F404.875
ENDDO ! Over I ORH6F404.876
ENDDO ! Over K ORH6F404.877
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.381
DO K=1,KM OOM3F405.382
DO I=1,IMT OOM3F405.383
IF (FKMP(I,JREAD+1).GE.KAR(K)) THEN OOM3F405.384
FMPP(I,K)=1.0 OOM3F405.385
ELSE OOM3F405.386
FMPP(I,K)=0.0 OOM3F405.387
ENDIF OOM3F405.388
ENDDO OOM3F405.389
ENDDO OOM3F405.390
C Save external mode velocities for row JREAD+1 OOM3F405.391
DO K=1,KM OOM3F405.392
DO I=1,IMT OOM3F405.393
UCLINP(I,K)=UPP(I,K) OOM3F405.394
VCLINP(I,K)=VPP(I,K) OOM3F405.395
ENDDO OOM3F405.396
ENDDO OOM3F405.397
ENDIF ! L_OBIMOM.or.L_OBIHARMGM OOM3F405.398
OOM3F405.399
C BLOKINIT.464
C--------------------------------------------------------------------- BLOKINIT.465
C SAVE INTERNAL MODE VELOCITIES FOR ROW JREAD BLOKINIT.466
C AND COMPUTE ADVECTIVE COEFFICIENT FOR SOUTH FACE OF ROW 2 U,V BOXES BLOKINIT.467
C--------------------------------------------------------------------- BLOKINIT.468
C BLOKINIT.469
DO K=1,KM ORH6F404.878
DO I=1,IMT ORH6F404.879
UCLIN(I,K)=UP(I,K) ORH6F404.880
VCLIN(I,K)=VP(I,K) ORH6F404.881
ENDDO ! Over I ORH6F404.882
ENDDO ! Over K ORH6F404.883
C BLOKINIT.476
C BLOKINIT.477
IF (JST.EQ.JMTM1_GLOBAL) THEN ORH6F404.884
! If our 1st row is the last but one model row ORH6F404.885
! then clinic will not get called unless L_OSYMM ORH6F404.886
! is true. However, ROWCALC needs a value for USAV ORH6F404.887
! and VSAV for row JMTM1_GLOBAL which is the same ORH6F404.888
! value as used for row JMTM1_GLOBAL - 1 ie: ORH6F404.889
DO K=1,KM ORH6F404.890
DO I = 1, IMT ORH6F404.891
USAV(I,K)=UP(I,K) ORH6F404.892
VSAV(I,K)=VP(I,K) ORH6F404.893
ENDDO ORH6F404.894
ENDDO ORH6F404.895
ENDIF ORH6F404.896
C--------------------------------------------------------------------- BLOKINIT.478
C COMPUTE FVSU FOR ROW JREAD - 1. BLOKINIT.479
C--------------------------------------------------------------------- BLOKINIT.480
C BLOKINIT.481
CALL CALCFVN( ORH6F404.897
*CALL ARGSIZE BLOKINIT.483
*CALL ARGD1 BLOKINIT.484
*CALL ARGDUMO BLOKINIT.485
*CALL ARGPTRO BLOKINIT.486
*CALL ARGOCALL BLOKINIT.487
*CALL COCAROWS BLOKINIT.488
& ,JREAD-1 BLOKINIT.489
& ,LL_ASS_BTRP,DV_ASS_BTRP BLOKINIT.491
& ,KMUP,KMU ORL1F404.1019
& ,FVSU,VP,V BLOKINIT.493
&,JMT_GLOBAL ORH6F402.85
& ) BLOKINIT.494
ORH6F404.898
ENDIF BLOKINIT.495
ORH6F404.899
*IF DEF,MPP ORH9F402.100
IF (JST.EQ.1) THEN ORH9F402.101
J = J_1 ORH9F402.102
ELSE ORH9F402.103
J = J_1 -1 ORH9F402.104
ENDIF ORH9F402.105
*ELSE ORH9F402.106
IF (JST.EQ.1) THEN BLOKINIT.517
J=1 BLOKINIT.518
ELSE BLOKINIT.519
J=JST-1 BLOKINIT.520
ENDIF BLOKINIT.521
*ENDIF ORH9F402.107
C BLOKINIT.522
IF (.NOT.L_ONOCLIN) THEN ORH1F305.3836
ORL1F404.776
IF (L_OFREESFC) THEN ORL1F404.777
DO I=1,IMTM1 ORL1F404.778
SFUB(I) = UBTBBC(I,J+1)*HR(I,J+1) ORL1F404.779
SFVB(I) = VBTBBC(I,J+1)*HR(I,J+1) ORL1F404.780
ENDDO ! over i ORL1F404.781
ORL1F404.782
ELSE ORL1F404.783
ORL1F404.784
DO I=1,IMTM1 ORH6F404.900
DIAG1=PB(I+1,J+2)-PB(I ,J+1) ORH6F404.901
DIAG2=PB(I ,J+2)-PB(I+1,J+1) ORH6F404.902
SFUB(I)=-(DIAG1+DIAG2)*DYU2R(J+1)*HR(I,J+1) ORH6F404.903
SFVB(I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+1)*CSR(J+1) ORH6F404.904
ENDDO ! Over I ORH6F404.905
ORL1F404.785
ENDIF ! (L_OFREESFC) ORL1F404.786
ORL1F404.787
C BLOKINIT.530
C 2ND, COMPUTE FOR TAU TIME LEVEL BLOKINIT.531
C BLOKINIT.532
IF (L_OFREESFC) THEN ORH6F404.906
DO I=1,IMTM1 ORH6F404.907
SFU(I) = UBT(I,J+1)*HR(I,J+1) ORH6F404.908
SFV(I) = VBT(I,J+1)*HR(I,J+1) ORH6F404.909
ENDDO ORH6F404.910
ELSE ORH6F404.911
DO I=1,IMTM1 ORH6F404.912
DIAG1=P (I+1,J+2)-P (I ,J+1) ORH6F404.913
DIAG2=P (I ,J+2)-P (I+1,J+1) ORH6F404.914
SFU (I)=-(DIAG1+DIAG2)*DYU2R(J+1)*HR(I,J+1) ORH6F404.915
SFV (I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+1)*CSR(J+1) ORH6F404.916
ENDDO ! Over I ORH6F404.917
ENDIF ORH6F404.918
IF (L_OCYCLIC) THEN ORH6F404.919
C BLOKINIT.541
C 3RD, SET CYCLIC BOUNDARY CONDITIONS BLOKINIT.542
C BLOKINIT.543
SFUB(IMT)=SFUB(2) ORH6F404.920
SFVB(IMT)=SFVB(2) ORH6F404.921
SFU (IMT)=SFU (2) ORH6F404.922
SFV (IMT)=SFV (2) ORH6F404.923
ELSE ORH6F404.924
SFUB(IMT)=0.0 ORH6F404.925
SFVB(IMT)=0.0 ORH6F404.926
SFU (IMT)=0.0 ORH6F404.927
SFV (IMT)=0.0 ORH6F404.928
ENDIF ORH6F404.929
C BLOKINIT.556
C----------------------------------------------------------------------- BLOKINIT.557
C SAVE EXTERNAL MODE FOR USE IN TIME FILTER BLOKINIT.558
C----------------------------------------------------------------------- BLOKINIT.559
C BLOKINIT.560
DO I=1,IMT ORH6F404.930
SSFUBP(I)=SFUB(I) ORH6F404.931
SSFVBP(I)=SFVB(I) ORH6F404.932
ENDDO ! Over I ORH6F404.933
C BLOKINIT.565
C--------------------------------------------------------------------- BLOKINIT.566
C ADD EXTERNAL MODE TO INTERNAL MODE FOR ROW JREAD (OCEAN PTS. ONLY) BLOKINIT.567
C--------------------------------------------------------------------- BLOKINIT.568
C BLOKINIT.569
DO K=1,KM ORH6F404.934
DO I=1,IMU ORH6F404.935
IF (KMUP(I).GE.KAR(K)) THEN ORH6F404.936
UBP(I,K)=UBP(I,K)+SFUB(I) ORH6F404.937
VBP(I,K)=VBP(I,K)+SFVB(I) ORH6F404.938
UP (I,K)=UP (I,K)+SFU (I) ORH6F404.939
VP (I,K)=VP (I,K)+SFV (I) ORH6F404.940
ENDIF ORH6F404.941
ENDDO ! Over I ORH6F404.942
ENDDO ! Over K ORH6F404.943
C Add ext. mode to int. mode for row J+2 (OCEAN PTS. ONLY) OOM3F405.400
OOM3F405.401
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.402
C calculate the external mode for j+2 OOM3F405.403
C does this assume at least two rows per PE? OOM3F405.404
DO I=1,IMTM1 OOM3F405.405
DIAG1=PB(I+1,J+3)-PB(I ,J+2) OOM3F405.406
DIAG2=PB(I ,J+3)-PB(I+1,J+2) OOM3F405.407
SFUB(I)=-(DIAG1+DIAG2)*DYU2R(J+2)*HR(I,J+2) OOM3F405.408
SFVB(I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+2)*CSR(J+2) OOM3F405.409
ENDDO ! Over I OOM3F405.410
C OOM3F405.411
C 2ND, COMPUTE FOR TAU TIME LEVEL OOM3F405.412
C OOM3F405.413
DO I=1,IMTM1 OOM3F405.414
DIAG1=P (I+1,J+3)-P (I ,J+2) OOM3F405.415
DIAG2=P (I ,J+3)-P (I+1,J+2) OOM3F405.416
SFU (I)=-(DIAG1+DIAG2)*DYU2R(J+2)*HR(I,J+2) OOM3F405.417
SFV (I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+2)*CSR(J+2) OOM3F405.418
ENDDO ! Over I OOM3F405.419
OOM3F405.420
IF (L_OCYCLIC) THEN OOM3F405.421
C OOM3F405.422
C 3RD, SET CYCLIC BOUNDARY CONDITIONS OOM3F405.423
C OOM3F405.424
SFUB(IMT)=SFUB(2) OOM3F405.425
SFVB(IMT)=SFVB(2) OOM3F405.426
SFU (IMT)=SFU (2) OOM3F405.427
SFV (IMT)=SFV (2) OOM3F405.428
ELSE OOM3F405.429
SFUB(IMT)=0.0 OOM3F405.430
SFVB(IMT)=0.0 OOM3F405.431
SFU (IMT)=0.0 OOM3F405.432
SFV (IMT)=0.0 OOM3F405.433
ENDIF OOM3F405.434
C------------------------------------------------------------------- OOM3F405.435
C SAVE EXTERNAL MODE FOR USE IN TIME FILTER OOM3F405.436
C-------------------------------------------------------------------- OOM3F405.437
C OOM3F405.438
DO I=1,IMT OOM3F405.439
SSFUBPP(I)=SFUB(I) OOM3F405.440
SSFVBPP(I)=SFVB(I) OOM3F405.441
ENDDO ! Over I OOM3F405.442
C OOM3F405.443
C OOM3F405.444
DO K=1,KM OOM3F405.445
DO I=1,IMU OOM3F405.446
IF (KMUPP(I).GE.KAR(K)) THEN OOM3F405.447
UBPP(I,K)=UBPP(I,K)+SFUB(I) OOM3F405.448
VBPP(I,K)=VBPP(I,K)+SFVB(I) OOM3F405.449
UPP (I,K)=UPP (I,K)+SFU (I) OOM3F405.450
VPP (I,K)=VPP (I,K)+SFV (I) OOM3F405.451
ENDIF OOM3F405.452
ENDDO OOM3F405.453
ENDDO OOM3F405.454
OOM3F405.455
ENDIF ! L_OBIMOM.or.L_OBIHARMGM OOM3F405.456
OOM3F405.457
IF (L_OBIMOM) THEN OOM3F405.458
OOM3F405.459
IF (JST.EQ.1) THEN OOM3F405.460
OOM3F405.461
C--------------------------------------------------------------- OOM3F405.462
C COMPUTE LAPLACIANS FOR ROW j+1 with jst=1 OOM3F405.463
C--------------------------------------------------------------- OOM3F405.464
C OOM3F405.465
DO K=1,KM OOM3F405.466
DO I=1,IMT OOM3F405.467
D2U(I,K,2)=0. OOM3F405.468
D2V(I,K,2)=0. OOM3F405.469
ENDDO OOM3F405.470
ENDDO OOM3F405.471
OOM3F405.472
BBUD=8.0*(CSR(J+1)*CSR(J+1)) OOM3F405.473
CCUD=(CST(J+2)*DYTR(J+2))*(DYUR(J+1)*CSR(J+1)) OOM3F405.474
DDUD=(CST(J+1)*DYTR(J+1))*(DYUR(J+1)*CSR(J+1)) OOM3F405.475
GGUD=(1.0-(TNG(J+1)*TNG(J+1)))/(RADIUS*RADIUS) OOM3F405.476
HHUD=2.0*SINE(J+1)/(RADIUS*(CS(J+1)*CS(J+1))) OOM3F405.477
OOM3F405.478
DO K=1,KM OOM3F405.479
DO I=2,IMTM1 OOM3F405.480
D2U(I,K,3)=(BBUD*DXU2RQ(I,K))* OOM3F405.481
* (DXT4RQ(I,K)*((UBP(I+1,K)-UBP(I,K))+(UBP(I-1,K)-UBP(I,K)))) OOM3F405.482
D2U(I,K,3)=D2U(I,K,3)+CCUD*(UBPP(I,K)-UBP(I,K)) OOM3F405.483
* -DDUD*UBP(I,K) OOM3F405.484
D2U(I,K,3)=D2U(I,K,3)+GGUD*UBP(I,K) OOM3F405.485
* - (HHUD*DXU2RQ(I,K))*(VBP(I+1,K)-VBP(I-1,K)) OOM3F405.486
OOM3F405.487
D2V(I,K,3)=(BBUD*DXU2RQ(I,K))* OOM3F405.488
* (DXT4RQ(I,K)*((VBP(I+1,K)-VBP(I,K))+(VBP(I-1,K)-VBP(I,K)))) OOM3F405.489
D2V(I,K,3)=D2V(I,K,3)+CCUD*(VBPP(I,K)-VBP(I,K)) OOM3F405.490
* -DDUD*VBP(I,K) OOM3F405.491
D2V(I,K,3)=D2V(I,K,3)+GGUD*VBP(I,K) OOM3F405.492
* + (HHUD*DXU2RQ(I,K))*(UBP(I+1,K)-UBP(I-1,K)) OOM3F405.493
ENDDO OOM3F405.494
IF (L_OCYCLIC) THEN OOM3F405.495
C SET CYCLIC BOUNDARY CONDITIONS ON LAPLACIANS OOM3F405.496
D2U(1,K,3)=D2U(IMTM1,K,3) OOM3F405.497
D2U(IMT,K,3)=D2U(2,K,3) OOM3F405.498
D2V(1,K,3)=D2V(IMTM1,K,3) OOM3F405.499
D2V(IMT,K,3)=D2V(2,K,3) OOM3F405.500
ELSE OOM3F405.501
C extra b.c. for biharmonic OOM3F405.502
D2U(1,K,3)=0. OOM3F405.503
D2U(IMT,K,3)=0. OOM3F405.504
D2V(1,K,3)=0. OOM3F405.505
D2V(IMT,K,3)=0. OOM3F405.506
ENDIF OOM3F405.507
ENDDO OOM3F405.508
OOM3F405.509
ENDIF ! jst=1 OOM3F405.510
ENDIF ! L_OBIMOM OOM3F405.511
OOM3F405.512
ENDIF ORH1F305.3840
ORH6F404.944
IF (L_OCNASSM) THEN ORH1F305.3841
C BLOKINIT.582
C----------------------------------------------------------------------- BLOKINIT.583
C ADD DATA ASSIMILATION INCREMENTS FOR ROW JREAD BLOKINIT.584
C----------------------------------------------------------------------- BLOKINIT.585
C BLOKINIT.586
IF (LL_ASS_BTRP) THEN ORH6F404.945
DO K=1,KM ORH6F404.946
DO I=1,IMU ORH6F404.947
IF (KMUP(I).GE.KAR(K)) THEN ORH6F404.948
UP(I,K)=UP(I,K)+DU_ASS_BTRP(I,JREAD) ORH6F404.949
VP(I,K)=VP(I,K)+DV_ASS_BTRP(I,JREAD) ORH6F404.950
ENDIF ORH6F404.951
ENDDO ! Over I ORH6F404.952
ENDDO ! Over K ORH6F404.953
ENDIF ORH6F404.954
ENDIF ORH1F305.3842
C BLOKINIT.598
C--------------------------------------------------------------------- BLOKINIT.599
C ACCUMULATE KINETIC ENERGY FROM ROW 2 EVERY NTSI TIMESTEPS BLOKINIT.600
C--------------------------------------------------------------------- BLOKINIT.601
C BLOKINIT.602
IF (JST.EQ.1) THEN BLOKINIT.603
IF (MOD(ITT,NTSI).EQ.0) THEN BLOKINIT.605
DO K=1,KM ORH6F404.955
FX=0.5*CS(J+1)*DYU(J+1)*DZ(K) ORH6F404.956
DO I=2,IMUM1 ORH6F404.957
EKTOT=EKTOT+(UP(I,K)*UP(I,K)+VP(I,K)*VP(I,K))* ORH6F404.958
& FX*DXU(I) ORH6F404.959
ENDDO ! Over I ORH6F404.960
ENDDO ! Over K ORH6F404.961
ENDIF BLOKINIT.612
ENDIF BLOKINIT.614
C BLOKINIT.615
C--------------------------------------------------------------------- BLOKINIT.616
C COMPUTE DENSITY TO THE SOUTH OF ROW JST BLOKINIT.617
C--------------------------------------------------------------------- BLOKINIT.618
C BLOKINIT.619
CALL STATE(TP(1,1,1),TP(1,1,2),RHOS, BLOKINIT.621
& TDIF(1,1,1),TDIF(1,1,2),IMT,KM, BLOKINIT.622
& JREAD,JMT) ORH7F404.78
IF (L_OCYCLIC) THEN ORH1F305.3843
C BLOKINIT.629
C--------------------------------------------------------------------- ORH6F404.962
C SET CYCLIC BOUNDARY CONDITIONS ON DENSITY TO THE SOUTH OF ROW JST ORH6F404.963
C--------------------------------------------------------------------- ORH6F404.964
C BLOKINIT.631
DO K=1,KM ORH6F404.965
RHOS(IMT,K)=RHOS(2,K) ORH6F404.966
ENDDO ! Over K ORH6F404.967
ENDIF ORH1F305.3844
C BLOKINIT.636
C BLOKINIT.637
C If this is the first row of a block, we must ensure that BLOKINIT.638
C certain southern boundary values are available for the main BLOKINIT.639
C part of the computation. BLOKINIT.640
*IF DEF,MPP ORH9F402.157
C Pass between PEs values of WSX,WSY,WSX_LEADS,WSY_LEADS, ODC1F405.40
C ISX and ISY in the next row outside the halo for use in ODC1F405.41
C VERTCOFT (labelled WSXM etc) ODC1F405.42
IF (J_PE_JFINP1.GE.0) THEN ORH6F404.968
! We must send row J_JMT-1 ORH6F404.969
PE_RECV=J_PE_JFINP1 ORH6F404.970
CALL GC_RSEND(5004,IMT,PE_RECV,INFO,WSXM, ORH6F404.971
& D1(joc_taux+(J_JMT-2)*IMT)) ODC2F405.1
ENDIF ORH6F404.972
CALL GC_GSYNC(O_NPROC,INFO) ORH6F404.973
IF (J_PE_JSTM1.GE.0) THEN ORH6F404.974
! We're expecting to receive a message: ORH6F404.975
PE_SEND = J_PE_JSTM1 ORH6F404.976
CALL GC_RRECV(5004,IMT,PE_SEND,INFO,WSXM,D1) ORH6F404.977
ENDIF ORH6F404.978
CALL GC_GSYNC(O_NPROC,INFO) ORH6F404.979
IF (J_PE_JFINP1.GE.0) THEN ORH6F404.980
! We must send row J_JMT-1 ORH6F404.981
PE_RECV=J_PE_JFINP1 ORH6F404.982
CALL GC_RSEND(5005,IMT,PE_RECV,INFO,WSYM, ORH6F404.983
& D1(joc_tauy+(J_JMT-2)*IMT)) ODC2F405.2
ENDIF ORH6F404.984
CALL GC_GSYNC(O_NPROC,INFO) ORH6F404.985
IF (J_PE_JSTM1.GE.0) THEN ORH6F404.986
! We're expecting to receive a message: ORH6F404.987
PE_SEND = J_PE_JSTM1 ORH6F404.988
CALL GC_RRECV(5005,IMT,PE_SEND,INFO,WSYM,D1) ORH6F404.989
ENDIF ORH6F404.990
CALL GC_GSYNC(O_NPROC,INFO) ORH6F404.991
C Swap WSX ODC1F405.43
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.44
! We must send row J_JMT-1 ODC1F405.45
PE_RECV=J_PE_JFINP1 ODC1F405.46
CALL GC_RSEND(5004,IMT,PE_RECV,INFO,WSXM, ODC1F405.47
& D1(joc_taux+(J_JMT-1)*IMT)) ODC1F405.48
ENDIF ODC1F405.49
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.50
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.51
! We're expecting to receive a message: ODC1F405.52
PE_SEND = J_PE_JSTM1 ODC1F405.53
CALL GC_RRECV(5004,IMT,PE_SEND,INFO,WSXM,D1) ODC1F405.54
ENDIF ODC1F405.55
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.56
C Swap WSY ODC1F405.57
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.58
! We must send row J_JMT-1 ODC1F405.59
PE_RECV=J_PE_JFINP1 ODC1F405.60
CALL GC_RSEND(5005,IMT,PE_RECV,INFO,WSYM, ODC1F405.61
& D1(joc_tauy+(J_JMT-1)*IMT)) ODC1F405.62
ENDIF ODC1F405.63
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.64
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.65
! We're expecting to receive a message: ODC1F405.66
PE_SEND = J_PE_JSTM1 ODC1F405.67
CALL GC_RRECV(5005,IMT,PE_SEND,INFO,WSYM,D1) ODC1F405.68
ENDIF ODC1F405.69
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.70
ODC1F405.71
! Ice model related code only executed under suitable ODC1F405.72
! model configurations. ODC1F405.73
IF (L_ICEFREEDR) THEN ODC1F405.74
C Swap WSX_LEADS ODC1F405.75
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.76
! We must send row J_JMT-1 ODC1F405.77
PE_RECV=J_PE_JFINP1 ODC1F405.78
CALL GC_RSEND(5006,IMT,PE_RECV,INFO,WSX_LEADSM, ODC1F405.79
& WSX_LEADS(1,J_JMTM1)) ODC1F405.80
ENDIF ODC1F405.81
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.82
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.83
! We're expecting to receive a message: ODC1F405.84
PE_SEND = J_PE_JSTM1 ODC1F405.85
CALL GC_RRECV(5006,IMT,PE_SEND,INFO,WSX_LEADSM,WSX_LEADS) ODC1F405.86
ENDIF ODC1F405.87
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.88
C Swap WSY_LEADS ODC1F405.89
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.90
! We must send row J_JMT-1 ODC1F405.91
PE_RECV=J_PE_JFINP1 ODC1F405.92
CALL GC_RSEND(5007,IMT,PE_RECV,INFO,WSY_LEADSM, ODC1F405.93
& WSY_LEADS(1,J_JMTM1)) ODC1F405.94
ENDIF ODC1F405.95
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.96
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.97
! We're expecting to receive a message: ODC1F405.98
PE_SEND = J_PE_JSTM1 ODC1F405.99
CALL GC_RRECV(5007,IMT,PE_SEND,INFO,WSY_LEADSM,WSY_LEADS) ODC1F405.100
ENDIF ODC1F405.101
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.102
C Swap ISX ODC1F405.103
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.104
! We must send row J_JMT-1 ODC1F405.105
PE_RECV=J_PE_JFINP1 ODC1F405.106
CALL GC_RSEND(5008,IMT,PE_RECV,INFO,ISXM, ODC1F405.107
& ISX(1,J_JMTM1)) ODC1F405.108
ENDIF ODC1F405.109
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.110
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.111
! We're expecting to receive a message: ODC1F405.112
PE_SEND = J_PE_JSTM1 ODC1F405.113
CALL GC_RRECV(5008,IMT,PE_SEND,INFO,ISXM,ISX) ODC1F405.114
ENDIF ODC1F405.115
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.116
C Swap ISY ODC1F405.117
IF (J_PE_JFINP1.GE.0) THEN ODC1F405.118
! We must send row J_JMT-1 ODC1F405.119
PE_RECV=J_PE_JFINP1 ODC1F405.120
CALL GC_RSEND(5009,IMT,PE_RECV,INFO,ISYM, ODC1F405.121
& ISY(1,J_JMTM1)) ODC1F405.122
ENDIF ODC1F405.123
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.124
IF (J_PE_JSTM1.GE.0) THEN ODC1F405.125
! We're expecting to receive a message: ODC1F405.126
PE_SEND = J_PE_JSTM1 ODC1F405.127
CALL GC_RRECV(5009,IMT,PE_SEND,INFO,ISYM,ISY) ODC1F405.128
ENDIF ODC1F405.129
CALL GC_GSYNC(O_NPROC,INFO) ODC1F405.130
CALL SWAPBOUNDS(WSX_LEADS,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OLA0F404.20
CALL SWAPBOUNDS(WSY_LEADS,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OLA0F404.21
CALL SWAPBOUNDS(ISX,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OLA0F404.22
CALL SWAPBOUNDS(ISY,IMT,JMT,O_EW_HALO,O_NS_HALO,1) OLA0F404.23
ENDIF OLA0F404.24
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.513
C need to read in value for the streamfunction at row j+3 and pass it OOM3F405.514
C back to the row that requires it (to calculate UPP, need OOM3F405.515
C barotropic solution at UPPP). OOM3F405.516
OOM3F405.517
IF (J_PE_JSTM1.GE.0) THEN OOM3F405.518
c ! We must send row J_1+2 OOM3F405.519
PE_RECV=J_PE_JSTM1 OOM3F405.520
CALL GC_RSEND(5030,IMT,PE_RECV,INFO,PBJP,PB(1,J_1+2)) OOM3F405.521
ENDIF OOM3F405.522
OOM3F405.523
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.524
OOM3F405.525
IF (J_PE_JFINP1.GE.0) THEN OOM3F405.526
c ! We're expecting to receive a message: OOM3F405.527
PE_SEND = J_PE_JFINP1 OOM3F405.528
CALL GC_RRECV(5030,IMT,PE_SEND,INFO,PBJP,PB) OOM3F405.529
ENDIF OOM3F405.530
OOM3F405.531
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.532
OOM3F405.533
IF (J_PE_JSTM1.GE.0) THEN OOM3F405.534
c ! We must send row J_1+2 OOM3F405.535
PE_RECV=J_PE_JSTM1 OOM3F405.536
CALL GC_RSEND(5031,IMT,PE_RECV,INFO,PJP,P(1,J_1+2)) OOM3F405.537
ENDIF OOM3F405.538
OOM3F405.539
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.540
OOM3F405.541
IF (J_PE_JFINP1.GE.0) THEN OOM3F405.542
c ! We're expecting to receive a message: OOM3F405.543
PE_SEND = J_PE_JFINP1 OOM3F405.544
CALL GC_RRECV(5031,IMT,PE_SEND,INFO,PJP,P) OOM3F405.545
ENDIF OOM3F405.546
OOM3F405.547
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.548
OOM3F405.549
ENDIF ! L_OBIMOM.or.L_OBIHARMGM OOM3F405.550
OOM3F405.551
IF (L_OBIMOM.or.L_OBIHARMGM) THEN OOM3F405.552
OOM3F405.553
C Send value of FKMQ(J_1+1) back to previous PE, to be FKMQJP OOM3F405.554
IF (J_PE_JSTM1.GE.0) THEN OOM3F405.555
c ! We must send row J_1+1 OOM3F405.556
PE_RECV=J_PE_JSTM1 OOM3F405.557
CALL GC_RSEND(5032,IMT,PE_RECV,INFO,FKMQJP,FKMQ(1,J_1+1)) OOM3F405.558
ENDIF OOM3F405.559
OOM3F405.560
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.561
OOM3F405.562
IF (J_PE_JFINP1.GE.0) THEN OOM3F405.563
c ! We're expecting to receive a message: OOM3F405.564
PE_SEND = J_PE_JFINP1 OOM3F405.565
CALL GC_RRECV(5032,IMT,PE_SEND,INFO,FKMQJP,FKMQ) OOM3F405.566
ENDIF OOM3F405.567
OOM3F405.568
CALL GC_GSYNC(O_NPROC,INFO) OOM3F405.569
OOM3F405.570
ENDIF ! L_OBIMOM.or.L_OBIHARMGM OOM3F405.571
OOM3F405.572
ORL1F404.788
IF (L_OFREESFC) THEN ORL1F404.789
! The following variables are needed for initialisation ORL1F404.790
! purposes at block boundaries, but are outside the scope of ORL1F404.791
! our standard mpp halo. We therefore set up special variables ORL1F404.792
! to handle them. It's a bit of a drag in terms of shuffling ORL1F404.793
! more data around in argument lists, but it does ensure ORL1F404.794
! that the necessary communications (which is the main ORL1F404.795
! performance overhead) are only performed once per run. ORL1F404.796
ORL1F404.797
IF (J_PE_JFINP1.GE.0) THEN ORL1F404.798
! We must send row J_JMT-1 ORL1F404.799
PE_RECV=J_PE_JFINP1 ORL1F404.800
CALL GC_RSEND (5012,IMT,PE_RECV ORL1F404.801
& ,INFO,UBTBBCJ,UBTBBC(1,J_JMT-1)) ORL1F404.802
ENDIF ORL1F404.803
ORL1F404.804
CALL GC_GSYNC(O_NPROC,INFO) ORL1F404.805
ORL1F404.806
IF (J_PE_JSTM1.GE.0) THEN ORL1F404.807
! We're expecting to receive a message: ORL1F404.808
PE_SEND = J_PE_JSTM1 ORL1F404.809
CALL GC_RRECV (5012,IMT,PE_SEND ORL1F404.810
& ,INFO,UBTBBCJ,UBTBBC) ORL1F404.811
ENDIF ORL1F404.812
ORL1F404.813
CALL GC_GSYNC(O_NPROC,INFO) ORL1F404.814
IF (J_PE_JFINP1.GE.0) THEN ORL1F404.815
! We must send row J_JMT-1 ORL1F404.816
PE_RECV=J_PE_JFINP1 ORL1F404.817
CALL GC_RSEND (5013,IMT,PE_RECV ORL1F404.818
& ,INFO,VBTBBCJ,VBTBBC(1,J_JMT-1)) ORL1F404.819
ENDIF ORL1F404.820
ORL1F404.821
CALL GC_GSYNC(O_NPROC,INFO) ORL1F404.822
ORL1F404.823
IF (J_PE_JSTM1.GE.0) THEN ORL1F404.824
! We're expecting to receive a message: ORL1F404.825
PE_SEND = J_PE_JSTM1 ORL1F404.826
CALL GC_RRECV (5013,IMT,PE_SEND ORL1F404.827
& ,INFO,VBTBBCJ,VBTBBC) ORL1F404.828
ENDIF ORL1F404.829
ORL1F404.830
CALL GC_GSYNC(O_NPROC,INFO) ORL1F404.831
ORL1F404.832
ENDIF ! (L_OFREESFC) ORL1F404.833
*ENDIF OLA3F403.185
C BLOKINIT.641
IF (JST.GT.1) THEN BLOKINIT.642
C BLOKINIT.643
C--------------------------------------------------------------------- BLOKINIT.644
C COMPUTE DENSITY TO THE SOUTH OF ROW JST - 1 (in order to calculate BLOKINIT.645
C rxp, ry and rrzp for the first call to IPDCOFCL). BLOKINIT.646
C--------------------------------------------------------------------- BLOKINIT.647
C BLOKINIT.648
CALL STATE (T (1,1,1),T (1,1,2),RHOSM, ORH6F404.992
& TDIF(1,1,1),TDIF(1,1,2),IMT,KM, BLOKINIT.651
& JREAD-1,JMT) ORH7F404.79
ORH6F404.993
CALL STATE (TM(1,1,1),TM(1,1,2),RHOSM2, ORH6F404.994
& TDIF(1,1,1),TDIF(1,1,2),IMT,KM, BLOKINIT.654
& JREAD-2,JMT) ORH7F404.80
ORH6F404.995
fxe = 1.E10 ORH6F404.996
ORH6F404.997
IF (L_OCYCLIC) THEN ORH6F404.998
C BLOKINIT.664
C--------------------------------------------------------------------- ORH6F404.999
C SET CYCLIC BOUNDARY CONDITIONS ON DENSITY ORH6F404.1000
C--------------------------------------------------------------------- ORH6F404.1001
C BLOKINIT.666
DO K=1,KM ORH6F404.1002
RHOSM2(IMT,K)=RHOSM2(2,K) ORH6F404.1003
RHOSM (IMT,K)=RHOSM (2,K) ORH6F404.1004
ENDDO ! Over K ORH6F404.1005
ENDIF ORH6F404.1006
ORH6F404.1007
IF (L_OISOPYC) THEN ORH6F404.1008
ORH6F404.1009
!----------------------------------------------------------------------- ORH6F404.1010
! Compute rxp, ry, rrzp ready for the first call to IPDCOFCL ORH6F404.1011
!----------------------------------------------------------------------- ORH6F404.1012
ORH6F404.1013
DO K = 1, KM ORH6F404.1014
DO I = 1, IMT ORH6F404.1015
ry(I,K)=FM(I,K)*FMM(I,K)*(RHOSM(I,K)-RHOSM2(I,K))*fxe ORH6F404.1016
ENDDO ! Over I ORH6F404.1017
DO I = 1, IMTM1 ORH6F404.1018
rxp (I,K)= ORH6F404.1019
& FM(I,K)*FM(I+1,K)*(RHOSM(I+1,K)-RHOSM(I,K))*fxe ORH6F404.1020
ENDDO ! Over I ORH6F404.1021
ORH6F404.1022
IF (L_OCYCLIC) THEN ORH6F404.1023
rxp (IMT,K) = rxp (2,K) ORH6F404.1024
ELSE ORH6F404.1025
rxp (IMT,K) = 0.0 ORH6F404.1026
ENDIF ORH6F404.1027
ENDDO ! Over K ORH6F404.1028
ORH6F404.1029
DO K=1,KMP1 ORH6F404.1030
DO I=1,IMT ORH6F404.1031
tempa(I,K) = 0.0 ORH6F404.1032
tempb(I,K) = 0.0 ORH6F404.1033
ENDDO ! Over I ORH6F404.1034
ENDDO ! Over K ORH6F404.1035
ORH6F404.1036
CALL STATEC(T ,T (1,1,2),tempa,TDIF,TDIF(1,1,2),1,IMT,KM, ORH6F404.1037
& JREAD-2,JMT) ORH6F404.1038
CALL STATEC(T ,T (1,1,2),tempb,TDIF,TDIF(1,1,2),2,IMT,KM, ORH6F404.1039
& JREAD-2,JMT) ORH6F404.1040
ORH6F404.1041
DO I=1,IMT ORH6F404.1042
tempa(I,KMP1) = tempa(I,KM) ORH6F404.1043
tempb(I,KMP1) = tempb(I,KM) ORH6F404.1044
ENDDO ! Over I ORH6F404.1045
ORH6F404.1046
DO K=2,KM,2 ORH6F404.1047
DO I=1,IMT ORH6F404.1048
rrzp (I,K )=tempa(I,K-1)-tempa(I,K ) ORH6F404.1049
rrzp (I,K+1)=tempb(I,K)-tempb(I,K+1) ORH6F404.1050
ENDDO ! Over I ORH6F404.1051
ENDDO ! Over K ORH6F404.1052
ORH6F404.1053
IF (L_OEXTRAP) THEN ORH6F404.1054
IF (L_OTIMER) CALL TIMER('EXTRAP ',103) GPB8F405.74
CALL EXTRAP ORH6F404.1056
& (imt,imtm1,kmp1,km,fxe, ORH6F404.1057
& kmt,kmtp,dzz,dzz2rq,dz2rq, ORH6F404.1058
& tempa,tempb,rrzp,drhob1p,drhob2p ORH6F404.1059
& ) ORH6F404.1060
IF (L_OTIMER) CALL TIMER('EXTRAP ',104) GPB8F405.75
C k loop from 1 to KM when setting rrz(k=1) to an interpolated value OLA1F402.6
C which is relevent for the middle of the t grid box OLA1F402.7
do k=1,km ORH6F404.1062
do i=1,imt ORH6F404.1063
rrzp(i,k)=FM(i,k)*rrzp(i,k)*fxe ORH6F404.1064
enddo ORH6F404.1065
enddo ORH6F404.1066
do i=1,imt ORH6F404.1067
rrzp(i,kmp1)=0.0 ORH6F404.1068
enddo ORH6F404.1069
ELSE ORH6F404.1070
C k loop from 2 to KM when setting rrz(k=1) to zero ORH6F404.1071
DO K=2,KM ORH6F404.1072
DO I=1,IMT ORH6F404.1073
rrzp (I,K)=FM (I,K)*rrzp (I,K)*fxe ORH6F404.1074
ENDDO ! Over I ORH6F404.1075
ENDDO ! Over K ORH6F404.1076
DO I=1,IMT ORH6F404.1077
rrzp(I,1) = 0.0 ORH6F404.1078
rrzp (I,KMP1)=0.0 ORH6F404.1079
ENDDO ! Over I ORH6F404.1080
ENDIF ORH6F404.1081
ENDIF ! L_OISOPYC = true ORH6F404.1082
C this has j=j_1-1 set OOM1F405.1917
OOM1F405.1918
IF (L_OISOPYC) THEN OOM1F405.1919
C Initialise values involved with new isopycnal diffusion and GM90 OOM1F405.1920
C scheme OOM1F405.1921
c0=0. OOM1F405.1922
c1=1. OOM1F405.1923
p5=.5 OOM1F405.1924
epsln=1.0e-25 OOM1F405.1925
slmxr=c1/slope_max OOM1F405.1926
OOM1F405.1927
c----------------------------------------------------------------------- OOM1F405.1928
c store the square root of the tracer timestep acceleration values OOM1F405.1929
c into variable "dtxsqr" for use in isopycnal mixing OOM1F405.1930
c this is a MOM variable related to distorted timestepping: OOM1F405.1931
c set equal to 1 OOM1F405.1932
c----------------------------------------------------------------------- OOM1F405.1933
do k=1,km OOM1F405.1934
dtxsqr(k) = c1 OOM1F405.1935
enddo OOM1F405.1936
OOM1F405.1937
IF (L_OISOGM) THEN OOM1F405.1938
OOM1F405.1939
c diffusivity for biharmonic GM (set to zero if not selected) OOM1F405.1940
athkdftu_bi=athkdf_bi OOM1F405.1941
athkdftv_bi=athkdf_bi OOM1F405.1942
OOM1F405.1943
IF (.NOT.L_OVISBECK) THEN OOM1F405.1944
do k=1,km OOM1F405.1945
do i=1,imt OOM1F405.1946
athkdftu_mom(i,k)=athkdf(k) OOM1F405.1947
athkdftv_mom(i,k)=athkdf(k) OOM1F405.1948
enddo OOM1F405.1949
enddo OOM1F405.1950
ELSE OOM1F405.1951
do k=1,km OOM1F405.1952
do i=1,imt OOM1F405.1953
athkdftu_mom(i,k)=athkdftu(i,j) OOM1F405.1954
athkdftv_mom(i,k)=athkdftv(i,j) OOM1F405.1955
enddo OOM1F405.1956
enddo OOM1F405.1957
ENDIF ! L_OVISBECK OOM1F405.1958
OOM1F405.1959
do k=1,km OOM1F405.1960
top_bc(k) = c1 OOM1F405.1961
bot_bc(k) = c1 OOM1F405.1962
enddo OOM1F405.1963
top_bc(1) = c0 OOM1F405.1964
bot_bc(km) = c0 OOM1F405.1965
OOM1F405.1966
ENDIF ! L_OISOGM OOM1F405.1967
OOM1F405.1968
C initialise the expansion coeffs, alpha and beta, and the tracer OOM1F405.1969
C gradients before the first call to isopyc_m. Also need to OOM1F405.1970
C initialize variables for isopyc_a OOM1F405.1971
C this is inside a L_OSIOPYC and JST>1 OOM1F405.1972
c======================================================================= OOM1F405.1973
c Estimate alpha, beta, and normal gradients on faces of T cells OOM1F405.1974
c======================================================================= OOM1F405.1975
c OOM1F405.1976
IF (L_OISOMOM) THEN OOM1F405.1977
OOM1F405.1978
CALL DRODT(TBM,TBM(1,1,2),alphai(1,1,0),imt,km) OOM1F405.1979
CALL DRODS(TBM,TBM(1,1,2),betai(1,1,0),imt,km) OOM1F405.1980
call SETBCX (alphai(1,1,0), imt, km) OOM1F405.1981
call SETBCX (betai(1,1,0), imt, km) OOM1F405.1982
OOM1F405.1983
CALL DRODT(TB,TB(1,1,2),alphai(1,1,1),imt,km) OOM1F405.1984
CALL DRODS(TB,TB(1,1,2),betai(1,1,1),imt,km) OOM1F405.1985
call SETBCX (alphai(1,1,1), imt, km) OOM1F405.1986
call SETBCX (betai(1,1,1), imt, km) OOM1F405.1987
OOM1F405.1988
IF (L_OBIHARMGM) THEN OOM1F405.1989
CALL DRODT(TBP,TBP(1,1,2),alphai(1,1,2),imt,km) OOM1F405.1990
CALL DRODS(TBP,TBP(1,1,2),betai(1,1,2),imt,km) OOM1F405.1991
call SETBCX (alphai(1,1,2), imt, km) OOM1F405.1992
call SETBCX (betai(1,1,2), imt, km) OOM1F405.1993
ENDIF OOM1F405.1994
c OOM1F405.1995
do n=1,2 OOM1F405.1996
do k=1,km OOM1F405.1997
do i=1,imt-1 OOM1F405.1998
ddxt(i,k,n,1) = (((fm(i,k)*fm(i+1,k))*cstr(j))* OOM1F405.1999
& dxur(i))*(tb(i+1,k,n) - tb(i,k,n)) OOM1F405.2000
enddo OOM1F405.2001
enddo OOM1F405.2002
call SETBCX (ddxt(1,1,n,1), imt, km) OOM1F405.2003
enddo OOM1F405.2004
c OOM1F405.2005
do n=1,2 OOM1F405.2006
do k=1,km OOM1F405.2007
do i=1,imt OOM1F405.2008
ddyt(i,k,n,1) = ((fmm(i,k)*fm(i,k))*dyurjm)* OOM1F405.2009
& (tb(i,k,n) - tbm(i,k,n)) OOM1F405.2010
enddo OOM1F405.2011
enddo OOM1F405.2012
call SETBCX (ddyt(1,1,n,1), imt, km) OOM1F405.2013
enddo OOM1F405.2014
c OOM1F405.2015
IF (L_OBIHARMGM) THEN OOM1F405.2016
do n=1,2 OOM1F405.2017
do k=1,km OOM1F405.2018
do i=1,imt OOM1F405.2019
ddyt(i,k,n,2) = ((fm(i,k)*fmp(i,k))*dyur(j))* OOM1F405.2020
& (tbp(i,k,n) - tb(i,k,n)) OOM1F405.2021
OOM1F405.2022
enddo OOM1F405.2023
enddo OOM1F405.2024
call SETBCX (ddyt(1,1,n,2), imt, km) OOM1F405.2025
enddo OOM1F405.2026
ENDIF OOM1F405.2027
c OOM1F405.2028
do n=1,2 OOM1F405.2029
do k=1,km OOM1F405.2030
kp1 = min(k+1,km) OOM1F405.2031
do i=1,imt OOM1F405.2032
ddzt(i,k,n,0) = ((2.*fmm(i,kp1))*dzz2r(k+1))* OOM1F405.2033
& (tbm(i,k,n) - tbm(i,kp1,n)) OOM1F405.2034
ddzt(i,k,n,1) = ((2.*fm(i,kp1))*dzz2r(k+1))* OOM1F405.2035
& (tb(i,k,n) - tb(i,kp1,n)) OOM1F405.2036
enddo OOM1F405.2037
enddo OOM1F405.2038
do i=1,imt OOM1F405.2039
ddzt(i,0,n,0) = 0. OOM1F405.2040
ddzt(i,0,n,1) = 0. OOM1F405.2041
enddo OOM1F405.2042
call SETBCX (ddzt(1,0,n,0), imt, km+1) OOM1F405.2043
call SETBCX (ddzt(1,0,n,1), imt, km+1) OOM1F405.2044
enddo OOM1F405.2045
c OOM1F405.2046
IF (L_OBIHARMGM) THEN OOM1F405.2047
do n=1,2 OOM1F405.2048
do k=1,km OOM1F405.2049
kp1 = min(k+1,km) OOM1F405.2050
do i=1,imt OOM1F405.2051
ddzt(i,k,n,2) = ((2.*fmp(i,kp1))*dzz2r(k+1))* OOM1F405.2052
& (tbp(i,k,n) - tbp(i,kp1,n)) OOM1F405.2053
enddo OOM1F405.2054
enddo OOM1F405.2055
do i=1,imt OOM1F405.2056
ddzt(i,0,n,2) = 0. OOM1F405.2057
enddo OOM1F405.2058
call SETBCX (ddzt(1,0,n,2), imt, km+1) OOM1F405.2059
enddo OOM1F405.2060
ENDIF OOM1F405.2061
c OOM1F405.2062
IF (L_OISOGM) THEN OOM1F405.2063
do k=1,km OOM1F405.2064
km1 = max(k-1,1) OOM1F405.2065
kp1 = min(k+1,km) OOM1F405.2066
do i=1,imt OOM1F405.2067
at = ((alphai(i,k,0) + alphai(i,k,1)) + alphai(i,km1,0)) OOM1F405.2068
& + alphai(i,km1,1) OOM1F405.2069
bt = ((betai(i,k,0) + betai(i,k,1)) + betai(i,km1,0)) OOM1F405.2070
& + betai(i,km1,1) OOM1F405.2071
stn(i,k,1) = -(at*(ddyt(i,k,1,1) + ddyt(i,km1,1,1)) OOM1F405.2072
& + bt*(ddyt(i,k,2,1) + ddyt(i,km1,2,1))) OOM1F405.2073
& / (at*(ddzt(i,km1,1,0) + ddzt(i,km1,1,1)) OOM1F405.2074
& + bt*(ddzt(i,km1,2,0) + ddzt(i,km1,2,1))+epsln) OOM1F405.2075
c OOM1F405.2076
ab = ((alphai(i,k,0) + alphai(i,k,1)) + alphai(i,kp1,0)) OOM1F405.2077
& + alphai(i,kp1,1) OOM1F405.2078
bb = ((betai(i,k,0) + betai(i,k,1)) + betai(i,kp1,0)) OOM1F405.2079
& + betai(i,kp1,1) OOM1F405.2080
sbn(i,k,1) = -(ab*(ddyt(i,k,1,1) + ddyt(i,kp1,1,1)) OOM1F405.2081
& + bb*(ddyt(i,k,2,1) + ddyt(i,kp1,2,1))) OOM1F405.2082
& / (ab*(ddzt(i,k,1,0) + ddzt(i,k,1,1)) OOM1F405.2083
& + bb*(ddzt(i,k,2,0) + ddzt(i,k,2,1))+epsln) OOM1F405.2084
OOM1F405.2085
stn(i,k,0)=c0 OOM1F405.2086
sbn(i,k,0)=c0 OOM1F405.2087
enddo OOM1F405.2088
enddo OOM1F405.2089
OOM1F405.2090
IF (L_OISOTAPER) THEN OOM1F405.2091
do k=1,km OOM1F405.2092
kp1 = min(k+1,km) OOM1F405.2093
do i=1,imt OOM1F405.2094
Ath0 = c1 OOM1F405.2095
c Ath0 = athkdftv_bi(i,k) OOM1F405.2096
ath_tn(i,k,0) = c0 OOM1F405.2097
ath_bn(i,k,0) = c0 OOM1F405.2098
absstn = abs(stn(i,k,1)) OOM1F405.2099
abssbn = abs(sbn(i,k,1)) OOM1F405.2100
tanh_temp(i) = (absstn-slopec)/dslope OOM1F405.2101
tanh_temp(i+imt) = (abssbn-slopec)/dslope OOM1F405.2102
enddo OOM1F405.2103
OOM1F405.2104
call fast_tanh(imt*2,tanh_temp) OOM1F405.2105
OOM1F405.2106
do i=1,imt OOM1F405.2107
ath_tn(i,k,1) = (((Ath0*fmm(i,k))*fm(i,k)) OOM1F405.2108
& *p5)*(c1-tanh_temp(i)) OOM1F405.2109
ath_bn(i,k,1) = (((Ath0*fmm(i,kp1))*fm(i,kp1)) OOM1F405.2110
& *p5)*(c1-tanh_temp(i+imt)) OOM1F405.2111
enddo OOM1F405.2112
enddo OOM1F405.2113
OOM1F405.2114
ELSE OOM1F405.2115
OOM1F405.2116
do k=1,km OOM1F405.2117
sc = c1/(slmxr*dtxsqr(k)) OOM1F405.2118
kp1 = min(k+1,km) OOM1F405.2119
do i=1,imt OOM1F405.2120
Ath0 = c1 OOM1F405.2121
c Ath0 = athkdftv_bi(i,k) OOM1F405.2122
absstn = abs(stn(i,k,1)) OOM1F405.2123
abssbn = abs(sbn(i,k,1)) OOM1F405.2124
if (absstn .gt. sc) then OOM1F405.2125
ath_tn(i,k,1) = ((Ath0*fmm(i,k))*fm(i,k)) OOM1F405.2126
& *(sc/(absstn + epsln))**2 OOM1F405.2127
else OOM1F405.2128
ath_tn(i,k,1) = (Ath0*fmm(i,k))*fm(i,k) OOM1F405.2129
endif OOM1F405.2130
if (abssbn .gt. sc) then OOM1F405.2131
ath_bn(i,k,1) = ((Ath0*fmm(i,kp1))*fm(i,kp1)) OOM1F405.2132
& *(sc/(abssbn + epsln))**2 OOM1F405.2133
else OOM1F405.2134
ath_bn(i,k,1) = (Ath0*fmm(i,kp1))*fm(i,kp1) OOM1F405.2135
endif OOM1F405.2136
enddo OOM1F405.2137
enddo OOM1F405.2138
ENDIF ! taper OOM1F405.2139
OOM1F405.2140
IF (L_OBIHARMGM) THEN OOM1F405.2141
do k=1,km OOM1F405.2142
km1 = max(k-1,1) OOM1F405.2143
kp1 = min(k+1,km) OOM1F405.2144
do i=1,imt OOM1F405.2145
at = ((alphai(i,k,1) + alphai(i,k,2)) + alphai(i,km1,1)) OOM1F405.2146
& + alphai(i,km1,2) OOM1F405.2147
bt = ((betai(i,k,1) + betai(i,k,2)) + betai(i,km1,1)) OOM1F405.2148
& + betai(i,km1,2) OOM1F405.2149
stn(i,k,2) = -(at*(ddyt(i,k,1,2) + ddyt(i,km1,1,2)) OOM1F405.2150
& + bt*(ddyt(i,k,2,2) + ddyt(i,km1,2,2))) OOM1F405.2151
& / (at*(ddzt(i,km1,1,1) + ddzt(i,km1,1,2)) OOM1F405.2152
& + bt*(ddzt(i,km1,2,1) + ddzt(i,km1,2,2))+epsln) OOM1F405.2153
OOM1F405.2154
ab = ((alphai(i,k,1) + alphai(i,k,2)) + alphai(i,kp1,1)) OOM1F405.2155
& + alphai(i,kp1,2) OOM1F405.2156
bb = ((betai(i,k,1) + betai(i,k,2)) + betai(i,kp1,1)) OOM1F405.2157
& + betai(i,kp1,2) OOM1F405.2158
sbn(i,k,2) = -(ab*(ddyt(i,k,1,2) + ddyt(i,kp1,1,2)) OOM1F405.2159
& + bb*(ddyt(i,k,2,2) + ddyt(i,kp1,2,2))) OOM1F405.2160
& / (ab*(ddzt(i,k,1,1) + ddzt(i,k,1,2)) OOM1F405.2161
& + bb*(ddzt(i,k,2,1) + ddzt(i,k,2,2))+epsln) OOM1F405.2162
enddo OOM1F405.2163
enddo OOM1F405.2164
OOM1F405.2165
IF (L_OISOTAPER) THEN OOM1F405.2166
do k=1,km OOM1F405.2167
kp1 = min(k+1,km) OOM1F405.2168
do i=1,imt OOM1F405.2169
Ath0 = c1 OOM1F405.2170
c Ath0 = athkdftv_bi(i,k) OOM1F405.2171
absstn = abs(stn(i,k,2)) OOM1F405.2172
abssbn = abs(sbn(i,k,2)) OOM1F405.2173
tanh_temp(i) = (absstn-slopec)/dslope OOM1F405.2174
tanh_temp(i+imt) = (abssbn-slopec)/dslope OOM1F405.2175
enddo OOM1F405.2176
OOM1F405.2177
call fast_tanh(imt*2,tanh_temp) OOM1F405.2178
OOM1F405.2179
do i=1,imt OOM1F405.2180
ath_tn(i,k,2) = (((Ath0*fm(i,k))*fmp(i,k)) OOM1F405.2181
& *p5)*(c1-tanh_temp(i)) OOM1F405.2182
ath_bn(i,k,2) = (((Ath0*fm(i,kp1))*fmp(i,kp1)) OOM1F405.2183
& *p5)*(c1-tanh_temp(i+imt)) OOM1F405.2184
enddo OOM1F405.2185
enddo OOM1F405.2186
OOM1F405.2187
ELSE OOM1F405.2188
OOM1F405.2189
do k=1,km OOM1F405.2190
sc = c1/(slmxr*dtxsqr(k)) OOM1F405.2191
kp1 = min(k+1,km) OOM1F405.2192
do i=1,imt OOM1F405.2193
Ath0 = c1 OOM1F405.2194
c Ath0 = athkdftv_bi(i,k) OOM1F405.2195
absstn = abs(stn(i,k,2)) OOM1F405.2196
abssbn = abs(sbn(i,k,2)) OOM1F405.2197
if (absstn .gt. sc) then OOM1F405.2198
ath_tn(i,k,2) = ((Ath0*fm(i,k))*fmp(i,k)) OOM1F405.2199
& *(sc/(absstn + epsln))**2 OOM1F405.2200
else OOM1F405.2201
ath_tn(i,k,2) = (Ath0*fm(i,k))*fmp(i,k) OOM1F405.2202
endif OOM1F405.2203
if (abssbn .gt. sc) then OOM1F405.2204
ath_bn(i,k,2) = ((Ath0*fm(i,kp1))*fmp(i,kp1)) OOM1F405.2205
& *(sc/(abssbn + epsln))**2 OOM1F405.2206
else OOM1F405.2207
ath_bn(i,k,2) = (Ath0*fm(i,kp1))*fmp(i,kp1) OOM1F405.2208
endif OOM1F405.2209
enddo OOM1F405.2210
enddo OOM1F405.2211
ENDIF ! taper OOM1F405.2212
ENDIF ! L_OBIHARMGM OOM1F405.2213
OOM1F405.2214
do k=1,km OOM1F405.2215
do i=1,imt OOM1F405.2216
Ath0 = athkdftv_mom(i,k) OOM1F405.2217
adv_vntiso(i,k,1) = -((ath_tn(i,k,1)*stn(i,k,1))*top_bc(k) - OOM1F405.2218
& (ath_bn(i,k,1)*sbn(i,k,1))*bot_bc(k))* OOM1F405.2219
& Ath0*(2.*dz2r(k))*csjm OOM1F405.2220
enddo OOM1F405.2221
enddo OOM1F405.2222
OOM1F405.2223
IF (L_OBIHARMGM) THEN OOM1F405.2224
OOM1F405.2225
do k=1,km OOM1F405.2226
do i=1,imt OOM1F405.2227
Ath0_j = (athkdftv_bi*dytr(j))*cst(j) OOM1F405.2228
Ath0_jp1 = (athkdftv_bi*dytr(j+1))*cst(j+1) OOM1F405.2229
OOM1F405.2230
part1 = (ath_tn(i,k,2)*stn(i,k,2)) - OOM1F405.2231
& (ath_tn(i,k,1)*stn(i,k,1))*Ath0_jp1 OOM1F405.2232
part2 = (ath_tn(i,k,1)*stn(i,k,1)) - OOM1F405.2233
& (ath_tn(i,k,0)*stn(i,k,0))*Ath0_j OOM1F405.2234
stn_d2(i,k) = ((((part2-part1) OOM1F405.2235
& *dyur(j))*csr(j))*fm(i,k))*fmp(i,k) OOM1F405.2236
OOM1F405.2237
OOM1F405.2238
part1 = (ath_bn(i,k,2)*sbn(i,k,2) OOM1F405.2239
& - ath_bn(i,k,1)*sbn(i,k,1))*Ath0_jp1 OOM1F405.2240
part2 = (ath_bn(i,k,1)*sbn(i,k,1) OOM1F405.2241
& - ath_bn(i,k,0)*sbn(i,k,0))*Ath0_j OOM1F405.2242
sbn_d2(i,k) = ((((part2-part1) OOM1F405.2243
& *dyur(j))*csr(j))*fm(i,k))*fmp(i,k) OOM1F405.2244
enddo OOM1F405.2245
enddo OOM1F405.2246
OOM1F405.2247
do k=1,km OOM1F405.2248
do i=1,imt OOM1F405.2249
adv_vntiso(i,k,1) = adv_vntiso(i,k,1) - OOM1F405.2250
& (((stn_d2(i,k)*top_bc(k)) - (sbn_d2(i,k)*bot_bc(k)))* OOM1F405.2251
& (2.*dz2r(k)))*csjm OOM1F405.2252
enddo OOM1F405.2253
enddo OOM1F405.2254
OOM1F405.2255
ENDIF ! L_OBIHARMGM OOM1F405.2256
OOM1F405.2257
OOM1F405.2258
ENDIF ! L_OISOGM OOM1F405.2259
ENDIF ! L_OISOMOM OOM1F405.2260
OOM1F405.2261
ENDIF ! L_OISOPYC OOM1F405.2262
C--------------------------------------------------------------------- BLOKINIT.724
C We must calculate EXTERNAL mode velocities for row JREAD - 1 since BLOKINIT.725
C we need to know U, UB, UBM, V, VB, VBM at row JREAD. BLOKINIT.726
C--------------------------------------------------------------------- BLOKINIT.727
*IF DEF,MPP ORH9F402.108
J=J_1 -2 ORH6F404.1083
*ELSE ORH9F402.110
J=JST-2 BLOKINIT.728
*ENDIF ORH9F402.111
C BLOKINIT.729
IF (.NOT.L_ONOCLIN) THEN ORH6F404.1084
IF (L_OFREESFC) THEN ORH6F404.1085
ORH6F404.1086
DO I=1,IMTM1 ORH6F404.1087
SFUB(I) = UBTBBC(I,J+1)*HR(I,J+1) ORH6F404.1088
SFVB(I) = VBTBBC(I,J+1)*HR(I,J+1) ORH6F404.1089
*IF DEF,MPP PXBLOKIN.3
SFUBM(I)= UBTBBCJ(I)*HRJ(I) ORH6F404.1090
SFVBM(I)= VBTBBCJ(I)*HRJ(I) ORH6F404.1091
*ENDIF PXBLOKIN.4
ENDDO ! over i ORH6F404.1092
ORH6F404.1093
ELSE ORH6F404.1094
ORH6F404.1095
DO I=1,IMTM1 ORH6F404.1096
DIAG1=PB(I+1,J+2)-PB(I ,J+1) ORH6F404.1097
DIAG2=PB(I ,J+2)-PB(I+1,J+1) ORH6F404.1098
SFUB(I)=-(DIAG1+DIAG2)*DYU2R(J+1)*HR(I,J+1) ORH6F404.1099
SFVB(I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+1)*CSR(J+1) ORH6F404.1100
DIAG1=PB(I+1,J+1)-PB(I ,J ) ORH6F404.1101
DIAG2=PB(I ,J+1)-PB(I+1,J ) ORH6F404.1102
*IF DEF,MPP ORH9F402.196
! MPP code must use the specially comunicated ORH6F404.1103
! values for these calculations. ORH6F404.1104
SFUBM(I)=-(DIAG1+DIAG2)*DYU2RJ*HRJ(I) ORH6F404.1105
SFVBM(I)= (DIAG1-DIAG2)*DXU2R(I )*HRJ(I)*CSRJ ORH6F404.1106
*ELSE ORH9F402.201
SFUBM(I)=-(DIAG1+DIAG2)*DYU2R(J)*HR(I,J) ORH6F404.1107
SFVBM(I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J)*CSR(J) ORH6F404.1108
*ENDIF ORH9F402.202
ENDDO ! Over I ORH6F404.1109
ENDIF ! (L_OFREESFC) ORH6F404.1110
C BLOKINIT.741
C 2ND, COMPUTE FOR TAU TIME LEVEL BLOKINIT.742
C BLOKINIT.743
IF (L_OFREESFC) THEN ORH6F404.1111
DO I=1,IMTM1 ORH6F404.1112
SFU(I) = UBT(I,J+1)*HR(I,J+1) ORH6F404.1113
SFV(I) = VBT(I,J+1)*HR(I,J+1) ORH6F404.1114
ENDDO ORH6F404.1115
ORH6F404.1116
ELSE ORH6F404.1117
DO I=1,IMTM1 ORH6F404.1118
DIAG1=P (I+1,J+2)-P (I ,J+1) ORH6F404.1119
DIAG2=P (I ,J+2)-P (I+1,J+1) ORH6F404.1120
SFU (I)=-(DIAG1+DIAG2)*DYU2R(J+1)*HR(I,J+1) ORH6F404.1121
SFV (I)= (DIAG1-DIAG2)*DXU2R(I )*HR(I,J+1)*CSR(J+1) ORH6F404.1122
ENDDO ! Over I ORH6F404.1123
ENDIF ORH6F404.1124
ORH6F404.1125
IF (L_OCYCLIC) THEN ORH6F404.1126
C BLOKINIT.752
C 3RD, SET CYCLIC BOUNDARY CONDITIONS BLOKINIT.753
C BLOKINIT.754
SFUB(IMT)=SFUB(2) ORH6F404.1127
SFVB(IMT)=SFVB(2) ORH6F404.1128
SFU (IMT)=SFU (2) ORH6F404.1129
SFV (IMT)=SFV (2) ORH6F404.1130
SFUBM(IMT)=SFUBM(2) ORH6F404.1131
SFVBM(IMT)=SFVBM(2) ORH6F404.1132
ENDIF ORH6F404.1133
C--------------------------------------------------------------------- BLOKINIT.763
C ADD EXTERNAL MODE TO INTERNAL MODE FOR ROW JREAD (OCEAN PTS. ONLY) BLOKINIT.764
C--------------------------------------------------------------------- BLOKINIT.765
C BLOKINIT.766
DO K=1,KM ORH6F404.1134
DO I=1,IMU ORH6F404.1135
IF (FKMQ(I,JREAD-1).GE.KAR(K)) THEN ORH6F404.1136
UB (I,K)=UB (I,K)+SFUB(I) ORH6F404.1137
VB (I,K)=VB (I,K)+SFVB(I) ORH6F404.1138
U (I,K)=U (I,K)+SFU (I) ORH6F404.1139
V (I,K)=V (I,K)+SFV (I) ORH6F404.1140
ENDIF ORH6F404.1141
*IF DEF,MPP ORH9F402.34
! JREAD - 2 is outside the range of the halos ORH6F404.1142
! so we refer to a full global copy of this array ORH6F404.1143
IF (FKMQ_GLOBAL(I,JREAD-2+J_OFFSET).GE.KAR(K)) THEN ORH6F404.1144
*ELSE ORH9F402.38
IF(FKMQ(I,JREAD-2).GE.KAR(K)) THEN ORH6F404.1145
*ENDIF ORH9F402.39
UBM(I,K)=UBM(I,K)+SFUBM(I) ORH6F404.1146
VBM(I,K)=VBM(I,K)+SFVBM(I) ORH6F404.1147
ENDIF ORH6F404.1148
ENDDO ! Over I ORH6F404.1149
ENDDO ! Over K ORH6F404.1150
ENDIF ORH6F404.1151
IF (L_OCNASSM) THEN ORH6F404.1152
C BLOKINIT.783
C----------------------------------------------------------------------- BLOKINIT.784
C ADD DATA ASSIMILATION INCREMENTS FOR ROW JREAD-1 BLOKINIT.785
C----------------------------------------------------------------------- BLOKINIT.786
C BLOKINIT.787
IF (LL_ASS_BTRP) THEN ORH6F404.1153
DO K=1,KM ORH6F404.1154
DO I=1,IMU ORH6F404.1155
IF (FKMQ(I,JREAD-1).GE.KAR(K)) THEN ORH6F404.1156
U (I,K)=U (I,K)+DU_ASS_BTRP(I,JREAD-1) ORH6F404.1157
V (I,K)=V (I,K)+DV_ASS_BTRP(I,JREAD-1) ORH6F404.1158
ENDIF ORH6F404.1159
ENDDO ! Over I ORH6F404.1160
ENDDO ! Over K ORH6F404.1161
ENDIF ORH6F404.1162
ENDIF BLOKINIT.797
ORH6F404.1163
*IF DEF,MPP ORH9F402.112
J=J_1-1 ORH6F404.1164
*ELSE ORH9F402.114
J=JST-1 BLOKINIT.800
*ENDIF ORH9F402.115
C BLOKINIT.801
C--------------------------------------------------------------------- BLOKINIT.802
C COMPUTE VALUE OF FVST FOR ROW JST BLOKINIT.803
C--------------------------------------------------------------------- BLOKINIT.804
C The value of FVST depends on V at J-1 for the last timestep. BLOKINIT.805
C BLOKINIT.806
FXB=(CSTR(J)*CS(J)) OSY1F405.31
DO K=1,KM ORH6F404.1167
DO I=2,IMT ORH6F404.1168
FVST(I,K)=((V(I,K)*DXU(I))+(V(I-1,K)*DXU(I-1)))*FXB OSY1F405.32
& *DXT2R(I) OSY1F405.33
ENDDO ! Over I ORH6F404.1170
FVST(1,K)=0.0 ORH6F404.1171
ENDDO ! Over K ORH6F404.1172
C OSY1F405.34
C This call is to calculate FLUXST for the first row of the block. OSY1F405.35
C This is the same quantity as FLUXNT for the halo row, so we call OSY1F405.36
C ADV_SOURCE to calculate FLUXNT for the halo row and pass it back OSY1F405.37
C as FLUXST. Therefore the order of the FLUXNT and FLUXST arguments OSY1F405.38
C in the call is reversed. Also the FVN value for the halo row that OSY1F405.39
C we pass into the routine is the FVST value just calculated. OSY1F405.40
C OSY1F405.41
DO I=1,IMT OSY1F405.42
KMTJM(I)=FKMP_GLOBAL(I,J_1+J_OFFSET-2) OSY1F405.43
ENDDO OSY1F405.44
OSY1F405.45
L_BOOTSTRAP=.TRUE. OSY1F405.46
DO M=1,NT OSY1F405.47
CALL ADV_SOURCE( OSY1F405.48
& O_ADVECT_SCHEME(1,M), OSY1F405.49
& J, OSY1F405.50
& IMT,J_JMT,KM, OSY1F405.51
& TEMPA, ! Dummy return OSY1F405.52
& TEMPA,TEMPA,TEMPA,TEMPA, ! variables. OSY1F405.53
& T(1,1,M),TB(1,1,M), OSY1F405.54
& TM(1,1,M),TBM(1,1,M),TP(1,1,M),TBP(1,1,M), OSY1F405.55
& TPP(1,1,M),TBPP(1,1,M), OSY1F405.56
& FUW,FVST,FVST,W, OSY1F405.57
& FLUXNT(1,1,M),FLUXST(1,1,M),TEMPA, OSY1F405.58
& DXTR,DYTR,CSTR,DZ,DZZ, OSY1F405.59
& KMTJM,KMT,KMTP,KMTPP, OSY1F405.60
& L_OIMPADDF, OSY1F405.61
& L_OFREESFC, OSY1F405.62
& L_BOOTSTRAP, OSY1F405.63
& L_OCYCLIC, OSY1F405.64
& J_OFFSET,imout,jmout,imout_hud,jmout_hud,temptend,temptend, OSY1F405.65
& NMEDLEV,m,NT,L_OMEDADV,L_OHUDOUT,.FALSE.,.FALSE.,tempmed, OSY1F405.66
& tempmed,CS OSY1F405.67
& ) OSY1F405.68
ENDDO ! over M. OSY1F405.69
C BLOKINIT.816
FXA = (CST(J)*CSTR(J+1)) OSY1F405.70
DO K=1,KM ORH6F404.1174
DO I=1,IMT ORH6F404.1175
FVST(I,K)=FVST(I,K) * FXA ORH6F404.1176
do m=1,nt OSY1F405.71
FLUXST(I,K,M)=FLUXST(I,K,M)*FXA OSY1F405.72
enddo OSY1F405.73
ENDDO ! Over I ORH6F404.1177
ENDDO ! Over K ORH6F404.1178
C BLOKINIT.823
C BLOKINIT.824
IF (L_OISOPYC) THEN ORH6F404.1179
*IF DEF,MPP OLA3F403.186
c Set up WSX and WSY OLA3F403.187
DO I=1,IMT ORH6F404.1180
WSX(I)=D1(joc_taux+I-1) ORH6F404.1181
WSY(I)=D1(joc_tauy+I-1) ORH6F404.1182
C SET UP HTN,PME,SOL,WME OOM1F405.456
HTN(I)=D1(JOC_HEAT+I-1) OOM1F405.457
PME(I)=D1(JOC_PLE+I-1) OOM1F405.458
SOL(I)=D1(JOC_SOLAR+I-1) OOM1F405.459
WME(I)=D1(JOC_WME+I-1) OOM1F405.460
ENDDO ORH6F404.1183
*ELSE OLA3F403.192
c Set up WSX,WSY,WSXM,WSYM OLA3F403.193
DO I=1,IMT ORH6F404.1184
WSX(I)=D1(joc_taux+(JST-2)*IMT+I-1) ORH6F404.1185
WSY(I)=D1(joc_tauy+(JST-2)*IMT+I-1) ORH6F404.1186
WSXM(I)=D1(joc_taux+(JST-3)*IMT+I-1) ORH6F404.1187
WSYM(I)=D1(joc_tauy+(JST-3)*IMT+I-1) ORH6F404.1188
ENDDO ORH6F404.1189
C SET UP HTN,PME,SOL,WME OOM1F405.461
DO I=1,IMT OOM1F405.462
HTN(I)=D1(JOC_HEAT+(JST-2)*IMT+I-1) OOM1F405.463
PME(I)=D1(JOC_PLE+(JST-2)*IMT+I-1) OOM1F405.464
SOL(I)=D1(JOC_SOLAR+(JST-2)*IMT+I-1) OOM1F405.465
WME(I)=D1(JOC_WME+(JST-2)*IMT+I-1) OOM1F405.466
ENDDO OOM1F405.467
*ENDIF OLA3F403.200
C CALCULATE WATERFLUX FROM SEAICE OOM1F405.468
IF (L_SEAICE) THEN OOM1F405.469
DO I=1,IMT OOM1F405.470
WATERFLUX_ICE(I)=-1.*CARYSALT(I,J)*RHO_WATER_SI*DZ(1) OOM1F405.471
& /0.035 OOM1F405.472
ENDDO OOM1F405.473
ELSE OOM1F405.474
DO I=1,IMT OOM1F405.475
WATERFLUX_ICE(I)=0.0 OOM1F405.476
ENDDO OOM1F405.477
ENDIF OOM1F405.478
IF (L_SEAICE.AND.L_ICEFREEDR) THEN ODC1F405.26
J_idr = J ODC1F405.27
J_idrM1 = J-1 ODC1F405.28
C next line should be redundant, as should variable J_idrM1 here. ODC1F405.29
J_idrM1 = MAX(1,J-1) ODC1F405.30
ELSE ODC1F405.31
J_idr = 1 ODC1F405.32
J_idrM1 = 1 ODC1F405.33
ENDIF OLA0F404.32
C--------------------------------------------------------------------- BLOKINIT.826
C Now call the subroutine to calculate esav BLOKINIT.827
C--------------------------------------------------------------------- BLOKINIT.828
C if using Griffies scheme, now call CALCDIFF rather than CALCESAV, OOM1F405.309
C to calculate the appropriate variable (diff_fn rather than esav) OOM1F405.310
IF (.NOT.L_OISOMOM) THEN OOM1F405.311
CALL CALCESAV ORH1F305.3860
& (J,JMT,IMT,IMTM1,KM,KMT,KMP,KMP1,KMP2,NT,NTMIN2,KMM1, ORH1F305.3861
& T,TP,TDIF,TB,TBP,TBM, ORH1F305.3862
& UB,VB,UBM,VBM, ORH1F305.3863
& DXUR,DXU2RQ,DXT4RQ,DYUR,DYT4R,DZ2RQ,DZZ2RQ,ZDZ,DYTR, ORH1F305.3864
& NERGY,CS,CSR,CSTR,ITT,FM,FMP,FMM, ORH1F305.3865
& RHOSM,RHOS,ahi, ORH1F305.3866
& WSX,WSY,WSXM,WSYM, OLA3F403.201
& ISX(1,J_idr),ISY(1,J_idr),WSX_LEADS(1,J_idr), ODC1F405.34
& WSY_LEADS(1,J_idr),ISXM,ISYM, ODC1F405.35
& WSX_LEADSM,WSY_LEADSM, ODC1F405.36
& ZDZZ,DZ,L_OBULKRI,L_OWINDMIX,L_OBULKMAXMLD, OOM1F405.479
& LAMBDA_LARGE,MAX_LARGE_LEVELS, OOM1F405.480
& NO_LAYERS_IN_LEV,HTN,PME,WATERFLUX_ICE,SOL,WME, OOM1F405.481
& PHIT(J),OCEANHEATFLUX(1,J),CARYHEAT(1,J),FLXTOICE(1,J), OOM1F405.482
& JFT0, rxp,ry,rrzp,esav ORH1F305.3867
&,J_OFFSET ORH7F402.315
& ,drhob1p,drhob2p,DZZ,KMTP,KMTPP,VISOPN,ATHKDF,DZ2R OLA0F401.120
& ,ATHKDFTU,ATHKDFTV OLA2F403.259
& ,mldsav ORH1F305.3869
& , DIAG_MLD ORH0F401.41
& ,KAPPA_B_SI ORH1F305.3870
& ) ORH1F305.3871
ELSE OOM1F405.312
CALL CALCDIFF( OOM1F405.313
*CALL ARGSIZE OOM1F405.314
*CALL COCAWRKA OOM1F405.315
& ,j,cstr,dyur,dxur,dz2r,dzz,dzz2r,athkdftu,athkdftv,ahi,athkdf, OOM1F405.316
& dz,dyu,dxu,cs,dxt4r,dyt4r,dxtr,dytr,cst,csjm,dyurjm,j_1, OOM1F405.317
& KMP,NERGY,FKAPB_SI,CSR,ITT, OOM1F405.318
& KAPPA_B_SI,J_OFFSET, OOM1F405.319
& WSXM,WSYM,OCEANHEATFLUX(1,J),CARYHEAT(1,J),FLXTOICE(1,J), OOM1F405.320
& max_Large_levels,no_layers_in_lev, OOM1F405.321
& waterflux_ice,L_OBULKRI,L_OWINDMIX,L_OBULKMAXMLD, OOM1F405.322
& lambda_Large,phit(j), OOM1F405.323
& ISX(1,J_idr),ISY(1,J_idr),WSX_LEADS(1,J_idr), OOM1F405.324
& WSY_LEADS(1,J_idr),ISXM,ISYM, OOM1F405.325
& WSX_LEADSM,WSY_LEADSM, OOM1F405.326
& ZDZZ,ZDZ, OOM1F405.327
& adv_vetiso, OOM1F405.328
& adv_vbtiso,adv_fbiso OOM1F405.329
& ) OOM1F405.330
OOM1F405.331
ENDIF OOM1F405.332
OOM1F405.333
ORH6F404.1190
ENDIF ORH6F404.1191
C BLOKINIT.849
C--------------------------------------------------------------------- BLOKINIT.850
C BLOKINIT.851
IF (L_OBIMOM) THEN OOM3F405.573
C--------------------------------------------------------------- OOM3F405.574
C COMPUTE LAPLACIANS FOR ROW j-1 for jst>1 OOM3F405.575
C--------------------------------------------------------------- OOM3F405.576
C OOM3F405.577
BBUD=8.0*(CSR(J)*CSR(J)) OOM3F405.578
CCUD=(CST(J+1)*DYTR(J+1))*(DYUR(J)*CSR(J)) OOM3F405.579
DDUD=(CST(J)*DYTR(J))*(DYUR(J)*CSR(J)) OOM3F405.580
GGUD=(1.0-(TNG(J)*TNG(J)))/(RADIUS*RADIUS) OOM3F405.581
HHUD=2.0*SINE(J)/(RADIUS*(CS(J)*CS(J))) OOM3F405.582
OOM3F405.583
DO K=1,KM OOM3F405.584
DO I=2,IMTM1 OOM3F405.585
pt1=(BBUD*DXU2RQ(I,K))* OOM3F405.586
* (DXT4RQ(I,K)*((UB(I+1,K)-UB(I,K))+(UB(I-1,K)-UB(I,K)))) OOM3F405.587
pt2=CCUD*(UBP(I,K)-UB(I,K)) OOM3F405.588
* +DDUD*(UBM(I,K)-UB(I,K)) OOM3F405.589
pt3=GGUD*UB(I,K) OOM3F405.590
* -(HHUD*DXU2RQ(I,K))*(VB(I+1,K)-VB(I-1,K)) OOM3F405.591
D2U(I,K,2)=pt1+pt2+pt3 OOM3F405.592
ENDDO OOM3F405.593
C put in cyclic condition if appropriate OOM3F405.594
IF (L_OCYCLIC) THEN OOM3F405.595
D2U( 1,K,2)=D2U(IMTM1,K,2) OOM3F405.596
D2U(IMT,K,2)=D2U( 2,K,2) OOM3F405.597
ELSE OOM3F405.598
D2U( 1,K,2)=0. OOM3F405.599
D2U(IMT,K,2)=0. OOM3F405.600
ENDIF OOM3F405.601
ENDDO OOM3F405.602
OOM3F405.603
DO K=1,KM OOM3F405.604
DO I=2,IMTM1 OOM3F405.605
pt1=(BBUD*DXU2RQ(I,K))* OOM3F405.606
* (DXT4RQ(I,K)*((VB(I+1,K)-VB(I,K))+(VB(I-1,K)-VB(I,K)))) OOM3F405.607
pt2=CCUD*(VBP(I,K)-VB(I,K)) OOM3F405.608
* +DDUD*(VBM(I,K)-VB(I,K)) OOM3F405.609
pt3=GGUD*VB(I,K) OOM3F405.610
* +(HHUD*DXU2RQ(I,K))*(UB(I+1,K)-UB(I-1,K)) OOM3F405.611
D2V(I,K,2)=pt1+pt2+pt3 OOM3F405.612
ENDDO OOM3F405.613
IF (L_OCYCLIC) THEN OOM3F405.614
D2V( 1,K,2)=D2V(IMTM1,K,2) OOM3F405.615
D2V(IMT,K,2)=D2V( 2,K,2) OOM3F405.616
ELSE OOM3F405.617
D2V( 1,K,2)=0. OOM3F405.618
D2V(IMT,K,2)=0. OOM3F405.619
ENDIF OOM3F405.620
ENDDO OOM3F405.621
OOM3F405.622
ENDIF ! L_OBIMOM OOM3F405.623
OOM3F405.624
IF (L_OBIMOM) THEN OOM3F405.625
C--------------------------------------------------------------- OOM3F405.626
C COMPUTE LAPLACIANS FOR ROW j+1 for jst>1 OOM3F405.627
C--------------------------------------------------------------- OOM3F405.628
C OOM3F405.629
BBUD = 8.0*(CSR(J+1)*CSR(J+1)) OOM3F405.630
CCUD = (CST(J+2)*DYTR(J+2))*(DYUR(J+1)*CSR(J+1)) OOM3F405.631
DDUD = (CST(J+1)*DYTR(J+1))*(DYUR(J+1)*CSR(J+1)) OOM3F405.632
GGUD = (1.0-(TNG(J+1)*TNG(J+1)))/(RADIUS*RADIUS) OOM3F405.633
HHUD = 2.0*SINE(J+1)/(RADIUS*(CS(J+1)*CS(J+1))) OOM3F405.634
OOM3F405.635
DO K=1,KM OOM3F405.636
DO I=2,IMTM1 OOM3F405.637
pt1=(BBUD*DXU2RQ(I,K))* OOM3F405.638
* (DXT4RQ(I,K)*((UBP(I+1,K)-UBP(I,K))+(UBP(I-1,K)-UBP(I,K)))) OOM3F405.639
pt2=CCUD*(UBPP(I,K)-UBP(I,K)) OOM3F405.640
* +DDUD*(UB(I,K)-UBP(I,K)) OOM3F405.641
pt3=GGUD*UBP(I,K) OOM3F405.642
* -(HHUD*DXU2RQ(I,K))*(VBP(I+1,K)-VBP(I-1,K)) OOM3F405.643
D2U(I,K,3)=pt1+pt2+pt3 OOM3F405.644
ENDDO OOM3F405.645
C put in cyclic condition if appropriate OOM3F405.646
IF (L_OCYCLIC) THEN OOM3F405.647
D2U( 1,K,3)=D2U(IMTM1,K,3) OOM3F405.648
D2U(IMT,K,3)=D2U( 2,K,3) OOM3F405.649
ELSE OOM3F405.650
D2U( 1,K,3)=0. OOM3F405.651
D2U(IMT,K,3)=0. OOM3F405.652
ENDIF OOM3F405.653
ENDDO OOM3F405.654
OOM3F405.655
DO K=1,KM OOM3F405.656
DO I=2,IMTM1 OOM3F405.657
pt1=(BBUD*DXU2RQ(I,K))* OOM3F405.658
* (DXT4RQ(I,K)*((VBP(I+1,K)-VBP(I,K))+(VBP(I-1,K)-VBP(I,K)))) OOM3F405.659
pt2=CCUD*(VBPP(I,K)-VBP(I,K)) OOM3F405.660
* +DDUD*(VB(I,K)-VBP(I,K)) OOM3F405.661
pt3=GGUD*VBP(I,K) OOM3F405.662
* +(HHUD*DXU2RQ(I,K))*(UBP(I+1,K)-UBP(I-1,K)) OOM3F405.663
D2V(I,K,3)=pt1+pt2+pt3 OOM3F405.664
ENDDO OOM3F405.665
IF (L_OCYCLIC) THEN OOM3F405.666
D2V( 1,K,3)=D2V(IMTM1,K,3) OOM3F405.667
D2V(IMT,K,3)=D2V( 2,K,3) OOM3F405.668
ELSE OOM3F405.669
D2V( 1,K,3)=0. OOM3F405.670
D2V(IMT,K,3)=0. OOM3F405.671
ENDIF OOM3F405.672
ENDDO OOM3F405.673
OOM3F405.674
ENDIF ! L_OBIMOM OOM3F405.675
OOM3F405.676
ENDIF ! Calculations for values to the south of JST BLOKINIT.852
C BLOKINIT.853
C BLOKINIT.854
IF (JST.EQ.JMTM1_GLOBAL) THEN ORH3F403.19
! We need RHOSRN if we dont have a call to clinic on our ORH3F403.20
! first row. ORH3F403.21
J = J_1 - 1 ORH3F403.22
ORH3F403.23
CALL STATEC(TB(1,1,1),TB(1,1,2),RHOSRNA,TEMPA,TEMPB,1, OOM1F405.483
& IMT,KM,J,JMT) OOM1F405.484
CALL STATEC(TB(1,1,1),TB(1,1,2),RHOSRNB,TEMPA,TEMPB,2, OOM1F405.485
& IMT,KM,J,JMT) OOM1F405.486
DO I=1,IMT OOM1F405.487
RHOSRNA(I,KM+1)=RHOSRNA(I,KM) OOM1F405.488
RHOSRNB(I,KM+1)=RHOSRNB(I,KM) OOM1F405.489
ENDDO OOM1F405.490
CALL STATED(TB(1,1,1),TB(1,1,2),rhosrn,tempa,tempb,IMT,KM,J ORH3F403.24
& ,KM,JMT) ORH7F404.81
ORH3F403.26
! We also need RHON ORH3F403.27
CALL STATE(TP(1,1,1),TP(1,1,2),RHON,tempa,tempb,IMT,KM,J+1 ORH3F403.28
& ,JMT) ORH7F404.82
ORH3F403.30
ENDIF ORH3F403.31
C======================================================================= BLOKINIT.855
C END OF BOOTSTRAP PROCEDURE ========================================= BLOKINIT.856
C======================================================================= BLOKINIT.857
C BLOKINIT.858
!======================================================================= ORH0F401.28
! At this point, the following tracer values are available: ORH0F401.29
! ORH0F401.30
! T : Values for row JST-1 (row 1 if JST = 1) ORH6F404.1192
! TB : Values for row JST-1 (row 1 if JST = 1) ORH0F401.32
! TM : Values for row JST-2 ORH0F401.33
! TBM : Values for row JST-2 ORH0F401.34
! TBP : Values for row JST (row 2 if JST = 1) ORH0F401.35
! TP : Values for row JST (row 2 if JST = 1) ORH0F401.36
! TPX : Values for row JFIN+1 ORH0F401.37
! TBPX: Values for row JFIN+1 ORH0F401.38
! ORH0F401.39
!======================================================================= ORH0F401.40
IF (L_OTIMER) CALL TIMER('BLOKINIT',4) ORH1F305.3887
C BLOKINIT.862
RETURN BLOKINIT.863
END BLOKINIT.864
C BLOKINIT.865
*ENDIF BLOKINIT.866