SUBROUTINE INITDUMP( 1,42@DYALLOC.1503
*CALL ARGSIZE 
@DYALLOC.1504
*CALL ARGD1 @DYALLOC.1505
*CALL ARGDUMA @DYALLOC.1506
*CALL ARGDUMO @DYALLOC.1507
*CALL ARGDUMW WRB1F401.237
*CALL ARGSTS @DYALLOC.1508
*CALL ARGPTRA @DYALLOC.1509
*CALL ARGPTRO @DYALLOC.1510
*CALL ARGPTRW WRB1F401.238
*CALL ARGCONA @DYALLOC.1511
*CALL ARGCONO @DYALLOC.1512
*CALL ARGCONW WRB1F401.239
*CALL ARGPPX GSS1F305.478
& sm_ident,ICODE,CMESSAGE) WRB1F401.240
IMPLICIT NONE INITDUM1.32
INITDUM1.33
C*L Arguments @DYALLOC.1514
CL @DYALLOC.1515
*CALL OARRYSIZ ORH6F401.26
*CALL CMAXSIZE @DYALLOC.1516
*CALL CSUBMODL GSS1F305.479
*CALL TYPSIZE @DYALLOC.1517
*CALL NSTYPES ABX1F404.84
*CALL TYPD1 @DYALLOC.1518
*CALL TYPDUMA @DYALLOC.1519
*CALL TYPDUMO @DYALLOC.1520
*CALL TYPDUMW WRB1F401.241
*CALL TYPSTS ! Contains *CALL CPPXREF GSS1F305.480
*CALL TYPPTRA @DYALLOC.1522
*CALL TYPPTRO @DYALLOC.1523
*CALL TYPPTRW WRB1F401.242
*CALL TYPCONA @DYALLOC.1524
*CALL TYPCONO @DYALLOC.1525
*CALL TYPCONW WRB1F401.243
INTEGER I ! Temporary pointer count INITDUM1.34
INTEGER sm_ident ! Sub-model indicator WRB1F401.244
INTEGER ICODE ! Return code INITDUM1.36
INTEGER NFTIN ! FTN number for read INITDUM1.37
INTEGER NFTSWAP ! FTN number for swapping radiation incrs INITDUM1.38
INTEGER SEGSTART ! Pointer to start of radiation incrs INITDUM1.39
INTEGER SEGEND ! Pointer to end of radiation incrs INITDUM1.40
INTEGER LEN_IO ! Length of data transferred INITDUM1.41
INTEGER ERROR ! Error code returned by OPEN INITDUM1.43
INTEGER ocnrow_length ! Ocean row length GKR0F400.59
INITDUM1.44
REAL A_IO ! IO completion code INITDUM1.45
INITDUM1.46
CHARACTER*80 TS150793.83
& CMESSAGE ! Error message INITDUM1.48
INITDUM1.49
*CALL TYPOCDPT @DYALLOC.1526
*CALL TYPWVDPT WRB1F401.245
@DYALLOC.1527
*CALL CHSUNITS RS030293.246
*CALL CCONTROL INITDUM1.53
*CALL CENVIR GGH1F305.1
*CALL CHISTORY GDR3F305.138
*CALL C_MDI @DYALLOC.1529
*CALL CLOOKADD TJ300394.116
*CALL C_GLOBAL GSS1F304.1369
*CALL C_WRITD GSS1F304.1370
*CALL CRUNTIMC ADR1F305.100
@DYALLOC.1530
*CALL PPXLOOK GSS1F305.481
GSS1F305.482
LOGICAL @DYALLOC.1531
* L_A_DUMP ! ) Switches to indicate whether @DYALLOC.1532
* ,L_O_DUMP,L_W_DUMP ! ) atmos, ocean or wave dump. WRB1F401.246
& ,L_A_PROG_ONLY ! ) Switches set if only prognostic @DYALLOC.1534
& ,L_O_PROG_ONLY ! ) fields to be read in. @DYALLOC.1535
& ,L_W_PROG_ONLY WRB1F401.247
INTEGER @DYALLOC.1536
& LEN2_LOOKUP @DYALLOC.1537
& ,LEN_DATA @DYALLOC.1538
& ,N_PROG_FLDS ! No of prognostic fields in dumps GDR2F304.4
& ,N_PROG_LOOKUP GDR5F400.20
& ,LEN_PROG GDR5F400.21
& ,TOT_LEN_DATA GDR5F400.22
& ,D1_ADDR_SUBMODEL_ID ! submodel id in D1_ADDR array GPB4F403.29
& ,JEXP_PTR ! Pointer to Exponent Field GDR6F405.14
*IF DEF,MPP GSM1F403.62
*IF DEF,ATMOS GSM1F403.63
& ,A_MPP_ADDR(A_LEN2_LOOKUP) GSM1F403.64
& ,A_MPP_LEN(A_LEN2_LOOKUP) GSM1F403.65
*ENDIF GSM1F403.66
*IF DEF,OCEAN GSM1F403.67
& ,O_MPP_ADDR(O_LEN2_LOOKUP) GSM1F403.68
& ,O_MPP_LEN(O_LEN2_LOOKUP) GSM1F403.69
*ENDIF GSM1F403.70
*ENDIF GSM1F403.71
*CALL COMOCASZ @DYALLOC.1540
*IF DEF,MPP GPB0F305.72
*CALL PARVARS GPB0F305.73
*CALL DECOMPTP GRR0F403.3
INTEGER info ! return code from GC operations GPB0F401.199
*ENDIF GPB0F305.74
INITDUM1.55
CL Subroutines called INITDUM1.56
*IF DEF,ATMOS,OR,DEF,OCEAN,OR,DEF,WAVE WRB1F401.248
EXTERNAL INITDUM1.58
& UM_READDUMP,TIMER,READ_FLH,SETPOS,ADDRESS_CHECK GPB4F403.30
*ENDIF INITDUM1.60
*IF DEF,ATMOS INITDUM1.61
& ,PR_INHDA,PR_REHDA,SETCONA,SET_ATM_POINTERS,READLSTA INITDUM1.62
*ENDIF INITDUM1.63
*IF DEF,OCEAN INITDUM1.64
& ,SET_OCN_POINTERS,SET_CONSTANTS_OCEAN,READNLST_OCEAN INITDUM1.65
& ,REMLND INITDUM1.66
& ,DATASWAP INITDUM1.67
*ENDIF INITDUM1.68
*IF DEF,WAVE WRB1F401.250
& ,SET_WAV_POINTERS,SET_CONSTANTS_WAV WRB1F401.251
*ENDIF WRB1F401.252
INITDUM1.69
C*--------------------------------------------------------------------- INITDUM1.70
CL Internal Structure INITDUM1.71
INITDUM1.76
*IF DEF,ATMOS INITDUM1.77
CL 1.0 Read atmosphere dump and initialise atmosphere model. INITDUM1.78
IF (sm_ident.EQ.atmos_sm) THEN WRB1F401.253
INITDUM1.80
CL 1.1 Open unit for atmosphere dump, read fixed length header @DYALLOC.1542
CL and set buffer length @DYALLOC.1543
NFTIN = 21 INITDUM1.82
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), GGH1F305.3
& LEN_FT_ENVIR(NFTIN),0,0,ERROR) GGH1F305.4
@DYALLOC.1544
CALL READ_FLH (NFTIN,A_FIXHD,LEN_FIXHD,ICODE,CMESSAGE) @DYALLOC.1545
IF (ICODE.GT.0) RETURN @DYALLOC.1546
@DYALLOC.1547
CALL SETPOS (NFTIN,0,ICODE) GTD0F400.88
@DYALLOC.1549
C Test if atmos dump. @DYALLOC.1550
L_A_DUMP = A_FIXHD(5).EQ.1 .AND. A_FIXHD(2).EQ.atmos_sm WRB1F401.254
@DYALLOC.1552
C Test if only prognostic fields to be read in @DYALLOC.1553
L_A_PROG_ONLY = L_A_DUMP .AND. H_STEPim(a_im).EQ.0 GDR3F305.139
@DYALLOC.1555
C Get no of prognostic fields in atmos dump GDR2F304.5
N_PROG_FLDS = A_FIXHD(153) GDR2F304.6
GDR2F304.7
C Check N_PROG_FLDS has been set. GDR2F304.8
IF (N_PROG_FLDS.EQ.IMDI) THEN GDR2F304.9
WRITE (6,*) ' ' GDR2F304.10
WRITE (6,*) ' No of prognostic fields not set in FIXHD(153)' GDR2F304.11
WRITE (6,*) ' Run RECONFIGURATION to set FIXHD(153)' GDR2F304.12
CMESSAGE = 'INITDUMP: FIXHD(153) not set in atmos dump' GDR2F304.13
ICODE = 101 GDR2F304.14
GO TO 9999 ! Return GDR2F304.15
ENDIF GDR2F304.16
GDR2F304.17
C Check N_PROG_FLDS matches with A_PROG_LOOKUP set up by the UI GDR2F304.18
N_PROG_LOOKUP = A_PROG_LOOKUP GDR5F400.23
*IF DEF,SLAB GDR5F400.24
! Get total no of prognostic fields (atmos + slab) GDR5F400.25
N_PROG_LOOKUP = N_PROG_LOOKUP + S_PROG_LOOKUP GDR5F400.26
*ENDIF GDR5F400.27
IF (N_PROG_FLDS.NE.N_PROG_LOOKUP) THEN GDR5F400.28
WRITE (6,*) ' ' GDR2F304.20
WRITE (6,*) ' Mismatch in no of prognostic fields.' GDR2F304.21
WRITE (6,*) ' No of prog fields in Atmos dump ',N_PROG_FLDS GDR2F304.22
WRITE (6,*) ' No of prog fields expected ',N_PROG_LOOKUP GDR5F400.29
WRITE (6,*) ' ' GDR2F304.24
WRITE (6,*) ' Run RECONFIGURATION to get correct no of', GDR2F304.25
& ' prognostic fields in atmos dump' GDR2F304.26
WRITE (6,*) ' or' GDR2F304.27
WRITE (6,*) ' Check/Reset experiment in User Interface' GDR2F304.28
WRITE (6,*) ' ' GDR2F304.29
CMESSAGE = 'INITDUMP: Wrong no of atmos prognostic fields' GDR2F304.30
ICODE = 102 GDR2F304.31
GO TO 9999 ! Return GDR2F304.32
ENDIF GDR2F304.33
GDR2F304.34
*IF DEF,MPP GSM1F404.11
! Initialise D1 to prevent uninitialised data in unused rows of U fields GSM1F404.12
! *DIR$ CACHE_BYPASS D1 GPB0F405.203
DO I = 1,LEN_TOT GSM1F404.14
D1(I)=0.0 GSM1F404.15
ENDDO GSM1F404.16
*ENDIF GSM1F404.17
C Determine no of fields to be read in @DYALLOC.1556
IF (L_A_PROG_ONLY) THEN @DYALLOC.1557
@DYALLOC.1558
C Prognostic fields only @DYALLOC.1559
LEN2_LOOKUP = N_PROG_FLDS GDR2F304.35
LEN_PROG = A_PROG_LEN GDR5F400.30
TOT_LEN_DATA = A_LEN_DATA GDR5F400.31
*IF DEF,SLAB GDR5F400.32
! Get total length of prognostic data GDR5F400.33
LEN_PROG = A_PROG_LEN + S_PROG_LEN GDR5F400.34
TOT_LEN_DATA = A_LEN_DATA + S_LEN_DATA GDR5F400.35
GDR5F400.36
write (6,*) ' ' GDR5F400.37
write (6,*) ' n_prog_lookup = ',n_prog_lookup GDR5F400.38
write (6,*) ' len_prog = ',len_prog GDR5F400.39
write (6,*) ' tot_len_data = ',tot_len_data GDR5F400.40
GDR5F400.41
*ENDIF GDR5F400.42
GDR5F400.43
LEN_DATA = LEN_PROG GDR5F400.44
@DYALLOC.1562
WRITE (6,*) ' ' GDR2F304.36
WRITE (6,*) ' Read in ',N_PROG_FLDS,' prognostic fields.' GDR2F304.37
@DYALLOC.1566
GSM1F404.18
C INITIALISE DIAGNOSTIC AREA OF D1 TO RMDI @DYALLOC.1567
DO I = LEN_DATA+1, TOT_LEN_DATA GDR5F400.45
D1(I)=RMDI @DYALLOC.1569
END DO @DYALLOC.1570
@DYALLOC.1571
ELSE @DYALLOC.1572
@DYALLOC.1573
C All fields. @DYALLOC.1574
LEN2_LOOKUP = A_LEN2_LOOKUP @DYALLOC.1575
LEN_DATA = A_LEN_DATA @DYALLOC.1576
@DYALLOC.1577
WRITE (6,*) ' ' GDR2F304.38
WRITE (6,*) ' Read in all ',LEN2_LOOKUP,' fields.' GDR5F400.46
@DYALLOC.1581
ENDIF @DYALLOC.1582
INITDUM1.84
*IF DEF,SLAB GDR5F400.47
write (6,*) ' ' GDR5F400.48
write (6,*) ' a_prog_lookup = ',a_prog_lookup GDR5F400.49
write (6,*) ' s_prog_lookup = ',s_prog_lookup GDR5F400.50
write (6,*) ' a_len2_lookup = ',a_len2_lookup GDR5F400.51
write (6,*) ' s_len2_lookup = ',s_len2_lookup GDR5F400.52
write (6,*) ' a_prog_len = ',a_prog_len GDR5F400.53
write (6,*) ' s_prog_len = ',s_prog_len GDR5F400.54
write (6,*) ' a_len_data = ',a_len_data GDR5F400.55
write (6,*) ' s_len_data = ',s_len_data GDR5F400.56
write (6,*) ' len_data = ',len_data GDR5F400.57
*ENDIF GDR5F400.58
*IF DEF,MPP GRR0F403.4
! Ensure that domain decomposition is consistent with submodel GRR0F403.5
GRR0F403.6
CALL CHANGE_DECOMPOSITION(decomp_standard_atmos,ICODE) GRR0F403.7
GRR0F403.8
*ENDIF GRR0F403.9
GDR5F400.59
CL 1.2 Call READDUMP to read atmosphere dump. INITDUM1.93
IF (LTIMER) THEN INITDUM1.94
CALL TIMER('READDUMP',3) INITDUM1.95
INITDUM1.96
END IF INITDUM1.97
INITDUM1.98
GPB4F403.31
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(atmos_sm) GPB4F403.32
GPB4F403.33
CALL UM_READDUMP(NFTIN, A_FIXHD, LEN_FIXHD, GPB4F403.34
& A_INTHD, A_LEN_INTHD, INITDUM1.100
& A_REALHD, A_LEN_REALHD, INITDUM1.101
& A_LEVDEPC, A_LEN1_LEVDEPC, A_LEN2_LEVDEPC, INITDUM1.102
& A_ROWDEPC, A_LEN1_ROWDEPC, A_LEN2_ROWDEPC, INITDUM1.103
& A_COLDEPC, A_LEN1_COLDEPC, A_LEN2_COLDEPC, INITDUM1.104
& A_FLDDEPC, A_LEN1_FLDDEPC, A_LEN2_FLDDEPC, INITDUM1.105
& A_EXTCNST, A_LEN_EXTCNST, INITDUM1.106
& A_DUMPHIST, LEN_DUMPHIST, INITDUM1.107
& A_CFI1, A_LEN_CFI1, INITDUM1.108
& A_CFI2, A_LEN_CFI2, INITDUM1.109
& A_CFI3, A_LEN_CFI3, INITDUM1.110
& A_LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.72
*IF DEF,MPP GSM1F403.73
& A_MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.74
*ENDIF GPB0F401.50
& atmos_sm, GPB4F403.35
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.36
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.37
& LEN_DATA,D1, GDG0F401.810
*CALL ARGPPX GDG0F401.811
& .TRUE.,ICODE,CMESSAGE) GKR3F403.20
*IF DEF,MPP GPB0F401.205
! Broadcast return code to all processors. GPB0F401.206
CALL GC_IBCAST(666,1,0,nproc,info,ICODE) GPB0F401.207
*ENDIF GPB0F401.208
INITDUM1.114
IF (LTIMER) THEN INITDUM1.115
CALL TIMER('READDUMP',4) INITDUM1.116
INITDUM1.117
END IF INITDUM1.118
INITDUM1.119
CALL FILE_CLOSE(NFTIN,FT_ENVIRON(NFTIN), GGH1F305.5
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) GTD0F400.5
INITDUM1.121
IF (ICODE .GT. 0) RETURN INITDUM1.122
INITDUM1.123
C Check validity of integer header data and print out information. INITDUM1.124
*IF -DEF,MPP GPB0F305.75
CALL PR_INHDA (A_INTHD, A_LEN_INTHD, ROW_LENGTH, INITDUM1.125
& P_ROWS, P_LEVELS, Q_LEVELS, TR_LEVELS, AJS1F401.1563
& ST_LEVELS, SM_LEVELS, BL_LEVELS, AJS1F401.1564
& TR_VARS, ICODE, CMESSAGE) GDR6F405.15
*ELSE GPB0F305.76
! Pass through the global numbers so the validity check works GPB0F305.77
! glsize(1) is the global ROW_LENGTH GPB0F305.78
! glsize(2) is the global P_ROWS GPB0F305.79
CALL PR_INHDA (A_INTHD, A_LEN_INTHD, glsize(1), GPB0F305.80
& glsize(2),P_LEVELS,Q_LEVELS,TR_LEVELS, AJS1F401.1565
& ST_LEVELS, SM_LEVELS, BL_LEVELS, AJS1F401.1566
& TR_VARS, ICODE, CMESSAGE) GDR6F405.16
*ENDIF GPB0F305.83
INITDUM1.128
IF (ICODE.GT.0) RETURN @DYALLOC.1585
INITDUM1.129
C Check validity of real header data and print out information. @DYALLOC.1586
CALL PR_REHDA (A_REALHD, A_LEN_REALHD) @DYALLOC.1587
INITDUM1.130
IF (ICODE.GT.0) RETURN INITDUM1.131
INITDUM1.132
IF (L_A_PROG_ONLY) THEN @DYALLOC.1588
INITDUM1.135
*IF -DEF,MPP GPB0F401.51
CALL ADDRESS_CHECK (A_LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GDR8F400.38
*ELSE GPB0F401.52
C Need to pass field address and length info to ADDRESS_CHECK GSM1F403.75
DO I=1,LEN2_LOOKUP GSM1F403.76
A_MPP_ADDR(I) = A_MPP_LOOKUP(P_NADDR,I) GSM1F403.77
A_MPP_LEN(I) = A_MPP_LOOKUP(P_LBLREC,I) GSM1F403.78
ENDDO GSM1F403.79
CALL ADDRESS_CHECK (A_LOOKUP,A_MPP_ADDR, GSM1F403.80
& A_MPP_LEN,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.81
*ENDIF GPB0F401.55
& SI,NITEMS,NSECTS,LEN_DATA, GDR8F400.39
*CALL ARGPPX GSS1F305.483
& ICODE,CMESSAGE) WRB1F401.255
IF (ICODE.GT.0) RETURN @DYALLOC.1592
INITDUM1.136
ENDIF @DYALLOC.1593
@DYALLOC.1594
C Reset A_FIXHD to correspond to Output Dump @DYALLOC.1595
A_FIXHD(152) = A_LEN2_LOOKUP @DYALLOC.1596
A_FIXHD(160) = A_FIXHD(150) + LEN1_LOOKUP*A_LEN2_LOOKUP @DYALLOC.1597
*IF -DEF,MPP GPB0F305.84
A_FIXHD(161) = A_LEN_DATA @DYALLOC.1598
*ELSE GPB0F305.85
A_FIXHD(161) = global_A_LEN_DATA GPB1F402.320
*ENDIF GPB0F305.87
INITDUM1.138
CL 1.3 Call SET_ATM_POINTERS to set integer pointers to data in INITDUM1.139
CL atmosphere dump and secondary storage area in D1 array. INITDUM1.140
CALL SET_ATM_POINTERS( @DYALLOC.1599
*CALL ARGSIZE @DYALLOC.1600
*CALL ARGDUMA @DYALLOC.1601
*CALL ARGSTS @DYALLOC.1602
*CALL ARGPTRA @DYALLOC.1603
& ICODE,CMESSAGE) @DYALLOC.1604
INITDUM1.144
CL Call READLSTA to read namelists to control atmosphere integration INITDUM1.145
CL and diagnostic point print. INITDUM1.146
REWIND 5 INITDUM1.147
CALL READLSTA( @DYALLOC.1605
*CALL ARGSIZE @DYALLOC.1606
*CALL ARGDUMA @DYALLOC.1607
*CALL ARGPTRA @DYALLOC.1610
*CALL ARGCONA @DYALLOC.1611
& ICODE,CMESSAGE) @DYALLOC.1612
INITDUM1.149
IF (ICODE.GT.0) RETURN INITDUM1.150
INITDUM1.151
IF (LSINGLE_HYDROL) THEN GDR6F405.17
JEXP_PTR = JEAGLE_EXP ! Eagleson's Exponent GDR6F405.18
ENDIF GDR6F405.19
IF (LMOSES) THEN GDR6F405.20
JEXP_PTR = JCLAPP_HORN ! Clapp-Hornberger B Coefficient GDR6F405.21
ENDIF GDR6F405.22
CL 1.5 Call SETCONA to initialise additional fields for atmosphere INITDUM1.152
CL model using dump information. INITDUM1.153
CALL SETCONA(A_LEVDEPC(JAK),A_LEVDEPC(JBK), INITDUM1.154
& A_LEVDEPC(JDELTA_AK),A_LEVDEPC(JDELTA_BK),D1(JPSTAR), INITDUM1.155
& D1(JTHETA(1)),D1(JQ(1)),RHCRIT, ADR1F305.101
& D1(JSAT_SOIL_COND),D1(JVOL_SMC_SAT),D1(JVOL_SMC_WILT), GDR6F405.23
& D1(JEXP_PTR), D1(JLAND), L_LSPICE, GDR6F405.24
& D1(JRHC(1)), D1(JICE_FRACTION), BL_LEVELS, L_RHCPT, ASK1F405.41
& P_FIELD,P_LEVELS,P_ROWS,U_ROWS,U_FIELD,ROW_LENGTH, INITDUM1.159
& LAND_FIELD,Q_LEVELS, INITDUM1.160
& A_REALHD(1),A_REALHD(2),A_REALHD(3),A_REALHD(4), INITDUM1.161
& A_REALHD(5),A_REALHD(6), INITDUM1.162
& L_OLD_PWTS, ATJ0F403.7
& AKH,BKH,AK_TO_THE_KAPPA,BK_TO_THE_KAPPA, INITDUM1.163
& AKH_TO_THE_KAPPA,BKH_TO_THE_KAPPA, INITDUM1.164
& COS_U_LATITUDE,SEC_U_LATITUDE,SIN_U_LATITUDE, GJT1F304.23
& TAN_U_LATITUDE, GJT1F304.24
& COS_P_LATITUDE,SEC_P_LATITUDE, INITDUM1.166
& SIN_LONGITUDE,COS_LONGITUDE,TRUE_LONGITUDE, INITDUM1.167
& F1,F2,F3,F3_P,TRIGS,IFAX,D1(JP_EXNER(1)), INITDUM1.168
& TWO_D_GRID_CORRECTION, INITDUM1.169
& D1(JQCL(1)),D1(JQCF(1)),SOILB,LAND_LIST,CLOUD_LEVELS, INITDUM1.170
& ETA_SPLIT,NUM_CLOUD_TYPES,LOW_BOT_LEVEL,LOW_TOP_LEVEL, INITDUM1.171
& MED_BOT_LEVEL,MED_TOP_LEVEL,HIGH_BOT_LEVEL,HIGH_TOP_LEVEL, INITDUM1.172
& ETA_MATRIX_INV,MATRIX_POLY_ORDER,ICODE,CMESSAGE) INITDUM1.173
INITDUM1.174
C Set ELF flag INITDUM1.175
ELF=(A_FIXHD(4).EQ.3.OR.A_FIXHD(4).EQ.103) INITDUM1.176
INITDUM1.177
END IF INITDUM1.178
INITDUM1.179
! Fill atmosphere stash array GKR0F400.60
GKR0F400.61
do i = 1, p_levels GKR0F400.62
a_spsts(a_ixsts(1) + i-1) = a_levdepc(jak + i-1) GKR0F400.63
a_spsts(a_ixsts(2) + i-1) = a_levdepc(jbk + i-1) GKR0F400.64
a_spsts(a_ixsts(3) + i-1) = akh(i) GKR0F400.65
a_spsts(a_ixsts(4) + i-1) = bkh(i) GKR0F400.66
a_spsts(a_ixsts(5) + i-1) = a_levdepc(jdelta_ak + i-1) GKR0F400.67
a_spsts(a_ixsts(6) + i-1) = a_levdepc(jdelta_bk + i-1) GKR0F400.68
end do GKR0F400.69
a_spsts(a_ixsts(3) + p_levels) = akh( p_levels+1) GKR0F400.70
a_spsts(a_ixsts(4) + p_levels) = bkh( p_levels+1) GKR0F400.71
GKR0F400.72
GKR0F400.73
a_spsts(a_ixsts(7)) = jp_exner(1) ! pexner GKR0F400.74
a_spsts(a_ixsts(8)) = jpstar ! pstar GKR0F400.75
GKR0F400.76
do i = 1, ROW_LENGTH * U_ROWS GKR0F400.77
a_spsts(a_ixsts(10)+ i-1) = COS_U_LATITUDE(i) GKR0F400.78
end do GKR0F400.79
GKR0F400.80
do i = 1, ROW_LENGTH * P_ROWS GKR0F400.81
a_spsts(a_ixsts(9)+ i-1) = COS_P_LATITUDE(i) GKR0F400.82
a_spsts(a_ixsts(11)+ i-1) = D1(JLAND + i-1) GKR0F400.83
end do GKR0F400.84
GKR0F400.85
*ENDIF INITDUM1.180
*IF DEF,OCEAN INITDUM1.181
INITDUM1.182
CL 2.0 Read ocean dump and initialise ocean model. INITDUM1.183
IF (sm_ident.EQ.ocean_sm) THEN WRB1F401.256
CL 2.1 Open unit for ocean dump and read in fixed length header @DYALLOC.1614
NFTIN=41 INITDUM1.186
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), GGH1F305.7
& LEN_FT_ENVIR(NFTIN),0,0,ERROR) GGH1F305.8
@DYALLOC.1615
CALL READ_FLH (NFTIN,O_FIXHD,LEN_FIXHD,ICODE,CMESSAGE) @DYALLOC.1616
IF (ICODE.GT.0) RETURN @DYALLOC.1617
@DYALLOC.1618
CALL SETPOS (NFTIN,0,ICODE) GTD0F400.89
@DYALLOC.1620
C Test if ocean dump. @DYALLOC.1621
L_O_DUMP = O_FIXHD(5).EQ.1 .AND. O_FIXHD(2).EQ.ocean_sm WRB1F401.257
@DYALLOC.1623
C Test if only prognostic fields to be read in @DYALLOC.1624
L_O_PROG_ONLY = L_O_DUMP .AND. H_STEPim(o_im).EQ.0 GDR3F305.140
@DYALLOC.1626
C Get no of prognostic fields in ocean dump GDR2F304.40
N_PROG_FLDS = O_FIXHD(153) GDR2F304.41
GDR2F304.42
C Check N_PROG_FLDS has been set. GDR2F304.43
IF (N_PROG_FLDS.EQ.IMDI) THEN GDR2F304.44
WRITE (6,*) ' ' GDR2F304.45
WRITE (6,*) ' No of prognostic fields not set in FIXHD(153)' GDR2F304.46
WRITE (6,*) ' Run RECONFIGURATION to set FIXHD(153)' GDR2F304.47
CMESSAGE = 'INITDUMP: FIXHD(153) not set in ocean dump' GDR2F304.48
ICODE = 201 GDR2F304.49
GO TO 9999 ! Return GDR2F304.50
ENDIF GDR2F304.51
GDR2F304.52
C Check N_PROG_FLDS matches with O_PROG_LOOKUP set up by the UI GDR2F304.53
IF (N_PROG_FLDS.NE.O_PROG_LOOKUP) THEN GDR2F304.54
WRITE (6,*) ' ' GDR2F304.55
WRITE (6,*) ' Mismatch in no of prognostic fields.' GDR2F304.56
WRITE (6,*) ' No of prog fields in ocean dump ',N_PROG_FLDS GDR2F304.57
WRITE (6,*) ' No of prog fields set up by UI ',O_PROG_LOOKUP GDR2F304.58
WRITE (6,*) ' ' GDR2F304.59
WRITE (6,*) ' Run RECONFIGURATION to get correct no of', GDR2F304.60
& ' prognostic fields in ocean dump' GDR2F304.61
WRITE (6,*) ' or' GDR2F304.62
WRITE (6,*) ' Check/Reset experiment in User Interface' GDR2F304.63
WRITE (6,*) ' ' GDR2F304.64
CMESSAGE = 'INITDUMP: Wrong no of ocean prognostic fields' GDR2F304.65
ICODE = 202 GDR2F304.66
GO TO 9999 ! Return GDR2F304.67
ENDIF GDR2F304.68
GDR2F304.69
*IF DEF,MPP GSM1F404.19
! Initialise D1 to 0 to prevent NaNs in halos GSM1F404.20
! *DIR$ CACHE_BYPASS D1 GPB0F405.204
DO I = 1,LEN_TOT GSM1F404.22
D1(I)=0.0 GSM1F404.23
ENDDO GSM1F404.24
*ENDIF GSM1F404.25
C Set up no of fields to be read in @DYALLOC.1627
IF (L_O_PROG_ONLY) THEN @DYALLOC.1628
@DYALLOC.1629
C Prognostic fields only @DYALLOC.1630
LEN2_LOOKUP = N_PROG_FLDS GDR2F304.70
LEN_DATA = O_PROG_LEN @DYALLOC.1632
@DYALLOC.1633
WRITE (6,*) ' ' GDR2F304.71
WRITE (6,*) ' Read in ',N_PROG_FLDS,' prognostic fields.' GDR2F304.72
@DYALLOC.1637
C INITIALISE DIAGNOSTIC AREA OF D1 TO RMDI GSM7F403.7
DO I=LEN_DATA+1,O_LEN_DATA @DYALLOC.1639
D1(I)=RMDI @DYALLOC.1640
END DO @DYALLOC.1641
@DYALLOC.1642
ELSE @DYALLOC.1643
@DYALLOC.1644
C All fields. @DYALLOC.1645
LEN2_LOOKUP = O_LEN2_LOOKUP @DYALLOC.1646
LEN_DATA = O_LEN_DATA @DYALLOC.1647
@DYALLOC.1648
WRITE (6,*) ' ' GDR2F304.73
WRITE (6,*) ' Read in all ',O_LEN2_LOOKUP,' fields.' GDR2F304.74
@DYALLOC.1652
ENDIF @DYALLOC.1653
@DYALLOC.1654
*IF DEF,MPP GRR0F403.10
! Ensure that domain decomposition is consistent with submodel GRR0F403.11
GRR0F403.12
CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GRR0F403.13
GRR0F403.14
*ENDIF GRR0F403.15
CL 2.2 Call READ DUMP to read ocean dump. INITDUM1.192
INITDUM1.193
IF (LTIMER) THEN INITDUM1.194
CALL TIMER('READDUMP',3) INITDUM1.195
INITDUM1.196
END IF INITDUM1.197
INITDUM1.198
GPB4F403.38
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(ocean_sm) GPB4F403.39
GPB4F403.40
CALL UM_READDUMP(NFTIN,O_FIXHD,LEN_FIXHD, GPB4F403.41
& O_INTHD,O_LEN_INTHD, INITDUM1.200
& O_REALHD,O_LEN_REALHD, INITDUM1.201
& O_LEVDEPC,O_LEN1_LEVDEPC,O_LEN2_LEVDEPC, INITDUM1.202
& O_ROWDEPC,O_LEN1_ROWDEPC,O_LEN2_ROWDEPC, INITDUM1.203
& O_COLDEPC,O_LEN1_COLDEPC,O_LEN2_COLDEPC, INITDUM1.204
& O_FLDDEPC,O_LEN1_FLDDEPC,O_LEN2_FLDDEPC, INITDUM1.205
& O_EXTCNST,O_LEN_EXTCNST, INITDUM1.206
& O_DUMPHIST,LEN_DUMPHIST, INITDUM1.207
& O_CFI1,O_LEN_CFI1, INITDUM1.208
& O_CFI2,O_LEN_CFI2, INITDUM1.209
& O_CFI3,O_LEN_CFI3, INITDUM1.210
& O_LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, @DYALLOC.1656
*IF DEF,MPP GSM1F403.82
& O_MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.83
*ENDIF GPB0F401.60
& ocean_sm, GPB4F403.42
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.43
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.44
& LEN_DATA,D1, GDG0F401.813
*CALL ARGPPX GDG0F401.814
& .TRUE.,ICODE,CMESSAGE) GKR3F403.21
INITDUM1.214
INITDUM1.215
IF (LTIMER) THEN INITDUM1.216
CALL TIMER('READDUMP',4) INITDUM1.217
INITDUM1.218
END IF INITDUM1.219
INITDUM1.220
CALL FILE_CLOSE(NFTIN,FT_ENVIRON(NFTIN), GGH1F305.9
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) GTD0F400.6
INITDUM1.222
IF (ICODE.GT.0) RETURN @DYALLOC.1658
@DYALLOC.1659
IF (L_O_PROG_ONLY) THEN @DYALLOC.1660
@DYALLOC.1661
*IF -DEF,MPP GPB0F401.61
CALL ADDRESS_CHECK (O_LOOKUP,LEN1_LOOKUP,O_PROG_LOOKUP, @DYALLOC.1662
*ELSE GPB0F401.62
C Need to pass field address and length info to ADDRESS_CHECK GSM1F403.84
DO I=1,LEN2_LOOKUP GSM1F403.85
O_MPP_ADDR(I) = O_MPP_LOOKUP(P_NADDR,I) GSM1F403.86
O_MPP_LEN(I) = O_MPP_LOOKUP(P_LBLREC,I) GSM1F403.87
ENDDO GSM1F403.88
CALL ADDRESS_CHECK (O_LOOKUP,O_MPP_ADDR, GSM1F403.89
& O_MPP_LEN,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.90
*ENDIF GPB0F401.65
& SI,NITEMS,NSECTS,O_PROG_LEN, @DYALLOC.1663
*CALL ARGPPX GSS1F305.485
& ICODE,CMESSAGE) WRB1F401.258
IF (ICODE.GT.0) RETURN @DYALLOC.1665
@DYALLOC.1666
ENDIF @DYALLOC.1667
@DYALLOC.1668
C Reset O_FIXHD to correspond to Output Dump @DYALLOC.1669
O_FIXHD(152) = O_LEN2_LOOKUP @DYALLOC.1670
O_FIXHD(160) = O_FIXHD(150) + LEN1_LOOKUP*O_LEN2_LOOKUP @DYALLOC.1671
*IF DEF,MPP ORH6F402.1
O_FIXHD(161) = global_O_LEN_DATA GPB0F403.16
*ELSE ORH6F402.3
O_FIXHD(161) = O_LEN_DATA @DYALLOC.1672
*ENDIF ORH6F402.4
ORH6F402.5
@DYALLOC.1673
CL 2.3 Call SET_OCEAN_POINTERS to set integer pointers to ocean INITDUM1.223
CL data in dump and D1 array. INITDUM1.224
INITDUM1.225
CALL SET_OCN_POINTERS ( @DYALLOC.1674
*CALL ARGSIZE @DYALLOC.1675
*CALL ARGPTRO @DYALLOC.1676
*CALL ARGSTS @DYALLOC.1677
*CALL ARGDUMO @DYALLOC.1678
& ICODE, CMESSAGE) @DYALLOC.1679
INITDUM1.227
INITDUM1.228
IF (LTIMER) THEN INITDUM1.229
CALL TIMER('NLIST ',3) INITDUM1.230
INITDUM1.231
END IF INITDUM1.232
INITDUM1.233
CALL READNLST_OCEAN( @DYALLOC.1680
*CALL ARGSIZE @DYALLOC.1681
*CALL ARGOCTOP @DYALLOC.1682
& ICODE, CMESSAGE, O_EXTCNST) @DYALLOC.1683
INITDUM1.235
IF (LTIMER) THEN INITDUM1.236
CALL TIMER('NLIST ',4) INITDUM1.237
INITDUM1.238
END IF INITDUM1.239
INITDUM1.240
IF (LTIMER) THEN INITDUM1.241
CALL TIMER('CONFIG ',3) INITDUM1.242
INITDUM1.243
END IF INITDUM1.244
INITDUM1.245
CALL SET_CONSTANTS_OCEAN( @DYALLOC.1684
*CALL ARGSIZE @DYALLOC.1685
*CALL ARGOCTOP @DYALLOC.1686
& ICODE, CMESSAGE, O_REALHD(7),O_LEVDEPC,O_ROWDEPC, @DYALLOC.1687
& O_REALHD(5),O_REALHD(8), INITDUM1.247
& O_COLDEPC,O_FLDDEPC,O_SPSTS(O_IXSTS(11)) ORH2F405.14
&,IMT_CLN,JMT_CLN,IMT_BIO, ORH2F405.15
& ltimer) ORH1F305.4759
INITDUM1.249
IF (LTIMER) THEN INITDUM1.250
CALL TIMER('CONFIG ',4) INITDUM1.251
INITDUM1.252
END IF INITDUM1.253
SI061093.32
IF (ICODE.GT.0) RETURN SI061093.33
INITDUM1.254
GKR0F400.86
! Fill ocean stash array. joc_tracer, joc_u and joc_v are not OKR1F402.19
! set here because they are set every timestep in OCN_FOR_STEP. OKR1F402.20
GKR0F400.88
o_spsts(o_ixsts(4)) = JOC_NO_SEAPTS GKR0F400.98
o_spsts(o_ixsts(5)) = JOC_NO_SEGS GKR0F400.99
GKR0F400.100
do i = 1, o_len_cfi1 GKR0F400.101
o_spsts(o_ixsts(6)+i-1) = O_CFI1(i) GKR0F400.102
end do GKR0F400.103
GKR0F400.104
do i = 1, o_len_cfi2 GKR0F400.105
o_spsts(o_ixsts(7)+i-1) = O_CFI2(i) GKR0F400.106
end do GKR0F400.107
GKR0F400.108
do i = 1, o_len_cfi3 GKR0F400.109
o_spsts(o_ixsts(8)+i-1) = O_CFI3(i) GKR0F400.110
end do GKR0F400.111
GKR0F400.112
IF (CYCLIC_OCEAN) THEN GKR0F400.113
ocnrow_length=IMTM2 GKR0F400.114
ELSE GKR0F400.115
ocnrow_length=IMT GKR0F400.116
ENDIF GKR0F400.117
o_spsts(o_ixsts(9)) = ocnrow_length * jmt * km GKR0F400.118
GKR0F400.119
GKR0F400.120
INITDUM1.269
IF (ICODE .NE. 0) RETURN INITDUM1.270
INITDUM1.271
C Copy ocean data for forward timestep on startup INITDUM1.272
CALL DATASWAP (O_LEN_DUALDATA, OSI0F402.4
& D1(joc_tracer(1,2)), D1(joc_tracer(1,1))) INITDUM1.274
INITDUM1.275
END IF WRB1F401.259
WRB1F401.260
*ENDIF WRB1F401.261
*IF DEF,WAVE WRB1F401.262
WRB1F401.263
CL 4.0 Read wave dump and initialise wave model. WRB1F401.264
IF (sm_ident.EQ.wave_sm) THEN WRB1F401.265
CL 4.1 Open unit for wave dump and read in fixed length header WRB1F401.266
NFTIN=131 WRB1F401.267
CALL FILE_OPEN(NFTIN,FT_ENVIRON(NFTIN), WRB1F401.268
& LEN_FT_ENVIR(NFTIN),0,0,ERROR) WRB1F401.269
WRB1F401.270
CALL READ_FLH (NFTIN,W_FIXHD,LEN_FIXHD,ICODE,CMESSAGE) WRB1F401.271
IF (ICODE.GT.0) RETURN WRB1F401.272
WRB1F401.273
CALL SETPOS (NFTIN,0,ICODE) WRB1F401.274
WRB1F401.275
C Test if wave dump. WRB1F401.276
L_W_DUMP = W_FIXHD(5).EQ.1 .AND. W_FIXHD(2).EQ.wave_sm WRB1F401.277
WRB1F401.278
C Test if only prognostic fields to be read in WRB1F401.279
L_W_PROG_ONLY = L_W_DUMP .AND. H_STEPim(w_im).EQ.0 WRB1F401.280
WRB1F401.281
C Get no of prognostic fields in ocean dump WRB1F401.282
N_PROG_FLDS = W_FIXHD(153) WRB1F401.283
WRB1F401.284
C Check N_PROG_FLDS has been set. WRB1F401.285
IF (N_PROG_FLDS.EQ.IMDI) THEN WRB1F401.286
WRITE (6,*) ' ' WRB1F401.287
WRITE (6,*) ' No of prognostic fields not set in FIXHD(153)' WRB1F401.288
WRITE (6,*) ' Remake Wave dump to set FIXHD(153)' WRB1F401.289
CMESSAGE = 'INITDUMP: FIXHD(153) not set in wave dump' WRB1F401.290
ICODE = 201 WRB1F401.291
GO TO 9999 ! Return WRB1F401.292
ENDIF WRB1F401.293
WRB1F401.294
C Check N_PROG_FLDS matches with W_PROG_LOOKUP set up by the UI WRB1F401.295
IF (N_PROG_FLDS.NE.W_PROG_LOOKUP) THEN WRB1F401.296
WRITE (6,*) ' ' WRB1F401.297
WRITE (6,*) ' Mismatch in no of prognostic fields.' WRB1F401.298
WRITE (6,*) ' No of prog fields in wave dump ',N_PROG_FLDS WRB1F401.299
WRITE (6,*) ' No of prog fields set up by UI ',W_PROG_LOOKUP WRB1F401.300
WRITE (6,*) ' ' WRB1F401.301
WRITE (6,*) ' Remake wave dump to get correct no of', WRB1F401.302
& ' prognostic fields' WRB1F401.303
WRITE (6,*) ' or' WRB1F401.304
WRITE (6,*) ' Check/Reset experiment in User Interface' WRB1F401.305
WRITE (6,*) ' ' WRB1F401.306
CMESSAGE = 'INITDUMP: Wrong no of wave prognostic fields' WRB1F401.307
ICODE = 202 WRB1F401.308
GO TO 9999 ! Return WRB1F401.309
ENDIF WRB1F401.310
WRB1F401.311
C Set up no of fields to be read in WRB1F401.312
IF (L_W_PROG_ONLY) THEN WRB1F401.313
WRB1F401.314
C Prognostic fields only WRB1F401.315
LEN2_LOOKUP = N_PROG_FLDS WRB1F401.316
LEN_DATA = W_PROG_LEN WRB1F401.317
WRB1F401.318
WRITE (6,*) ' ' WRB1F401.319
WRITE (6,*) ' Read in ',N_PROG_FLDS,' prognostic fields.' WRB1F401.320
WRB1F401.321
C Initialise diagnostic area of D1 to RMDI WRB1F401.322
DO I=LEN_DATA+1,O_LEN_DATA WRB1F401.323
D1(I)=RMDI WRB1F401.324
END DO WRB1F401.325
WRB1F401.326
ELSE WRB1F401.327
WRB1F401.328
C All fields. WRB1F401.329
LEN2_LOOKUP = W_LEN2_LOOKUP WRB1F401.330
LEN_DATA = W_LEN_DATA WRB1F401.331
WRB1F401.332
WRITE (6,*) ' ' WRB1F401.333
WRITE (6,*) ' Read in all ',W_LEN2_LOOKUP,' fields.' WRB1F401.334
WRB1F401.335
ENDIF WRB1F401.336
WRB1F401.337
CL 4.2 Call READ DUMP to read wave dump. WRB1F401.338
WRB1F401.339
IF (LTIMER) THEN WRB1F401.340
CALL TIMER('READDUMP',3) WRB1F401.341
WRB1F401.342
END IF WRB1F401.343
WRB1F401.344
GPB4F403.45
D1_ADDR_SUBMODEL_ID = SUBMODEL_FOR_SM(wave_sm) GPB4F403.46
GPB4F403.47
CALL UM_READDUMP(NFTIN,W_FIXHD,LEN_FIXHD, GPB4F403.48
& W_INTHD,W_LEN_INTHD, WRB1F401.346
& W_REALHD,W_LEN_REALHD, WRB1F401.347
& W_LEVDEPC,W_LEN1_LEVDEPC,W_LEN2_LEVDEPC, WRB1F401.348
& W_ROWDEPC,W_LEN1_ROWDEPC,W_LEN2_ROWDEPC, WRB1F401.349
& W_COLDEPC,W_LEN1_COLDEPC,W_LEN2_COLDEPC, WRB1F401.350
& W_FLDDEPC,W_LEN1_FLDDEPC,W_LEN2_FLDDEPC, WRB1F401.351
& W_EXTCNST,W_LEN_EXTCNST, WRB1F401.352
& W_DUMPHIST,LEN_DUMPHIST, WRB1F401.353
& W_CFI1,W_LEN_CFI1, WRB1F401.354
& W_CFI2,W_LEN_CFI2, WRB1F401.355
& W_CFI3,W_LEN_CFI3, WRB1F401.356
& w_LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, WRB1F401.357
& wave_sm, GPB4F403.49
& NO_OBJ_D1(D1_ADDR_SUBMODEL_ID), GPB4F403.50
& D1_ADDR(1,1,D1_ADDR_SUBMODEL_ID), GPB4F403.51
& LEN_DATA,D1, WRB1F401.358
*CALL ARGPPX WRB1F401.359
& .TRUE.,ICODE,CMESSAGE) GKR3F403.22
WRB1F401.361
WRB1F401.365
IF (LTIMER) THEN WRB1F401.366
CALL TIMER('READDUMP',4) WRB1F401.367
WRB1F401.368
END IF WRB1F401.369
WRB1F401.370
CALL FILE_CLOSE(NFTIN,FT_ENVIRON(NFTIN), WRB1F401.371
& LEN_FT_ENVIR(NFTIN),0,0,ICODE) WRB1F401.372
WRB1F401.373
IF (ICODE.GT.0) RETURN WRB1F401.374
WRB1F401.375
IF (L_W_PROG_ONLY) THEN WRB1F401.376
WRB1F401.377
CALL ADDRESS_CHECK (W_LOOKUP,LEN1_LOOKUP,W_PROG_LOOKUP, WRB1F401.378
& SI,NITEMS,NSECTS,W_PROG_LEN, WRB1F401.379
*CALL ARGPPX WRB1F401.380
& ICODE,CMESSAGE) WRB1F401.381
IF (ICODE.GT.0) RETURN WRB1F401.382
WRB1F401.383
ENDIF WRB1F401.384
WRB1F401.385
C Reset W_FIXHD to correspond to Output Dump WRB1F401.386
W_FIXHD(152) = W_LEN2_LOOKUP WRB1F401.387
W_FIXHD(160) = W_FIXHD(150) + LEN1_LOOKUP*W_LEN2_LOOKUP WRB1F401.388
W_FIXHD(161) = W_LEN_DATA WRB1F401.389
WRB1F401.390
CL 4.3 Call SET_WAVE_POINTERS to set integer pointers to wave WRB1F401.391
CL data in dump and D1 array. WRB1F401.392
WRB1F401.393
CALL SET_WAV_POINTERS ( WRB1F401.394
*CALL ARGSIZE WRB1F401.395
*CALL ARGDUMW WRB1F401.396
*CALL ARGSTS WRB1F401.397
*CALL ARGPTRW WRB1F401.398
& ICODE, CMESSAGE) WRB1F401.399
WRB1F401.400
WRB1F401.401
CALL SET_CONSTANTS_WAV( WRB1F401.402
*CALL ARGSIZE WRB1F401.403
*CALL ARGD1 WRB1F401.404
*CALL ARGDUMW WRB1F401.405
*CALL ARGPTRW WRB1F401.406
*CALL ARGCONW WRB1F401.407
& ICODE, CMESSAGE) WRB1F401.408
WRB1F401.409
WRB1F401.410
IF (ICODE.GT.0) RETURN WRB1F401.411
WRB1F401.412
WRB1F401.413
! Fill wave stash array WRB1F401.414
WRB1F401.415
do i = 1, NGX * NGY WRB1F401.416
w_spsts(w_ixsts(1)+ i-1) = D1(jwv_lsmask + i-1) !land sea mask WRB1F401.417
end do WRB1F401.418
WRB1F401.419
w_spsts(w_ixsts(2)) = ngx*ngy ! size of fie WRB1F401.420
w_spsts(w_ixsts(3)) = 0 ! dummy WRB1F401.421
w_spsts(w_ixsts(4)) = 0 ! dummy WRB1F401.422
w_spsts(w_ixsts(5)) = 0 ! dummy WRB1F401.423
w_spsts(w_ixsts(6)) = 0 ! dummy WRB1F401.424
w_spsts(w_ixsts(7)) = 0 ! dummy WRB1F401.425
w_spsts(w_ixsts(8)) = 0 ! dummy WRB1F401.426
w_spsts(w_ixsts(9)) = 0 ! dummy WRB1F401.427
w_spsts(w_ixsts(10)) = 0 ! dummy WRB1F401.428
w_spsts(w_ixsts(11)) = 0 ! dummy WRB1F401.429
WRB1F401.430
! WRB1F401.431
END IF INITDUM1.276
INITDUM1.277
*ENDIF INITDUM1.278
INITDUM1.279
INITDUM1.280
GDR2F304.75
9999 CONTINUE GDR2F304.76
INITDUM1.285
RETURN INITDUM1.286
END INITDUM1.287
INITDUM1.288
INITDUM1.289
*ENDIF INITDUM1.290