SUBROUTINE CONTROL(LEN_FIXHD_IN,LEN_INTHD_IN,LEN_REALHD_IN, 2,308CONTROL1.23
& LEN1_LEVDEPC_IN,LEN2_LEVDEPC_IN,LEN1_ROWDEPC_IN, CONTROL1.24
& LEN2_ROWDEPC_IN,LEN1_COLDEPC_IN,LEN2_COLDEPC_IN, CONTROL1.25
& LEN1_FLDDEPC_IN,LEN2_FLDDEPC_IN,LEN_EXTCNST_IN,OZONE_LEVELS_IN, CONTROL1.26
& LEN_DUMPHIST_IN,LEN_CFI1_IN,LEN_CFI2_IN,LEN_CFI3_IN, CONTROL1.27
& LEN1_LOOKUP_IN,LEN2_LOOKUP_IN,LEN_DATA_IN,BL_LEVELS_IN CONTROL1.28
& ,ROW_LENGTH_IN,P_ROWS_IN,P_LEVELS_IN,Q_LEVELS_IN UJS1F401.4
& ,ST_LEVELS_IN,SM_LEVELS_IN UJS1F401.5
& ,MAX_VARIABLES_IN,P_FIELD_IN,U_ROWS_IN,U_FIELD_IN CONTROL1.30
& ,LEN_FIXHD_OUT,LEN_INTHD_OUT,LEN_REALHD_OUT,TR_LEVELS_ADV_OUT, CONTROL1.31
& LEN1_LEVDEPC_OUT,LEN2_LEVDEPC_OUT,LEN1_ROWDEPC_OUT, CONTROL1.32
& LEN2_ROWDEPC_OUT,LEN1_COLDEPC_OUT,LEN2_COLDEPC_OUT, CONTROL1.33
& LEN1_FLDDEPC_OUT,LEN2_FLDDEPC_OUT,LEN_EXTCNST_OUT, CONTROL1.34
& LEN_DUMPHIST_OUT,LEN_CFI1_OUT,LEN_CFI2_OUT,LEN_CFI3_OUT, CONTROL1.35
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT,LEN_DATA_OUT CONTROL1.36
& ,ROW_LENGTH_OUT,P_ROWS_OUT,P_LEVELS_OUT,Q_LEVELS_OUT CONTROL1.37
& ,MAX_VARIABLES_OUT,P_FIELD_OUT,U_ROWS_OUT,U_FIELD_OUT CONTROL1.38
C UDG4F405.8
& ,FIXHD_OUT,INTHD_OUT,REALHD_OUT,LEVDEPC_OUT,ROWDEPC_OUT UDG4F405.9
& ,COLDEPC_OUT,FLDDEPC_OUT,EXTCNST_OUT,DUMPHIST_OUT,CFI1_OUT UDG4F405.10
& ,CFI2_OUT,CFI3_OUT,LOOKUP_OUT, UDG4F405.11
& PP_ITEMC_OUT,PP_POS_OUT,N_TYPES_OUT, UDG4F405.12
& PP_LEN_OUT,PP_NUM_OUT,PP_TYPE_OUT, UDG4F405.13
& AKH_OUT,BKH_OUT,LAND_POINTS_OUT UDG4F405.14
C UDG4F405.15
& ,TR_LEVELS_OUT,ST_LEVELS_OUT,SM_LEVELS_OUT,BL_LEVELS_OUT UJS1F401.6
& ,OZONE_LEVELS_OUT, TR_VARS_OUT GDR6F405.10
& ,LEN_INTHD_UARS,LEN_REALHD_UARS,LEN1_LEVDEPC_UARS CONTROL1.41
& ,LEN2_LEVDEPC_UARS,LEN2_LOOKUP_UARS,LEN_DATA_UARS,UARS CONTROL1.42
& ,GRIB,NFTIN,NFTOUT,NFTUARS,NLOOKUPS,LEN_ANCIL,STRAT_Q CONTROL1.43
&,RESET,OCEAN,NFTTRACER,NFTTRANS,TRANS AD221292.90
& ,LEN_INTHD_TRANS,LEN_REALHD_TRANS,LEN1_LEVDEPC_TRANS AD221292.91
& ,LEN2_LEVDEPC_TRANS,LEN2_LOOKUP_TRANS,LEN_DATA_TRANS AD221292.92
& ,LEN_INTHD_TRACER,LEN_REALHD_TRACER,LEN1_LEVDEPC_TRACER CONTROL1.45
& ,LEN2_LEVDEPC_TRACER,LEN2_LOOKUP_TRACER,LEN_DATA_TRACER CONTROL1.46
& ,NDATASETS,FTN_ANCIL,TITLE,PER_ARGS,PER_LEN,NFTPER AD150293.50
& ,PERTURBATION,C_GRID_IN,C_GRID_OUT,H_INT_TYPE,LPOLARCHK UDG4F402.3
& ,ANVIL_FACTOR,TOWER_FACTOR AJX1F404.16
& ,POINTS_PER_OCEAN_LEVEL,DUMP_PACK,LAND_POINTS_UMUI, UDG1F404.4
& RadialGridIn,RadialGridOut,NFTIN2,NFTIN3,RM_CP, UDG6F405.38
& len1_lookup_um,len2_lookup_um,fixhd_um, UIE2F401.5
& len1_lookup_ls,len2_lookup_ls,fixhd_ls, UIE2F401.6
*CALL ARGPPX 
UDG2F305.48
& LAMIPII_IN, GRS2F404.225
& LCAL360,LSPIRAL_S,LOZONE_ZONAL,L_MP_PRECIP) UDG4F404.13
CLL CONTROL1.48
CLL CONTROL1.49
CONTROL1.50
IMPLICIT NONE CONTROL1.51
CONTROL1.52
LOGICAL LCAL360 GSS1F304.277
LOGICAL LAMIPII_IN ! T= AMIP II run ice updating GRS2F404.226
LOGICAL LSPIRAL_S ! Switch for SPIRAL_S routine UDG2F305.50
! defining unresolved coastal points UDG2F305.51
LOGICAL LOZONE_ZONAL !T= Zonal ozone field UDG2F305.52
!F= Full ozone field UDG2F305.53
LOGICAL L_MP_PRECIP !T=Mixed phase precipitation chosen UDG4F404.14
!F=Standard precipitation chosen UDG4F404.15
GSS1F304.278
INTEGER CONTROL1.53
& LEN_FIXHD_IN !IN Length of fixed length header on input file CONTROL1.54
&,LEN_INTHD_IN !IN Length of integer header on input file CONTROL1.55
&,LEN_REALHD_IN !IN Length of real header on input file CONTROL1.56
&,LEN1_LEVDEPC_IN !IN 1st dim of lev dependent consts on input file CONTROL1.57
&,LEN2_LEVDEPC_IN !IN 2nd dim of lev dependent consts on input file CONTROL1.58
&,LEN1_ROWDEPC_IN !IN 1st dim of row dependent consts on input file CONTROL1.59
&,LEN2_ROWDEPC_IN !IN 2nd dim of row dependent consts on input file CONTROL1.60
&,LEN1_COLDEPC_IN !IN 1st dim of col dependent consts on input file CONTROL1.61
&,LEN2_COLDEPC_IN !IN 2nd dim of col dependent consts on input file CONTROL1.62
&,LEN1_FLDDEPC_IN !IN 1st dim of field dependent consts on input fi CONTROL1.63
&,LEN2_FLDDEPC_IN !IN 2nd dim of field dependent consts on input fi CONTROL1.64
&,LEN_EXTCNST_IN !IN Length of extra consts on input file CONTROL1.65
&,LEN_DUMPHIST_IN !IN Length of history header on input file CONTROL1.66
&,LEN_CFI1_IN !IN Length of index1 on input file CONTROL1.67
&,LEN_CFI2_IN !IN Length of index2 on input file CONTROL1.68
&,LEN_CFI3_IN !IN Length of index3 on input file CONTROL1.69
&,LEN1_LOOKUP_IN !IN 1st dim of LOOKUP on input file CONTROL1.70
&,LEN2_LOOKUP_IN !IN 2nd dim of LOOKUP on input file CONTROL1.71
&,LEN_DATA_IN !IN Length of data on input file CONTROL1.72
&,ROW_LENGTH_IN !IN No of points E-W on input file CONTROL1.73
&,P_ROWS_IN !IN No of p-rows on input file CONTROL1.74
&,P_LEVELS_IN !IN No of levels on input file CONTROL1.75
&,Q_LEVELS_IN !IN No of wet levels on input file CONTROL1.76
&,MAX_VARIABLES_IN!IN Maximum varaiables on input file CONTROL1.77
&,ST_LEVELS_IN !IN No of deep soil temp levels on input file UJS1F401.8
&,SM_LEVELS_IN !IN No of soil moisture levels on input file UJS1F401.9
&,BL_LEVELS_IN !IN No of b.l. levels on input file CONTROL1.79
&,OZONE_LEVELS_IN !IN No of ozone levels on input file CONTROL1.80
&,P_FIELD_IN !IN No of p-points per level on input file CONTROL1.81
&,U_ROWS_IN !IN No of uv-rows on input file CONTROL1.82
&,U_FIELD_IN !IN No of uv-points per level on input file CONTROL1.83
CONTROL1.84
INTEGER CONTROL1.85
& NFTIN, CONTROL1.86
& NFTOUT, CONTROL1.87
& NFTIN2, UIE2F401.7
& NFTIN3, UIE2F401.8
& NFTUARS, CONTROL1.88
& NFTTRANS, AD221292.93
& NFTTRACER, CONTROL1.89
& NFTPER, AD150293.52
& NLOOKUPS, CONTROL1.90
& LEN_ANCIL CONTROL1.91
CONTROL1.92
INTEGER CONTROL1.93
& FIXHD_IN(256), CONTROL1.94
& INTHD_IN(LEN_INTHD_IN), CONTROL1.95
& CFI1_IN(LEN_CFI1_IN+1),CFI2_IN(LEN_CFI2_IN+1), CONTROL1.96
& CFI3_IN(LEN_CFI3_IN+1), CONTROL1.97
& LOOKUP_IN(LEN1_LOOKUP_IN,LEN2_LOOKUP_IN), CONTROL1.98
& ID1_IN(P_FIELD_IN) CONTROL1.99
REAL CONTROL1.100
& REALHD_IN(LEN_REALHD_IN), CONTROL1.101
& LEVDEPC_IN(1+LEN1_LEVDEPC_IN*LEN2_LEVDEPC_IN), CONTROL1.102
& ROWDEPC_IN(1+LEN1_ROWDEPC_IN*LEN2_ROWDEPC_IN), CONTROL1.103
& COLDEPC_IN(1+LEN1_COLDEPC_IN*LEN2_COLDEPC_IN), CONTROL1.104
& FLDDEPC_IN(1+LEN1_FLDDEPC_IN*LEN2_FLDDEPC_IN), CONTROL1.105
& EXTCNST_IN(LEN_EXTCNST_IN+1), CONTROL1.106
& DUMPHIST_IN(LEN_DUMPHIST_IN+1) UDG4F405.16
& ,ANVIL_FACTOR AJX1F404.18
& ,TOWER_FACTOR AJX1F404.19
CONTROL1.109
INTEGER CONTROL1.110
* ROW_LENGTH_OUT !IN No of points E-W (output) CONTROL1.111
*,P_ROWS_OUT !IN No of P-points N-S (output) CONTROL1.112
*,P_LEVELS_OUT !IN No of levels (output) CONTROL1.113
*,Q_LEVELS_OUT !IN No of wet levels (output) CONTROL1.114
*,ST_LEVELS_OUT !IN No of deep soil temp levels (output) UJS1F401.10
*,SM_LEVELS_OUT !IN No of soil moisture levels (output) UJS1F401.11
*,TR_LEVELS_OUT !IN No of tracer levels (output) CONTROL1.116
*,TR_LEVELS_ADV_OUT !IN No of tracer levels to be adv'ted (output) CONTROL1.117
*,BL_LEVELS_OUT !IN No of b.l. levels (output) CONTROL1.118
*,OZONE_LEVELS_OUT !IN No of ozone levels (output) CONTROL1.119
*,TR_VARS_OUT !IN No of tracer variables (output) CONTROL1.120
*,MAX_VARIABLES_OUT !IN Maximum no of variables (output) CONTROL1.121
CONTROL1.124
INTEGER CONTROL1.125
* LEN_FIXHD_OUT !IN Length of fixed length header (output) CONTROL1.126
*,LEN_INTHD_OUT !IN Length of integer header (output) CONTROL1.127
*,LEN_REALHD_OUT !IN Length of real header (output) CONTROL1.128
*,LEN2_LEVDEPC_OUT !IN 2nd dim of lev dep consts (output) CONTROL1.129
*,LEN1_LEVDEPC_OUT !IN ist dim of lev dep consts (output) CONTROL1.130
*,LEN1_ROWDEPC_OUT !IN 1st dim of row dep consts (output) CONTROL1.131
*,LEN2_ROWDEPC_OUT !IN 2nd dim of row dep consts (output) CONTROL1.132
*,LEN1_COLDEPC_OUT !IN 1st dim of col dep consts (output) CONTROL1.133
*,LEN2_COLDEPC_OUT !IN 2nd dim of col dep consts (output) CONTROL1.134
*,LEN1_FLDDEPC_OUT !IN 1st dim of field dep consts (output) CONTROL1.135
*,LEN2_FLDDEPC_OUT !IN 2nd dim of field dep consts (output) CONTROL1.136
*,LEN_EXTCNST_OUT !IN Length of extra constants (output) CONTROL1.137
*,LEN_DUMPHIST_OUT !IN Length of history header (output) CONTROL1.138
&,LEN_CFI1_OUT !IN Length of index1 on output file CONTROL1.139
&,LEN_CFI2_OUT !IN Length of index2 on output file CONTROL1.140
&,LEN_CFI3_OUT !IN Length of index3 on output file CONTROL1.141
*,LEN1_LOOKUP_OUT !IN 1st dim of lookup header (output) CONTROL1.142
*,LEN2_LOOKUP_OUT !IN 2nd dim of lookup header (output) CONTROL1.143
&,LEN1_LOOKUP_UM ! 1st dim of lookup header (input UM dump) UIE2F401.11
&,LEN2_LOOKUP_UM ! 2nd dim of lookup header (input UM dump) UIE2F401.12
&,LEN1_LOOKUP_LS ! 1st dim of lookup header (input LS dump) UIE2F401.13
&,LEN2_LOOKUP_LS ! 2nd dim of lookup header (input LS dump) UIE2F401.14
*,U_FIELD_OUT !IN No of UV-points per level (output) CONTROL1.144
*,P_FIELD_OUT !IN No of p-points per level (output) CONTROL1.145
*,U_ROWS_OUT !IN No of uv-points N-S (output) CONTROL1.146
*,LEN_DATA_OUT !IN Length of output data (output) CONTROL1.147
INTEGER LAND_POINTS_UMUI !No of land points from UDG1F404.5
!namelist RECON UDG1F404.6
CONTROL1.148
INTEGER CONTROL1.149
& FIXHD_OUT(256), CONTROL1.150
& FIXHD_LS(256), UIE2F401.9
& FIXHD_UM(256), UIE2F401.10
& INTHD_OUT(LEN_INTHD_OUT), CONTROL1.151
& CFI1_OUT(LEN_CFI1_OUT+1), CONTROL1.152
& CFI2_OUT(LEN_CFI2_OUT+1),CFI3_OUT(LEN_CFI3_OUT+1), CONTROL1.153
& LOOKUP_OUT(LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT), CONTROL1.154
& ID1_OUT(P_FIELD_OUT) CONTROL1.155
INTEGER POINTS_PER_OCEAN_LEVEL(99) UDG2F305.54
INTEGER DUMP_PACK ! Packing indicator for Dump. See GDR2F401.12
! deck RECONF1 for details. GDR2F401.13
CONTROL1.156
REAL CONTROL1.157
& REALHD_OUT(LEN_REALHD_OUT), CONTROL1.158
& LEVDEPC_OUT(1+LEN1_LEVDEPC_OUT*LEN2_LEVDEPC_OUT), CONTROL1.159
& ROWDEPC_OUT(1+LEN1_ROWDEPC_OUT*LEN2_ROWDEPC_OUT), CONTROL1.160
& COLDEPC_OUT(1+LEN1_COLDEPC_OUT*LEN2_COLDEPC_OUT), CONTROL1.161
& FLDDEPC_OUT(1+LEN1_FLDDEPC_OUT*LEN2_FLDDEPC_OUT), CONTROL1.162
& EXTCNST_OUT(LEN_EXTCNST_OUT+1), CONTROL1.163
& DUMPHIST_OUT(LEN_DUMPHIST_OUT+1), CONTROL1.164
C & D1_OUT(P_FIELD_OUT*(P_LEVELS_OUT+1)) CONTROL1.165
& PERTURBATION ! Switch for transplanting data UDG3F402.91
UDG3F402.92
INTEGER CONTROL1.168
& LEN_INTHD_UARS !Length of integer header on UARS file CONTROL1.169
&,LEN_REALHD_UARS !Length of real header on UARS file CONTROL1.170
&,LEN1_LEVDEPC_UARS !1st dim of lev dependent consts on UARS file CONTROL1.171
&,LEN2_LEVDEPC_UARS !2nd dim of lev dependent consts on UARS file CONTROL1.172
&,LEN2_LOOKUP_UARS !2nd dim of LOOKUP on UARS file CONTROL1.173
&,LEN_DATA_UARS !Length of data on UARS file CONTROL1.174
&,LEN_INTHD_TRACER !Length of integer header on TRACER file CONTROL1.175
&,LEN_REALHD_TRACER !Length of real header on TRACER file CONTROL1.176
&,LEN1_LEVDEPC_TRACER !1st dim of lev dependent consts on TRACER fi CONTROL1.177
&,LEN2_LEVDEPC_TRACER !2nd dim of lev dependent consts on TRACER fi CONTROL1.178
&,LEN2_LOOKUP_TRACER !2nd dim of LOOKUP on TRACER file CONTROL1.179
&,LEN_DATA_TRACER !Length of data on TRACER file CONTROL1.180
&,LEN_INTHD_TRANS !Length of integer header on TRANS file AD221292.94
&,LEN_REALHD_TRANS !Length of real header on TRANS file AD221292.95
&,LEN1_LEVDEPC_TRANS !1st dim of lev dependent consts on TRANS file AD221292.96
&,LEN2_LEVDEPC_TRANS !2nd dim of lev dependent consts on TRANS file AD221292.97
&,LEN2_LOOKUP_TRANS !2nd dim of LOOKUP on TRANS file AD221292.98
&,LEN_DATA_TRANS !Length of data on TRANS file AD221292.99
&,LEN_INTHD_UPROG !Length of integer header on user prog file UDG4F304.7
&,LEN_REALHD_UPROG !Length of real header on user prog file UDG4F304.8
&,LEN1_LEVDEPC_UPROG !1st dim of lev depdnt consts on usr prog file UDG4F304.9
&,LEN2_LEVDEPC_UPROG !2nd dim of lev depdnt consts on usr prog file UDG4F304.10
&,LEN2_LOOKUP_UPROG !2nd dim of LOOKUP on user prognostic file UDG4F304.11
&,LEN_DATA_UPROG !Length of data on user prognostic file UDG4F304.12
&,PER_LEN !Dim of PER_ARGS AD150293.53
&,PER_ARGS(PER_LEN)!Lengths used to dim arrays in PERTURB AD150293.54
&,FIXHD_UPROG(256) !Fixed header of user prognostic file UDG4F304.13
CONTROL1.181
C ------------------------------------------------------------- CONTROL1.182
C External subroutines called:--------------------------------- CONTROL1.183
EXTERNAL READHEAD,WRITHEAD,CONVHEAD,POSERROR,ABORT_IO CONTROL1.184
&,H_INT_INIT,H_INT_CTL,COAST_AJ,READFLDS,WRITFLDS UDG1F400.27
&,V_INT,F_TYPE,IOERROR,W_LLTOEQ UDG1F400.28
*,SETPOS,LOCATE,INANCILA,PR_LOOK,REPLANCA,PR_RFLD,GETPOS CONTROL1.187
*,ROTATE,AUX_FILE UDG4F304.14
*,INTF_COAST_AJ UDG1F304.12
*,DERV_3D_CCA AJX1F404.17
*IF DEF,TIMER CONTROL1.189
*,TIMER CONTROL1.190
*ENDIF CONTROL1.191
C ------------------------------------------------------------- CONTROL1.193
*CALL C_G CONTROL1.194
*CALL C_LAPSE CONTROL1.195
*CALL C_R_CP CONTROL1.196
*CALL C_LHEAT CONTROL1.197
*CALL C_0_DG_C CONTROL1.198
*CALL C_MDI CONTROL1.199
*CALL CSUBMODL UDG2F305.56
*CALL CPPXREF UDG2F305.58
*CALL PPXLOOK UDG2F305.59
*CALL NRECON UDG2F305.60
*CALL CANCILA UDG2F305.61
*CALL C_ITEMS UDG2F305.62
*CALL RCPARAM UIE2F401.15
*CALL CNTLATM GDG0F401.203
*CALL C_DENSTY UDG1F401.4
*CALL NSTYPES GDR7F404.6
! ------------------------------------------------------------- UDG2F305.63
CONTROL1.202
INTEGER CONTROL1.203
* J,I,K,IJ,IJMIN,KK !Integer indices ADR1F304.24
*,N_TYPES_IN,N_TYPES_OUT !No of different field types CONTROL1.205
*,N_FIELDS_IN,N_FIELDS_OUT !No of fields per type CONTROL1.206
*,TYPE !Horiz interp mode CONTROL1.207
*,NBLP1 !No of B.L. levs + 1 CONTROL1.208
*,COASTAL_POINTS !No of coastal points CONTROL1.209
*,START_BLOCK_IN !READHEAD argument CONTROL1.210
*,START_BLOCK_OUT !READHEAD argument CONTROL1.211
*,POS_D1_IN !Pointers used to address CONTROL1.212
*,POS_D1_OUT,POS_D1_TMP !levels in vert interpolation CONTROL1.213
*,POSU,POSV,POS !Position returned by LOCATE UIE2F401.86
*,POS2 ! Position of u field returned by LOCATE when S=9 UIE2F401.87
*,POS3 ! Position of v field returned by LOCATE when S=9 UIE2F401.88
*,POSUV ! Position of u,v field returned by LOCATE when S=9 UIE2F401.89
*,POS_IN,POS_OUT ! Positions returned from LOCATE UDG6F400.3
*,LEN_IO !Length of I/O returned by BUFFER IN UDG4F304.15
&,LEN_DATA_MASK ! Length of data in MASK file GDR3F400.2
INTEGER IP_ROW_SUM !Used in averaging polar rows. UDG4F402.4
REAL RP_ROW_SUM !Used in averaging polar rows. UDG4F402.5
CONTROL1.217
INTEGER CONTROL1.218
* PP_LEN_IN(LEN2_LOOKUP_IN) !Length | CONTROL1.219
*,PP_NUM_IN(LEN2_LOOKUP_IN) !No of fields| For each CONTROL1.220
*,PP_POS_IN(LEN2_LOOKUP_IN) !Position | field type CONTROL1.221
*,PP_TYPE_IN(LEN2_LOOKUP_IN) !Real,int,log| on input file CONTROL1.222
*,PP_ITEMC_IN(LEN2_LOOKUP_IN) !Item code | CONTROL1.223
*,PP_LS_IN(LEN2_LOOKUP_IN) !Land or sea ^ on input file CONTROL1.224
CONTROL1.225
*,PP_LEN_OUT(LEN2_LOOKUP_OUT) !Length | CONTROL1.226
*,PP_NUM_OUT(LEN2_LOOKUP_OUT) !No of fields | For each CONTROL1.227
*,PP_POS_OUT(LEN2_LOOKUP_OUT) !Position | field type CONTROL1.228
*,PP_TYPE_OUT(LEN2_LOOKUP_OUT) !Real,int,log | on output file CONTROL1.229
*,PP_ITEMC_OUT(LEN2_LOOKUP_OUT) !Item code | CONTROL1.230
*,PP_LS_OUT(LEN2_LOOKUP_OUT) !Land or sea ^ on output file CONTROL1.231
*,PP_SOURCE_OUT(LEN2_LOOKUP_OUT)!NAMLST LOOK S| CONTROL1.232
*,PP_AREA_OUT(LEN2_LOOKUP_OUT) !NAMLST LOOK A| CONTROL1.233
CONTROL1.234
INTEGER GRID_TYPE(LEN2_LOOKUP_OUT) UDG1F400.29
!Grid type;- 1=p-grid, UDG1F400.30
! 2=q-grid, UDG1F400.31
! 3=zonal mean. UDG1F400.32
*,ICODE !OUT Return code; successful=0 CONTROL1.235
* ! error > 0 CONTROL1.236
CONTROL1.237
CHARACTER*256 CONTROL1.238
* CMESSAGE !OUT Error message if ICODE > 0 CONTROL1.239
CONTROL1.240
INTEGER STATUS !Error code from ALLOCATE & DEALLOCATE UDG4F405.17
INTEGER MODEL ! STASH internal model number UDG2F305.64
INTEGER SECTION ! STASH section number UDG2F305.65
INTEGER ITEM_CODE ! STASH item code UDG2F305.66
INTEGER PPXREF_GRID_TYPE UIE2F401.198
UDG2F305.67
INTEGER EXPPXI ! Function to extract integer UDG2F305.68
! from ppxref file UDG2F305.69
CHARACTER*36 EXPPXC ! Function to extract character string UDG2F305.70
! from ppxref file UDG2F305.71
CONTROL1.245
REAL TEMP CONTROL1.246
*,AKH_OUT(P_LEVELS_OUT+1) !Half level As for output levels CONTROL1.250
*,BKH_OUT(P_LEVELS_OUT+1) !Half level Bs for output levels CONTROL1.251
CONTROL1.252
INTEGER J_NAMELIST(LEN2_LOOKUP_OUT) UDG2F305.74
!USER_PROG_ANCIL_ITEMC from N'ST ITEMS UDG2F305.75
REAL R_NAMELIST(LEN2_LOOKUP_OUT) UDG2F305.76
!USER_PROG_RCONST from N'ST ITEMS UDG2F305.77
! C_NAMELIST should be dimensioned with LEN2_LOOKUP_OUT but UDG7F400.109
! dyanmic character arrays are not allowed in the portable code UDG7F400.110
! If MAX_LEN2_LOOKUP_OUT is not big enough the code will stop with an UDG7F400.111
! error message UDG7F400.112
CHARACTER*80 UDG7F400.113
* C_NAMELIST(MAX_LEN2_LOOKUP_OUT) !USER_PROG_ANCIL_FILE "" "" UDG7F400.114
!USER_PROG_ANCIL_FILE from N'ST ITEMS UDG2F305.79
REAL, DIMENSION (:), ALLOCATABLE :: D1_IN UDG4F405.18
REAL, DIMENSION (:), ALLOCATABLE :: D1_OUT UDG4F405.19
REAL, DIMENSION (:), ALLOCATABLE :: D1_TMP UDG4F405.20
REAL, DIMENSION (:), ALLOCATABLE :: D1_TEMP UDG4F405.21
REAL, DIMENSION (:), ALLOCATABLE :: D1_IN_TMP UDG4F405.22
REAL, DIMENSION (:), ALLOCATABLE :: P_TMP UDG4F405.23
REAL, DIMENSION (:), ALLOCATABLE :: PSTAR_OUT UDG4F405.24
REAL, DIMENSION (:), ALLOCATABLE :: P_OUT UDG4F405.25
REAL, DIMENSION (:, :), ALLOCATABLE :: P_HALF_TMP UDG4F405.26
REAL, DIMENSION (:, :), ALLOCATABLE :: P_EXNER_HALF_TMP UDG4F405.27
REAL, DIMENSION (:), ALLOCATABLE :: TOPOG_OUT UDG4F405.28
REAL, DIMENSION (:), ALLOCATABLE :: TOPOG_OLD UDG4F405.29
REAL, DIMENSION (:), ALLOCATABLE :: THR_OUT UDG4F405.30
UDG1F400.53
! Scalars for coastal adjustment UDG1F400.54
INTEGER INDEX_OUT(P_FIELD_OUT) !\ Gather indices linking UDG1F400.55
INTEGER INDEX_IN(P_FIELD_OUT) !/ coastal points on source UDG1F400.56
! and target grids UDG1F400.57
INTEGER INDEX_TARG_SEA(P_FIELD_OUT) UDG1F400.58
!Index of unresolved sea points UDG1F400.59
INTEGER INDEX_TARG_LAND(P_FIELD_OUT) UDG1F400.60
!Index of unresolved land points UDG1F400.61
INTEGER LAND_SEA_INDEX(P_FIELD_OUT) UDG1F400.62
!Index of land pts minus unres pts UDG1F400.63
INTEGER LAND_UNRES_INDEX(P_FIELD_OUT) UDG1F400.64
!Index of pts mapped onto unresolved UDG1F400.65
! land points UDG1F400.66
INTEGER SEA_UNRES_INDEX(P_FIELD_OUT) UDG1F400.67
!Index of pts mapped onto unresolved UDG1F400.68
! sea points UDG1F400.69
INTEGER DUMMY !Dummy argument passd to subroutines UDG1F400.70
INTEGER LAND_POINTS !No of land points UDG1F400.71
INTEGER LAND_POINTS_OUT !No of output land points UDG1F400.72
INTEGER LAND_POINTS_UNRES!No of unresolved land points UDG1F400.73
INTEGER SEA_POINTS_UNRES !No of unresolved sea points UDG1F400.74
INTEGER LEN2_LOOKUP_MASK !2nd dimension of LOOKUP in MASK fil UDG1F400.75
INTEGER MAXDIM !Largest dimension of field UDG1F400.76
INTEGER NSEARCH !Radius of search for SPIRAL_S UDG1F400.77
INTEGER INDEX_TARG_SEA_X(P_FIELD_OUT) !\ UDG1F400.78
INTEGER INDEX_TARG_LAND_X(P_FIELD_OUT) !Temporary arrays for UDG1F400.79
INTEGER LAND_SEA_MASK_X(P_FIELD_OUT) !for calls to SPIRAL_S UDG1F400.80
INTEGER SEA_POINTS_UNRESX !and CALC_NSEARCH UDG1F400.81
INTEGER LAND_POINTS_UNRESX !/ UDG1F400.82
UDG1F400.83
! Parameters for horizontal interpolation UDG1F400.84
INTEGER ICOF !Second dimension of coefficents ary UDG1F400.85
INTEGER IDIM !Second dimension of index arrays UDG1F400.86
PARAMETER(ICOF=2) UDG1F400.87
PARAMETER(IDIM=4) UDG1F400.88
UDG1F400.89
! Scalars for horizontal interpolation UDG1F400.90
INTEGER X_COLS_IN !N_S dimension (input to H_INT_CTL) UDG1F400.91
INTEGER X_COLS_OUT !N_S dimension (output of H_INT_CTL) UDG1F400.92
INTEGER X_FIELD_IN !Field length \ P_FIELD or U_FIELD UDG1F400.93
INTEGER X_FIELD_OUT !Field length /(in/out of H_INT_CTL) UDG1F400.94
INTEGER X_ROWS_IN !E_W dimension (input to H_INT_CTL) UDG1F400.95
INTEGER X_ROWS_OUT !E_W dimension (output of H_INT_CTL) UDG1F400.96
LOGICAL GLOBAL !True if global area required UDG1F400.97
UDG1F400.98
! Dynamic arrays for horizontal interpolation UDG1F400.99
INTEGER AW_INDEX_TARG_LHS(ROW_LENGTH_OUT+1,IDIM) UDG1F400.100
!Index of source box overlapping UDG1F400.101
!lhs of target grid-box UDG1F400.102
INTEGER AW_INDEX_TARG_TOP(P_ROWS_OUT+1,IDIM) UDG1F400.103
!Index of source box overlapping UDG1F400.104
!top of target grid-box UDG1F400.105
INTEGER BL_INDEX_B_L(P_FIELD_OUT,IDIM) UDG1F400.106
!Gather index for bottom l.h.c of UDG1F400.107
!source grid box. 1=P-pts; 2=UV-pts UDG1F400.108
INTEGER BL_INDEX_B_R(P_FIELD_OUT,IDIM) UDG1F400.109
!Gather index for bottom r.h.c of UDG1F400.110
!source grid box. 1=P-pts; 2=UV-pts UDG1F400.111
INTEGER BL_INDEX_NEAREST(P_FIELD_OUT) UDG1F400.112
!Gather index for nearest point on UDG1F400.113
!source grid for each target P-pt UDG1F400.114
REAL AW_AREA_BOX(IDIM) UDG1F400.115
!area of grid box in sq units of UDG1F400.116
REAL AW_COLAT_T(P_ROWS_OUT+1,IDIM) UDG1F400.117
!Colatitude of top of target grd-box UDG1F400.118
! (in units of DELTA_LAT_SRCE) UDG1F400.119
REAL AW_LONG_L(ROW_LENGTH_OUT+1,IDIM) UDG1F400.120
!Left longitude of target grid-box UDG1F400.121
! (in units of DELTA_LONG_SRCE) UDG1F400.122
REAL COEFF1(U_FIELD_OUT,ICOF)!Coefficient of rotation no 1 UDG1F400.123
REAL COEFF2(U_FIELD_OUT,ICOF)!Coefficient of rotation no 2 UDG1F400.124
REAL COEFF3(U_FIELD_IN,ICOF) !Coefficient of rotation no 1 UDG1F400.125
REAL COEFF4(U_FIELD_IN,ICOF) !Coefficient of rotation no 2 UDG1F400.126
REAL WEIGHT_B_L(P_FIELD_OUT,IDIM) !Weights used for UDG1F400.127
REAL WEIGHT_B_R(P_FIELD_OUT,IDIM) !\bi-linear horizontal UDG1F400.128
REAL WEIGHT_T_L(P_FIELD_OUT,IDIM) !/interpolation UDG1F400.129
REAL WEIGHT_T_R(P_FIELD_OUT,IDIM) ! 1=P-pts; 2=U-pts; UDG1F400.130
LOGICAL H_INT_TYPE !=T Area weighted interpolation; UDG1F400.131
!=F Bi-linear interpolation UDG1F400.132
LOGICAL LPOLARCHK ! True if polar rows to be UDG4F402.6
! averaged after horizontal UDG4F402.7
! interpolation UDG4F402.8
UDG1F400.133
LOGICAL CONTROL1.304
* LAND_SEA_MASK_IN(P_FIELD_IN) ! Input land-sea mask CONTROL1.305
*,LAND_SEA_MASK_OUT(P_FIELD_OUT) ! Output land-sea mask CONTROL1.306
*,LAND_SEA_MASK(P_FIELD_OUT) ! Temp output land-sea mask CONTROL1.307
*,TOPOG_MASK(P_FIELD_OUT) ! Mask for topography subarea CONTROL1.308
CONTROL1.309
REAL LAPSE_R_OVER_G,G_OVER_LAPSE_R CONTROL1.310
PARAMETER(LAPSE_R_OVER_G=LAPSE*R/G) CONTROL1.311
PARAMETER(G_OVER_LAPSE_R=G/(LAPSE*R)) CONTROL1.312
REAL PR_OUT,TR_OUT,TS_OUT ! Intermediate temporaries used in calc CONTROL1.313
* ! of pstar if ancillary orog provided CONTROL1.314
*,SUM ! Used in calc of polar values AD200593.140
CONTROL1.315
LOGICAL CONTROL1.316
* VERT ! Switch for vertical interpolation CONTROL1.317
*,HORIZ ! Switch for horizontal interpolation CONTROL1.318
*,GH_TO_LAM ! Switch signifying global to limited area CONTROL1.319
*,MASK ! Switch for land/sea mask CONTROL1.321
*,UARS ! Switch for UARS data CONTROL1.322
*,TRANS ! Switch for transplanting data AD221292.100
*,STRAT_Q ! Switch to reset stratospheric Q CONTROL1.323
*,RESET ! Switch to reset fc time info in FIXHD CONTROL1.324
*,GRIB ! Switch for GRIB data winds on A grid CONTROL1.325
*,SSTANOM ! Switch for SST anomaly CONTROL1.326
*,LOG_ICE_FRAC ! Switch for ice frac update CONTROL1.327
*,LSM ! Logical set if ancillary land-sea mask requested CONTROL1.328
*,LOZONE ! Logical set if vert int of ozone required CONTROL1.329
*,OCEAN ! Logical set if ocean reconfiguration CONTROL1.330
*,ROT_IN ! Logical set if input grid rotated CONTROL1.331
*,ROT_OUT ! Logical set if output grid rotated CONTROL1.332
*,C_GRID_IN !=T C-grid; =F B-grid input grid AD200593.141
*,C_GRID_OUT !=T C-grid; =F B-grid output grid AD200593.142
*,RadialGridIn !=T Vert co-ord radius =F hybrid UIE2F401.16
*,RadialGridOut !=T Vert co-ord radius =F hybrid UIE2F401.17
*,RM_CP UDG6F405.39
*,CYCLIC ! Switch for overlapping LAM fields UDG1F304.21
CONTROL1.333
DATA SSTANOM/.FALSE./ CONTROL1.334
CONTROL1.335
INTEGER NDATASETS,PP_LEN_INTHD,PP_LEN_REALHD GDR1F401.18
*,PP_LEN2_LEVDEPC,IOUNIT CONTROL1.337
GRB0F304.42
PARAMETER(PP_LEN_INTHD=15,PP_LEN_REALHD=6) CONTROL1.339
PARAMETER(PP_LEN2_LEVDEPC=4) CONTROL1.340
INTEGER FIXHD_ANCIL(256,NDATASETS) CONTROL1.341
*, INTHD_ANCIL(PP_LEN_INTHD,NDATASETS) CONTROL1.342
*, LOOKUP_ANCIL(LEN1_LOOKUP_OUT,NLOOKUPS) CONTROL1.343
*, LOOKUP_START(NDATASETS) CONTROL1.344
*, FTN_ANCIL(NDATASETS) CONTROL1.345
*, SWITCH(NANCIL_FIELDS) GDR1F401.19
*, ANCIL_ADD(NANCIL_FIELDS) GDR1F401.20
CHARACTER*80 TITLE(NDATASETS) CONTROL1.349
REAL CONTROL1.350
* REALHD_ANCIL(PP_LEN_REALHD,NDATASETS) CONTROL1.351
* ,LEVDEPC_ANCIL(P_LEVELS_OUT*PP_LEN2_LEVDEPC) CONTROL1.352
* ,ICE_FRAC(P_FIELD_OUT),TSTAR(P_FIELD_OUT) CONTROL1.353
* ,TSTAR_ANOM(P_FIELD_OUT) CONTROL1.354
CONTROL1.355
CHARACTER*80 F_TYPE_TITLE UDG7F400.115
CHARACTER*80 PHRASE CONTROL1.356
UDG6F400.4
LOGICAL LOZONE_ANC ! Set to T if Ozone Ancillary file required UDG6F400.5
LOGICAL ZONAL_IN ! Set to T if Zonal Ozone data in input data UDG6F400.6
LOGICAL ZONAL_OUT ! Set to T if Zonal Ozone data in output data UDG6F400.7
c GBC5F404.12
integer real_start_block, real_start_block_in, lbnrec GBC5F404.13
&,disk_address ! Current rounded disk address GBC5F404.14
&,number_of_data_words_on_disk ! Number of data words on disk GBC5F404.15
&,number_of_data_words_in_memory ! Number of Data Words in memory GBC5F404.16
CONTROL1.357
Integer N_PSL ! No of pseudo levels GDR7F404.7
*CALL CANCFLDA GDR1F401.21
UDG4F304.48
INTEGER JERR UDG4F304.49
REAL AA !BUFFER IN UNIT function UDG4F304.50
INTEGER NFT_UPROG !Unit number of external file for usr prognostic UDG4F304.51
GBC6F404.4
integer err ! used for file close and open operations GBC6F404.5
UDG4F304.55
*CALL P_EXNERC CONTROL1.377
CONTROL1.378
IF (MAX_LEN2_LOOKUP_OUT .LT. LEN2_LOOKUP_OUT) THEN UDG7F400.116
WRITE(6,*) 'ERROR : Reconfiguration CONTROL' UDG7F400.117
WRITE(6,*) 'MAX_LEN2_LOOKUP_OUT is not big enough' UDG7F400.118
WRITE(6,*) 'MAX_LEN2_LOOKUP_OUT= ',max_len2_lookup_out UDG7F400.119
WRITE(6,*) 'LEN2_LOOKUP_OUT= ',LEN2_LOOKUP_OUT UDG7F400.120
WRITE(6,*) 'MAX_LEN2_LOOKUP_OUT should be at least as big as ', UDG7F400.121
& 'LEN2_LOOKUP_OUT.' UDG7F400.122
WRITE(6,*) 'You will need to reset the PARAMETER statement in ', UDG7F400.123
& 'the C_ITEMS comdeck.' GDR1F401.22
CALL ABORT UDG7F400.125
ENDIF UDG7F400.126
DUMMY=1 CONTROL1.379
CONTROL1.380
C--------------------------------------------------------------- CONTROL1.385
C Read in header info for source dump CONTROL1.386
C--------------------------------------------------------------- CONTROL1.387
CONTROL1.388
CALL SETPOS(NFTIN,0,ICODE) GTD0F400.47
CONTROL1.390
*IF DEF,TIMER CONTROL1.391
CALL TIMER('READHEAD',3) CONTROL1.392
*ENDIF CONTROL1.393
CONTROL1.394
CALL READHEAD(NFTIN,FIXHD_IN,LEN_FIXHD_IN, GDG0F401.204
& INTHD_IN,LEN_INTHD_IN, GDG0F401.205
& REALHD_IN,LEN_REALHD_IN, GDG0F401.206
& LEVDEPC_IN,LEN1_LEVDEPC_IN,LEN2_LEVDEPC_IN, GDG0F401.207
& ROWDEPC_IN,LEN1_ROWDEPC_IN,LEN2_ROWDEPC_IN, GDG0F401.208
& COLDEPC_IN,LEN1_COLDEPC_IN,LEN2_COLDEPC_IN, GDG0F401.209
& FLDDEPC_IN,LEN1_FLDDEPC_IN,LEN2_FLDDEPC_IN, GDG0F401.210
& EXTCNST_IN,LEN_EXTCNST_IN, GDG0F401.211
& DUMPHIST_IN,LEN_DUMPHIST_IN, GDG0F401.212
& CFI1_IN,LEN_CFI1_IN, GDG0F401.213
& CFI2_IN,LEN_CFI2_IN, GDG0F401.214
& CFI3_IN,LEN_CFI3_IN, GDG0F401.215
& LOOKUP_IN,LEN1_LOOKUP_IN,LEN2_LOOKUP_IN, GDG0F401.216
& LEN_DATA_IN, GDG0F401.217
*CALL ARGPPX GDG0F401.218
& START_BLOCK_IN,ICODE,CMESSAGE) GDG0F401.219
CONTROL1.410
*IF DEF,TIMER CONTROL1.411
CALL TIMER('READHEAD',4) CONTROL1.412
*ENDIF CONTROL1.413
CONTROL1.414
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) CONTROL1.415
CONTROL1.416
C--------------------------------------------------------------- CONTROL1.417
C Find number of different input types and their characteristics CONTROL1.418
C--------------------------------------------------------------- CONTROL1.419
CONTROL1.420
*IF DEF,TIMER CONTROL1.421
CALL TIMER('F_TYPE ',3) CONTROL1.422
*ENDIF CONTROL1.423
CONTROL1.424
F_TYPE_TITLE='Input data' UDG7F400.127
CALL F_TYPE(LOOKUP_IN,LEN2_LOOKUP_IN,PP_NUM_IN,N_TYPES_IN, UDG7F400.128
& PP_LEN_IN,PP_ITEMC_IN,PP_TYPE_IN,PP_POS_IN, UDG7F400.129
& PP_LS_IN,FIXHD_IN, UDG7F400.130
*CALL ARGPPX UDG7F400.131
& F_TYPE_TITLE) UDG7F400.132
UDG7F400.133
*IF DEF,TIMER CONTROL1.429
CALL TIMER('F_TYPE ',4) CONTROL1.430
*ENDIF CONTROL1.431
CONTROL1.432
C--------------------------------------------------------------- CONTROL1.433
C Create header info for dump at new resolution CONTROL1.434
C--------------------------------------------------------------- CONTROL1.435
CONTROL1.436
*IF DEF,TIMER CONTROL1.437
CALL TIMER('CONVHEAD',3) CONTROL1.438
*ENDIF CONTROL1.439
CONTROL1.440
CALL CONVHEAD(VERT,HORIZ, CONTROL1.441
* LEN_FIXHD_OUT,FIXHD_OUT,LEN_FIXHD_IN,FIXHD_IN, CONTROL1.442
* LEN_INTHD_OUT,INTHD_OUT,LEN_INTHD_IN,INTHD_IN, CONTROL1.443
* LEN_REALHD_OUT,REALHD_OUT,LEN_REALHD_IN,REALHD_IN, CONTROL1.444
* LEN2_LEVDEPC_OUT,LEN1_LEVDEPC_OUT,LEVDEPC_OUT, CONTROL1.445
* LEN2_LEVDEPC_IN,LEN1_LEVDEPC_IN,LEVDEPC_IN, CONTROL1.446
* LEN1_ROWDEPC_OUT,LEN2_ROWDEPC_OUT,ROWDEPC_OUT, CONTROL1.447
* LEN1_ROWDEPC_IN,LEN2_ROWDEPC_IN,ROWDEPC_IN, CONTROL1.448
* LEN1_COLDEPC_IN,LEN2_COLDEPC_IN,COLDEPC_IN, CONTROL1.449
* LEN1_COLDEPC_OUT,LEN2_COLDEPC_OUT,COLDEPC_OUT, CONTROL1.450
* LEN1_FLDDEPC_IN,LEN2_FLDDEPC_IN,FLDDEPC_IN, CONTROL1.451
* LEN1_FLDDEPC_OUT,LEN2_FLDDEPC_OUT,FLDDEPC_OUT, CONTROL1.452
* LEN_EXTCNST_IN,EXTCNST_IN,LEN_EXTCNST_OUT,EXTCNST_OUT, CONTROL1.453
* LEN_CFI1_IN,CFI1_IN,LEN_CFI1_OUT,CFI1_OUT, CONTROL1.454
* LEN_CFI2_IN,CFI2_IN,LEN_CFI2_OUT,CFI2_OUT, CONTROL1.455
* LEN_CFI3_IN,CFI3_IN,LEN_CFI3_OUT,CFI3_OUT, CONTROL1.456
* LEN_DUMPHIST_OUT,DUMPHIST_OUT,LEN_DUMPHIST_IN,DUMPHIST_IN, CONTROL1.457
* LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT,LEN_DATA_OUT, CONTROL1.458
* ROW_LENGTH_OUT,P_ROWS_OUT,P_LEVELS_OUT,Q_LEVELS_OUT, CONTROL1.459
* ST_LEVELS_OUT,SM_LEVELS_OUT, UJS1F401.27
* TR_LEVELS_OUT,BL_LEVELS_OUT,TR_VARS_OUT, UJS1F401.28
& MAX_VARIABLES_OUT, OZONE_LEVELS_OUT, GDR6F405.11
* U_ROWS_OUT,U_FIELD_OUT,P_FIELD_OUT,TR_LEVELS_ADV_OUT, CONTROL1.462
* RadialGridOut, UIE2F401.85
* P_LEVELS_IN,Q_LEVELS_IN,ST_LEVELS_IN,SM_LEVELS_IN, UJS1F401.29
* TOPOG_MASK,RESET,OCEAN,C_GRID_OUT) UJS1F401.30
CONTROL1.464
*IF DEF,TIMER CONTROL1.465
CALL TIMER('CONVHEAD',4) CONTROL1.466
*ENDIF CONTROL1.467
CONTROL1.468
C--------------------------------------------------------------- CONTROL1.469
C Check for error in file pointers CONTROL1.470
C--------------------------------------------------------------- CONTROL1.471
CONTROL1.472
C Check for error in file pointers CONTROL1.473
lbnrec=30 GBC5F404.17
real_start_block_in=start_block_in GBC5F404.18
if(start_block_in.ne.fixhd_in(160)) then GBC5F404.19
C If new format Dumpfile, we must reset the start address GBC5F404.20
if((lookup_in(lbnrec,1).eq.0) .or. GBC5F404.21
C Prog lookups in dump before vn3.2: GBC5F404.22
2 ((lookup_in(lbnrec,1).eq.imdi) .and. GBC5F404.23
3 (fixhd_in(12).le.301))) then GBC5F404.24
CALL POSERROR('input model data', CONTROL1.475
* START_BLOCK_IN,160,FIXHD_IN(160)) CONTROL1.476
CALL ABORT CONTROL1.477
else GBC5F404.25
real_start_block_in=fixhd_in(160) GBC5F404.26
endif GBC5F404.27
ENDIF CONTROL1.478
CONTROL1.479
!------------------------------------------------------------------- GRS2F404.227
! Set LAMIPII in common block CANCILA using LAMIPII_IN GRS2F404.228
!------------------------------------------------------------------- GRS2F404.229
LAMIPII=LAMIPII_IN GRS2F404.230
C--------------------------------------------------------------------- UDG1F304.25
C Set switches for coastal adjustemnt UDG1F304.26
C--------------------------------------------------------------------- UDG1F304.27
UDG1F304.28
IF(FIXHD_OUT(4).NE.3.AND.FIXHD_OUT(4).NE.103)THEN UDG1F304.29
CYCLIC=.TRUE. UDG1F304.30
ELSE UDG1F304.31
CYCLIC=.FALSE. UDG1F304.32
ENDIF UDG1F304.33
UDG1F304.36
C--------------------------------------------------------------- CONTROL1.480
C Set up gather indices and weights for horizontal interpolation CONTROL1.481
C--------------------------------------------------------------- CONTROL1.482
CONTROL1.483
IF(.NOT.OCEAN)THEN CONTROL1.484
*IF DEF,TIMER CONTROL1.485
CALL TIMER('HINTINIT',3) UDG1F400.134
*ENDIF CONTROL1.487
CONTROL1.488
CALL H_INT_INIT(ICOF,IDIM,P_FIELD_OUT,P_ROWS_IN,P_ROWS_OUT UDG1F400.135
&, ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.136
&, U_FIELD_IN,U_FIELD_OUT,U_ROWS_IN,U_ROWS_OUT UDG1F400.137
&, GLOBAL,GRIB,H_INT_TYPE,FIXHD_IN,FIXHD_OUT UDG1F400.138
&, REALHD_IN,REALHD_OUT,AW_AREA_BOX UDG1F400.139
&, AW_INDEX_TARG_LHS,AW_INDEX_TARG_TOP UDG1F400.140
&, BL_INDEX_B_L,BL_INDEX_B_R,BL_INDEX_NEAREST UDG1F400.141
&, AW_COLAT_T,AW_LONG_L UDG1F400.142
&, COEFF1,COEFF2,COEFF3,COEFF4 UDG1F400.143
&, WEIGHT_T_R,WEIGHT_B_R,WEIGHT_T_L,WEIGHT_B_L) UDG1F400.144
*IF DEF,TIMER CONTROL1.495
CALL TIMER('HINTINIT',4) UDG1F400.145
*ENDIF CONTROL1.497
ENDIF CONTROL1.498
CONTROL1.499
IF(.NOT.(RadialGridIn.AND..NOT.RadialGridOut))THEN UIE2F401.211
C--------------------------------------------------------------- CONTROL1.500
C Interpolate land/sea mask CONTROL1.501
C--------------------------------------------------------------- CONTROL1.502
CONTROL1.503
IF(.NOT.OCEAN)THEN CONTROL1.504
CONTROL1.505
C Calculate new land/sea mask and gather indices for coastal ajustment CONTROL1.506
CONTROL1.507
MASK=.FALSE. CONTROL1.508
CONTROL1.509
C Read in new land/sea mask if requested CONTROL1.512
CONTROL1.513
LSM=.FALSE. CONTROL1.514
DO K=1,10000 CONTROL1.515
READ(5,ITEMS,END=1222,ERR=1223,IOSTAT=ICODE) UDG3F402.129
IF(ITEM.EQ.30.AND.SOURCE.EQ.2)LSM=.TRUE. GDG0F401.220
ENDDO CONTROL1.518
1222 CONTINUE CONTROL1.519
1223 CONTINUE UDG3F402.130
REWIND 5 CONTROL1.520
CONTROL1.521
IF(LSM)THEN CONTROL1.522
CONTROL1.523
MASK=.TRUE. CONTROL1.524
CONTROL1.525
WRITE(6,'(//,'' READING IN ANCILLARY LAND-SEA MASK'')') CONTROL1.526
WRITE(6,'( '' ----------------------------------'')') CONTROL1.527
CONTROL1.528
C Read in fixed length header from MASK file ADR1F304.26
C FIXHD_ANCIL is empty ; Treat as workspace here. ADR1F304.27
CALL READ_FLH (39,FIXHD_ANCIL,LEN_FIXHD_IN,ICODE,CMESSAGE) ADR1F304.28
IF (ICODE.NE.0) THEN ADR1F304.29
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,39) ADR1F304.30
ENDIF ADR1F304.31
CALL SETPOS (39,0,ICODE) GTD0F400.48
ADR1F304.33
C Get second dimension of lookup table in MASK file ADR1F304.34
LEN2_LOOKUP_MASK = FIXHD_ANCIL(152,1) ADR1F304.35
ADR1F304.36
! Get length of data in MASK file GDR3F400.3
LEN_DATA_MASK = FIXHD_ANCIL(161,1) GDR3F400.4
GDR3F400.5
*IF DEF,TIMER CONTROL1.529
CALL TIMER('READHEAD',3) CONTROL1.530
*ENDIF CONTROL1.531
CONTROL1.532
CALL READHEAD(39,FIXHD_ANCIL,LEN_FIXHD_IN, GDG0F401.221
& INTHD_ANCIL,PP_LEN_INTHD, GDG0F401.222
& REALHD_ANCIL,PP_LEN_REALHD, GDG0F401.223
& DUMMY,DUMMY,DUMMY, GDG0F401.224
& DUMMY,DUMMY,DUMMY, GDG0F401.225
& DUMMY,DUMMY,DUMMY, GDG0F401.226
& DUMMY,DUMMY,DUMMY, GDG0F401.227
& DUMMY,DUMMY, GDG0F401.228
& DUMMY,DUMMY, GDG0F401.229
& DUMMY,DUMMY, GDG0F401.230
& DUMMY,DUMMY, GDG0F401.231
& DUMMY,DUMMY, GDG0F401.232
& LOOKUP_ANCIL,LEN1_LOOKUP_IN,LEN2_LOOKUP_MASK, GDG0F401.233
& IMDI, GDG0F401.234
*CALL ARGPPX GDG0F401.235
& START_BLOCK_IN,ICODE,CMESSAGE) GDG0F401.236
CONTROL1.548
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,39) CONTROL1.549
CONTROL1.550
*IF DEF,TIMER CONTROL1.551
CALL TIMER('READHEAD',4) CONTROL1.552
*ENDIF CONTROL1.553
CONTROL1.554
*IF DEF,TIMER CONTROL1.555
CALL TIMER('READFLDS',3) CONTROL1.556
*ENDIF CONTROL1.557
CONTROL1.558
! Use LAND_SEA_MASK_OUT as workspace. GDR3F400.7
CALL READFLDS(39,1,1,LOOKUP_ANCIL,LEN1_LOOKUP_OUT, GDG0F401.237
& LAND_SEA_MASK_OUT,P_FIELD_OUT,FIXHD_ANCIL, GDG0F401.238
*CALL ARGPPX GDG0F401.239
& ICODE,CMESSAGE) GDG0F401.240
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,39) CONTROL1.561
CONTROL1.562
*IF DEF,TIMER CONTROL1.563
CALL TIMER('READFLDS',4) CONTROL1.564
*ENDIF CONTROL1.565
CONTROL1.566
CALL SETPOS(39,0,ICODE) GTD0F400.49
CONTROL1.568
C Convert l/s mask to integer CONTROL1.569
DO I=1,P_FIELD_OUT CONTROL1.570
IF (LAND_SEA_MASK_OUT(I)) THEN GDR3F400.10
ID1_OUT(I)=1 GDR3F400.11
ELSE GDR3F400.12
ID1_OUT(I)=0 GDR3F400.13
ENDIF GDR3F400.14
ENDDO CONTROL1.572
CONTROL1.573
ENDIF CONTROL1.574
CONTROL1.575
CALL LOCATE(30,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.578
IF(POS.EQ.0)THEN CONTROL1.579
WRITE(6,'('' *ERROR* L/S mask not in input file'')') CONTROL1.580
CALL ABORT CONTROL1.581
ENDIF CONTROL1.582
CONTROL1.583
*IF DEF,TIMER CONTROL1.584
CALL TIMER('READFLDS',3) CONTROL1.585
*ENDIF CONTROL1.586
CONTROL1.587
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.241
& LAND_SEA_MASK_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.242
*CALL ARGPPX GDG0F401.243
& ICODE,CMESSAGE) GDG0F401.244
IF(ICODE.EQ.1501)THEN UDG4F402.9
IF(LPOLARCHK)THEN UDG4F402.10
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.11
! North polar row UDG4F402.12
IP_ROW_SUM=0 UDG4F402.13
DO I=1,ROW_LENGTH_IN UDG4F402.14
IF(LAND_SEA_MASK_IN(I))IP_ROW_SUM=IP_ROW_SUM+1 UDG4F402.15
END DO UDG4F402.16
DO I=1,ROW_LENGTH_IN UDG4F402.17
IF(IP_ROW_SUM.GE.ROW_LENGTH_IN/2)THEN UDG4F402.18
LAND_SEA_MASK_IN(I)=.TRUE. UDG4F402.19
ELSE UDG4F402.20
LAND_SEA_MASK_IN(I)=.FALSE. UDG4F402.21
END IF UDG4F402.22
END DO UDG4F402.23
! South polar row UDG4F402.24
IP_ROW_SUM=0 UDG4F402.25
DO I=1,ROW_LENGTH_IN UDG4F402.26
IF(LAND_SEA_MASK_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I)) UDG4F402.27
& IP_ROW_SUM=IP_ROW_SUM+1 UDG4F402.28
END DO UDG4F402.29
DO I=1,ROW_LENGTH_IN UDG4F402.30
IF(IP_ROW_SUM.GE.ROW_LENGTH_IN/2)THEN UDG4F402.31
LAND_SEA_MASK_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.32
& =.TRUE. UDG4F402.33
ELSE UDG4F402.34
LAND_SEA_MASK_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.35
& =.FALSE. UDG4F402.36
END IF UDG4F402.37
END DO UDG4F402.38
END IF UDG4F402.39
ELSE IF(ICODE.NE.0)THEN UDG4F402.40
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.41
END IF UDG4F402.42
CONTROL1.591
*IF DEF,TIMER CONTROL1.592
CALL TIMER('READFLDS',4) CONTROL1.593
*ENDIF CONTROL1.594
CONTROL1.595
CONTROL1.596
C Convert l/s mask to integer CONTROL1.597
DO I=1,P_FIELD_IN CONTROL1.598
ID1_IN(I)=0 CONTROL1.599
IF(LAND_SEA_MASK_IN(I))ID1_IN(I)=1 CONTROL1.600
ENDDO CONTROL1.601
CONTROL1.602
C Switch on horizontal interpolation if new land sea mask is UDG6F304.5
C different from that in dump. UDG6F304.6
IF(LSM)THEN UDG6F304.7
DO I=1,P_FIELD_OUT UDG6F304.8
IF(.NOT.HORIZ)THEN UDG6F304.9
IF(ID1_IN(I).NE.ID1_OUT(I))THEN UDG6F304.10
HORIZ=.TRUE. UDG6F304.11
WRITE UDG6F304.12
& (6,*) ' HORIZONTAL INTERPOLATION SWITCHED ON BECAUSE'// UDG6F304.13
& ' LAND SEA MASK IS BEING CHANGED' UDG6F304.14
ENDIF UDG6F304.15
ENDIF UDG6F304.16
ENDDO UDG6F304.17
ENDIF UDG6F304.18
UDG6F304.19
IF(HORIZ)THEN UDG2F400.4
UDG2F400.5
*IF DEF,TIMER CONTROL1.603
CALL TIMER('COAST_AJ',3) CONTROL1.604
*ENDIF CONTROL1.605
CONTROL1.606
CALL COAST_AJ(BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.146
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.147
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.148
*,ROW_LENGTH_IN,P_ROWS_IN,P_FIELD_OUT,ID1_IN CONTROL1.609
*,ID1_OUT,INDEX_OUT,INDEX_IN,COASTAL_POINTS,MASK CONTROL1.610
*,INDEX_TARG_SEA,SEA_POINTS_UNRES,INDEX_TARG_LAND CONTROL1.611
*,LAND_POINTS_UNRES) CONTROL1.612
CONTROL1.613
*IF DEF,TIMER CONTROL1.614
CALL TIMER('COAST_AJ',4) CONTROL1.615
*ENDIF CONTROL1.616
CONTROL1.617
C Convert l/s mask back to logical CONTROL1.618
DO I=1,P_FIELD_OUT CONTROL1.619
LAND_SEA_MASK_OUT(I)=.FALSE. CONTROL1.620
IF(ID1_OUT(I).NE.0)LAND_SEA_MASK_OUT(I)=.TRUE. CONTROL1.621
ENDDO CONTROL1.622
CONTROL1.623
WRITE(6,'('' COASTAL PTS ='',I10)')COASTAL_POINTS CONTROL1.624
WRITE(6,'('' UNRES SEA PTS ='',I10)')SEA_POINTS_UNRES CONTROL1.625
WRITE(6,'('' UNRES LAND PTS ='',I10)')LAND_POINTS_UNRES CONTROL1.626
CONTROL1.627
WRITE (6,'(/,'' Input Land Sea Mask.'')') GDR3F400.15
IJ=1 CONTROL1.628
DO K=1,P_ROWS_IN GDR3F400.16
IJMIN=MIN(IJ+149,IJ+ROW_LENGTH_IN-1) GDR3F400.17
WRITE(6,'('' '',150I1)')(ID1_IN(I),I=IJ,IJMIN) GDR3F400.18
IJ=IJ+ROW_LENGTH_IN CONTROL1.631
ENDDO CONTROL1.632
CONTROL1.639
C Calculate no of output land points and store in integer header CONTROL1.640
LAND_POINTS_OUT=0 CONTROL1.641
DO I=1,P_FIELD_OUT CONTROL1.642
IF(LAND_SEA_MASK_OUT(I))LAND_POINTS_OUT=LAND_POINTS_OUT+1 CONTROL1.643
ENDDO CONTROL1.644
UDG1F404.7
! Check number of land points against that specified in UDG1F404.8
! namelist RECON UDG1F404.9
IF(LAND_POINTS_OUT.NE.LAND_POINTS_UMUI)THEN UDG1F404.10
write(6,*) 'ERROR : Reconfiguration CONTROL' UDG1F404.11
write(6,'(''No of land points in output Land-sea mask = '' UDG1F404.12
& ,I6)') LAND_POINTS_OUT UDG1F404.13
write(6,'(''No of land points specified in namelist RECON = '' UDG1F404.14
& ,I6)') LAND_POINTS_UMUI UDG1F404.15
write(6,'(''Please reprocess the job with the correct number'' UDG1F404.16
& ,'' of land points in UMUI panel'' )') UDG1F404.17
CALL ABORT UDG1F404.18
END IF UDG1F404.19
UDG1F404.20
INTHD_OUT(25)=LAND_POINTS_OUT CONTROL1.646
CONTROL1.647
C------------------------------------------------------------------ CONTROL1.648
C Set up gather indices to satify unresolved land and sea points CONTROL1.649
C------------------------------------------------------------------ CONTROL1.650
CONTROL1.651
C Compute gather index for sea points minus unresolved points CONTROL1.652
CONTROL1.653
IF(.NOT.LSPIRAL_S)THEN UDG1F304.37
DO I=1,P_FIELD_OUT CONTROL1.654
LAND_SEA_MASK(I)=.NOT.LAND_SEA_MASK_OUT(I) CONTROL1.655
ENDDO CONTROL1.656
DO I=1,SEA_POINTS_UNRES CONTROL1.657
IF(.NOT.LAND_SEA_MASK_OUT(INDEX_TARG_SEA(I))) CONTROL1.658
* LAND_SEA_MASK(INDEX_TARG_SEA(I))=.FALSE. CONTROL1.659
ENDDO CONTROL1.660
CONTROL1.661
LAND_POINTS = 0 GSS9F402.54
DO I=1,P_FIELD_OUT GSS9F402.55
IF(LAND_SEA_MASK(I))THEN GSS9F402.56
LAND_POINTS=LAND_POINTS + 1 GSS9F402.57
LAND_SEA_INDEX(LAND_POINTS) = I GSS9F402.58
END IF GSS9F402.59
END DO GSS9F402.60
CONTROL1.664
C Assign each unresolved sea pt to nearest non-unresolved sea pt CONTROL1.665
CONTROL1.666
DO I=1,SEA_POINTS_UNRES CONTROL1.667
CONTROL1.668
IF(INDEX_TARG_SEA(I).LE.LAND_SEA_INDEX(1))THEN CONTROL1.669
SEA_UNRES_INDEX(I)=LAND_SEA_INDEX(1) CONTROL1.670
CONTROL1.671
ELSEIF(INDEX_TARG_SEA(I).GT.LAND_SEA_INDEX(LAND_POINTS))THEN CONTROL1.672
CONTROL1.673
SEA_UNRES_INDEX(I)=LAND_SEA_INDEX(LAND_POINTS) CONTROL1.674
CONTROL1.675
ELSE CONTROL1.676
CONTROL1.677
DO KK=1,LAND_POINTS-1 CONTROL1.678
IF(INDEX_TARG_SEA(I).GE.LAND_SEA_INDEX(KK).AND. CONTROL1.679
* INDEX_TARG_SEA(I).LT.LAND_SEA_INDEX(KK+1))THEN CONTROL1.680
SEA_UNRES_INDEX(I)=LAND_SEA_INDEX(KK) CONTROL1.681
ENDIF CONTROL1.682
ENDDO CONTROL1.683
CONTROL1.684
ENDIF CONTROL1.685
ENDDO CONTROL1.686
CONTROL1.687
C Compute gather index for land points minus unresolved points CONTROL1.688
CONTROL1.689
DO I=1,P_FIELD_OUT CONTROL1.690
LAND_SEA_MASK(I)=LAND_SEA_MASK_OUT(I) CONTROL1.691
ENDDO CONTROL1.692
DO I=1,LAND_POINTS_UNRES CONTROL1.693
IF(LAND_SEA_MASK_OUT(INDEX_TARG_LAND(I))) CONTROL1.694
* LAND_SEA_MASK(INDEX_TARG_LAND(I))=.FALSE. CONTROL1.695
ENDDO CONTROL1.696
CONTROL1.697
LAND_POINTS = 0 GSS9F402.61
DO I=1,P_FIELD_OUT GSS9F402.62
IF(LAND_SEA_MASK(I))THEN GSS9F402.63
LAND_POINTS=LAND_POINTS + 1 GSS9F402.64
LAND_SEA_INDEX(LAND_POINTS) = I GSS9F402.65
END IF GSS9F402.66
END DO GSS9F402.67
CONTROL1.700
C Assign each unresolved land pt to nearest non-unresolved land pt CONTROL1.701
CONTROL1.702
DO I=1,LAND_POINTS_UNRES CONTROL1.703
CONTROL1.704
IF(INDEX_TARG_LAND(I).LE.LAND_SEA_INDEX(1))THEN CONTROL1.705
CONTROL1.706
LAND_UNRES_INDEX(I)=LAND_SEA_INDEX(1) CONTROL1.707
CONTROL1.708
ELSEIF(INDEX_TARG_LAND(I).GT.LAND_SEA_INDEX(LAND_POINTS))THEN CONTROL1.709
CONTROL1.710
LAND_UNRES_INDEX(I)=LAND_SEA_INDEX(LAND_POINTS) CONTROL1.711
CONTROL1.712
ELSE CONTROL1.713
CONTROL1.714
DO KK=1,LAND_POINTS-1 CONTROL1.715
IF(INDEX_TARG_LAND(I).GE.LAND_SEA_INDEX(KK).AND. CONTROL1.716
* INDEX_TARG_LAND(I).LT.LAND_SEA_INDEX(KK+1))THEN CONTROL1.717
LAND_UNRES_INDEX(I)=LAND_SEA_INDEX(KK) CONTROL1.718
ENDIF CONTROL1.719
ENDDO CONTROL1.720
CONTROL1.721
ENDIF CONTROL1.722
ENDDO CONTROL1.723
CONTROL1.724
ENDIF UDG1F304.38
UDG2F400.6
ELSE ! if (horiz) then UDG2F400.7
UDG2F400.8
C Convert land/sea mask back to logical UDG2F400.9
UDG2F400.10
DO I=1,P_FIELD_OUT UDG2F400.11
LAND_SEA_MASK_OUT(I)=.FALSE. UDG2F400.12
IF(ID1_IN(I).NE.0)LAND_SEA_MASK_OUT(I)=.TRUE. UDG2F400.13
ENDDO UDG2F400.14
UDG2F400.15
C Calculate no of output land points and store in integer header UDG2F400.16
UDG2F400.17
LAND_POINTS_OUT=0 UDG2F400.18
DO I=1,P_FIELD_OUT UDG2F400.19
IF(LAND_SEA_MASK_OUT(I))LAND_POINTS_OUT=LAND_POINTS_OUT+1 UDG2F400.20
ENDDO UDG2F400.21
UDG1F404.21
! Check number of land points against that specified in UDG1F404.22
! namelist RECON UDG1F404.23
IF(LAND_POINTS_OUT.NE.LAND_POINTS_UMUI)THEN UDG1F404.24
write(6,*) 'ERROR : Reconfiguration CONTROL' UDG1F404.25
write(6,'(''No of land points in output Land-sea mask = '' UDG1F404.26
& ,I6)') LAND_POINTS_OUT UDG1F404.27
write(6,'(''No of land points specified in namelist RECON = '' UDG1F404.28
& ,I6)') LAND_POINTS_UMUI UDG1F404.29
write(6,'(''Please reprocess the job with the correct number'' UDG1F404.30
& ,'' of land points in UMUI panel'')') UDG1F404.31
CALL ABORT UDG1F404.32
END IF UDG1F404.33
INTHD_OUT(25)=LAND_POINTS_OUT UDG2F400.23
ENDIF UDG2F400.24
ENDIF CONTROL1.725
GDR3F400.19
WRITE (6,'(/,'' Output Land Sea Mask.'')') GDR3F400.20
IJ=1 GDR3F400.21
DO K=1,P_ROWS_OUT GDR3F400.22
IJMIN=MIN(IJ+149,IJ+ROW_LENGTH_OUT-1) GDR3F400.23
IF(HORIZ)THEN UDG3F402.164
WRITE(6,'('' '',150I1)')(ID1_OUT(I),I=IJ,IJMIN) UDG3F402.165
ELSE UDG3F402.166
WRITE(6,'('' '',150I1)')(ID1_IN(I),I=IJ,IJMIN) UDG3F402.167
END IF UDG3F402.168
IJ=IJ+ROW_LENGTH_OUT GDR3F400.25
ENDDO GDR3F400.26
WRITE(6,'(''No. of land points='',I6)')LAND_POINTS_OUT UDG1F404.34
UDG1F404.35
CONTROL1.726
ENDIF ! Not PFinc2UM UIE2F401.212
C------------------------------------------------------------------ CONTROL1.727
C Set up LOOKUP headers for output file CONTROL1.728
C------------------------------------------------------------------ CONTROL1.729
CONTROL1.730
*IF DEF,TIMER CONTROL1.731
CALL TIMER('CONVLOOK',3) CONTROL1.732
*ENDIF CONTROL1.733
CONTROL1.734
CALL CONVLOOK(VERT,N_TYPES_IN,PP_NUM_IN, UDG7F400.134
& LEN_FIXHD_OUT,FIXHD_OUT,FIXHD_OUT(4),FIXHD_OUT(11), UDG7F400.135
& LEN_REALHD_OUT,REALHD_OUT,PP_ITEMC_IN, UDG7F400.136
& OZONE_LEVELS_IN, UDG7F400.137
& LEN2_LEVDEPC_OUT,LEN1_LEVDEPC_OUT,LEVDEPC_OUT, UDG7F400.138
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT, UDG7F400.139
& LOOKUP_OUT,LOOKUP_OUT, UDG7F400.140
& LEN1_LOOKUP_IN,LEN2_LOOKUP_IN, UDG7F400.141
& LOOKUP_IN,LOOKUP_IN, UDG7F400.142
& ROW_LENGTH_OUT,P_ROWS_OUT, UDG7F400.143
& P_LEVELS_OUT,Q_LEVELS_OUT,ST_LEVELS_OUT, UJS1F401.31
& SM_LEVELS_OUT,BL_LEVELS_OUT,OZONE_LEVELS_OUT, UJS1F401.32
& U_ROWS_OUT,U_FIELD_OUT,P_FIELD_OUT,PP_AREA_OUT, UDG7F400.146
& P_LEVELS_IN,Q_LEVELS_IN,ST_LEVELS_IN,SM_LEVELS_IN, UJS1F401.33
& PP_SOURCE_OUT,R_NAMELIST,C_NAMELIST,J_NAMELIST, UJS1F401.34
& POINTS_PER_OCEAN_LEVEL,GRID_TYPE,DUMP_PACK, GDR2F401.14
*CALL ARGPPX UDG7F400.150
& LAND_POINTS_OUT,LEN_DATA_OUT,OCEAN,LCAL360, UDG7F400.151
& C_GRID_IN,C_GRID_OUT, UIE2F401.18
& LOZONE_ZONAL) UDG7F400.152
c GBC5F404.28
c--reset the disk addresses and lengths for well-formed I/O GBC5F404.29
call set_dumpfile_address(fixhd_out, len_fixhd_out, GBC5F404.30
& lookup_out, len1_lookup_out, GBC5F404.31
& len2_lookup_out, GBC5F404.32
& number_of_data_words_in_memory, GBC5F404.33
& number_of_data_words_on_disk, GBC5F404.34
& disk_address) GBC5F404.35
UDG7F400.153
CONTROL1.747
*IF DEF,TIMER CONTROL1.748
CALL TIMER('CONVLOOK',4) CONTROL1.749
*ENDIF CONTROL1.750
c--set the new length for the dumpfile to the I/O Routines GBC6F404.6
call set_dumpfile_length(nftout, disk_address) GBC6F404.7
c--now open the file with contiguous storage if possible GBC6F404.8
if(.not.ocean) then GBC6F404.9
call file_open (nftout, 'ASTART', 6, 1, 0, err) GBC6F404.10
else GBC6F404.11
call file_open (nftout, 'OSTART', 6, 1, 0, err) GBC6F404.12
endif GBC6F404.13
CONTROL1.751
ALLOCATE (D1_IN(P_FIELD_IN*P_LEVELS_IN+P_FIELD_IN),STAT=STATUS) UDG4F405.31
ALLOCATE (D1_OUT(LEN_ANCIL),STAT=STATUS) UDG4F405.32
ALLOCATE (D1_TMP(P_FIELD_OUT*P_LEVELS_IN+P_FIELD_OUT),STAT=STATUS) UDG4F405.33
ALLOCATE (D1_TEMP(P_FIELD_OUT),STAT=STATUS) UDG4F405.34
ALLOCATE (D1_IN_TMP(P_FIELD_IN*SM_LEVELS_IN),STAT=STATUS) UDG4F405.35
ALLOCATE (P_TMP(P_FIELD_OUT*P_LEVELS_IN+P_FIELD_OUT),STAT=STATUS) UDG4F405.36
ALLOCATE (PSTAR_OUT(P_FIELD_OUT),STAT=STATUS) UDG4F405.37
ALLOCATE (P_OUT(P_FIELD_OUT),STAT=STATUS) UDG4F405.38
ALLOCATE (P_HALF_TMP(P_FIELD_OUT,P_LEVELS_OUT+1),STAT=STATUS) UDG4F405.39
ALLOCATE (P_EXNER_HALF_TMP(P_FIELD_OUT,P_LEVELS_OUT+1), UDG4F405.40
& STAT=STATUS) UDG4F405.41
ALLOCATE (TOPOG_OUT(P_FIELD_OUT),STAT=STATUS) UDG4F405.42
ALLOCATE (TOPOG_OLD(P_FIELD_OUT),STAT=STATUS) UDG4F405.43
ALLOCATE (THR_OUT(P_FIELD_OUT),STAT=STATUS) UDG4F405.44
UDG4F405.45
! Initialise D1_OUT UDG4F405.46
DO K=1,LEN_ANCIL UDG4F405.47
D1_OUT(K)=0.0 UDG4F405.48
END DO UDG4F405.49
UDG4F405.50
! Initialise D1_TEMP UDG4F405.51
DO K=1,P_FIELD_OUT UDG4F405.52
D1_TEMP(K)=0.0 UDG4F405.53
END DO UDG4F405.54
UDG4F405.55
C------------------------------------------------------------------ CONTROL1.752
C Find number of different outfield types and their characteristics CONTROL1.753
C------------------------------------------------------------------ CONTROL1.754
CONTROL1.755
CONTROL1.756
*IF DEF,TIMER CONTROL1.757
CALL TIMER('F_TYPE ',3) CONTROL1.758
*ENDIF CONTROL1.759
CONTROL1.760
F_TYPE_TITLE='Output data' UDG7F400.154
CALL F_TYPE(LOOKUP_OUT,LEN2_LOOKUP_OUT,PP_NUM_OUT,N_TYPES_OUT, UDG7F400.155
& PP_LEN_OUT,PP_ITEMC_OUT,PP_TYPE_OUT,PP_POS_OUT, UDG7F400.156
& PP_LS_OUT,FIXHD_OUT, UDG7F400.157
*CALL ARGPPX UDG7F400.158
& F_TYPE_TITLE) UDG7F400.159
UDG7F400.160
*IF DEF,TIMER CONTROL1.765
CALL TIMER('F_TYPE ',4) CONTROL1.766
*ENDIF CONTROL1.767
CONTROL1.768
C Convert PP_SOURCE_OUT & PP_AREA_OUT to store values by field code CONTROL1.769
DO K=1,N_TYPES_OUT CONTROL1.770
PP_SOURCE_OUT(K)=PP_SOURCE_OUT(PP_POS_OUT(K)) CONTROL1.771
PP_AREA_OUT(K)=PP_AREA_OUT(PP_POS_OUT(K)) CONTROL1.772
J_NAMELIST(K)=J_NAMELIST(PP_POS_OUT(K)) UDG3F403.18
R_NAMELIST(K)=R_NAMELIST(PP_POS_OUT(K)) UDG3F403.19
C_NAMELIST(K)=C_NAMELIST(PP_POS_OUT(K)) UDG3F403.20
ENDDO CONTROL1.773
CONTROL1.802
C--------------------------------------------------------------- CONTROL1.803
C Write out new header info CONTROL1.804
C--------------------------------------------------------------- CONTROL1.805
CONTROL1.806
*IF DEF,TIMER CONTROL1.807
CALL TIMER('WRITHEAD',3) CONTROL1.808
*ENDIF CONTROL1.809
CONTROL1.810
CALL WRITHEAD(NFTOUT,FIXHD_OUT,LEN_FIXHD_OUT, GDG0F401.245
& INTHD_OUT,LEN_INTHD_OUT, GDG0F401.246
& REALHD_OUT,LEN_REALHD_OUT, GDG0F401.247
& LEVDEPC_OUT,LEN1_LEVDEPC_OUT,LEN2_LEVDEPC_OUT, GDG0F401.248
& ROWDEPC_OUT,LEN1_ROWDEPC_OUT,LEN2_ROWDEPC_OUT, GDG0F401.249
& COLDEPC_OUT,LEN1_COLDEPC_OUT,LEN2_COLDEPC_OUT, GDG0F401.250
& FLDDEPC_OUT,LEN1_FLDDEPC_OUT,LEN2_FLDDEPC_OUT, GDG0F401.251
& EXTCNST_OUT,LEN_EXTCNST_OUT, GDG0F401.252
& DUMPHIST_OUT,LEN_DUMPHIST_OUT, GDG0F401.253
& CFI1_OUT,LEN_CFI1_OUT, GDG0F401.254
& CFI2_OUT,LEN_CFI2_OUT, GDG0F401.255
& CFI3_OUT,LEN_CFI3_OUT, GDG0F401.256
& LOOKUP_OUT,LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT, GDG0F401.257
& LEN_DATA_OUT, GDG0F401.258
*CALL ARGPPX GDG0F401.259
& START_BLOCK_OUT,ICODE,CMESSAGE) GDG0F401.260
CONTROL1.826
*IF DEF,TIMER CONTROL1.827
CALL TIMER('WRITHEAD',4) CONTROL1.828
*ENDIF CONTROL1.829
CONTROL1.830
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.831
CONTROL1.832
C Logical to indicate horizontal interpolation of form Global/Hem -> LAM CONTROL1.833
GH_TO_LAM=FIXHD_IN(4).LT.3.AND.FIXHD_OUT(4).GT.2 CONTROL1.834
C Logical to indicate output grid is rotated CONTROL1.835
ROT_OUT=REALHD_OUT(5).NE.90..OR.REALHD_OUT(6).NE.0. CONTROL1.836
CONTROL1.837
C Logical to indicate input grid is rotated CONTROL1.838
ROT_IN=REALHD_IN(5).NE.90..OR.REALHD_IN(6).NE.0. CONTROL1.839
CONTROL1.840
IF(.NOT.OCEAN)THEN CONTROL1.841
CONTROL1.842
C Calculate AKH and BKH CONTROL1.843
AKH_OUT(1)=0. CONTROL1.844
BKH_OUT(1)=1. CONTROL1.845
DO K=2,P_LEVELS_OUT+1 CONTROL1.846
AKH_OUT(K)=AKH_OUT(K-1)+LEVDEPC_OUT(K-1+2*P_LEVELS_OUT) CONTROL1.847
BKH_OUT(K)=BKH_OUT(K-1)+LEVDEPC_OUT(K-1+3*P_LEVELS_OUT) CONTROL1.848
ENDDO CONTROL1.849
CONTROL1.850
ENDIF CONTROL1.851
CONTROL1.852
C--------------------------------------------------------------- CONTROL1.853
C Check for error in file pointers CONTROL1.854
C--------------------------------------------------------------- CONTROL1.855
CONTROL1.856
lbnrec=30 GBC5F404.36
real_start_block=start_block_out GBC5F404.37
if(start_block_out.eq.fixhd_out(160)) then GBC5F404.38
C If new format Dumpfile, we must reset the start address GBC5F404.39
if((lookup_out(lbnrec,1).ne.0) .or. GBC5F404.40
C Prog lookups in dump before vn3.2: GBC5F404.41
2 ((lookup_out(lbnrec,1).eq.imdi) .and. GBC5F404.42
3 (fixhd_out(12).le.301))) then GBC5F404.43
CALL POSERROR('output model data', CONTROL1.858
* START_BLOCK_OUT,160,FIXHD_OUT(160)) CONTROL1.859
CALL ABORT CONTROL1.860
else GBC5F404.44
real_start_block=fixhd_out(160) GBC5F404.45
endif GBC5F404.46
ENDIF CONTROL1.861
CONTROL1.862
IF(.NOT.(RadialGridIn.AND..NOT.RadialGridOut))THEN UIE2F401.207
IF(.NOT.(RM_CP))THEN UDG6F405.78
! Do not write LAND-SEA mask to UM increment dump UDG6F405.79
C--------------------------------------------------------------- CONTROL1.863
C Write out new land/sea mask CONTROL1.864
C--------------------------------------------------------------- CONTROL1.865
CONTROL1.866
IF(.NOT.OCEAN)THEN CONTROL1.867
CONTROL1.868
CALL LOCATE(30,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.869
IF(POS.EQ.0)THEN CONTROL1.870
WRITE(6,'('' *ERROR* L/S mask not in output file'')') CONTROL1.871
CALL ABORT CONTROL1.872
ENDIF CONTROL1.873
CONTROL1.874
*IF DEF,TIMER CONTROL1.875
CALL TIMER('WRITFLDS',3) CONTROL1.876
*ENDIF CONTROL1.877
CONTROL1.878
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.261
& LAND_SEA_MASK_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.262
*CALL ARGPPX GDG0F401.263
& ICODE,CMESSAGE) GDG0F401.264
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.881
CONTROL1.882
*IF DEF,TIMER CONTROL1.883
CALL TIMER('WRITFLDS',4) CONTROL1.884
*ENDIF CONTROL1.885
CONTROL1.886
ENDIF CONTROL1.887
ENDIF ! Not RM_CP UDG6F405.80
CONTROL1.888
ENDIF ! Not PFinc2UM UIE2F401.208
CONTROL1.889
C--------------------------------------------------------------------- CONTROL1.890
C If source grid rotated, then read in U & V fields from input CONTROL1.891
C file, rotate winds to standard grid and then write back to input file. CONTROL1.892
C--------------------------------------------------------------------- CONTROL1.893
CONTROL1.894
IF(ROT_IN.AND.HORIZ)THEN UDG4F400.4
CONTROL1.896
! Locate start position of u & v fields on I/P file UIE2F401.110
IF (C_GRID_IN) THEN UIE2F401.111
CALL LOCATE(153,PP_ITEMC_IN,N_TYPES_IN,POSU) UIE2F401.112
CALL LOCATE(154,PP_ITEMC_IN,N_TYPES_IN,POSV) UIE2F401.113
ELSE UIE2F401.114
CALL LOCATE(2,PP_ITEMC_IN,N_TYPES_IN,POSU) UIE2F401.115
CALL LOCATE(3,PP_ITEMC_IN,N_TYPES_IN,POSV) UIE2F401.116
END IF UIE2F401.117
UIE2F401.118
! Find number of levels in I/P dump. UIE2F401.119
N_FIELDS_IN=PP_NUM_IN(POSU) UIE2F401.120
UIE2F401.121
! ROTATE dimensions u,v separately to take account of UIE2F401.122
! the extra u row (v unchanged) on the C grid. UIE2F401.123
CALL ROTATE( UIE2F401.124
*CALL ARGPPX UIE2F401.125
& PP_ITEMC_IN,PP_NUM_IN,PP_POS_IN,N_TYPES_IN, UIE2F401.126
& LOOKUP_IN,FIXHD_IN,U_FIELD_IN,COEFF3,COEFF4, UIE2F401.127
& NFTIN,0,C_GRID_OUT,C_GRID_IN,N_FIELDS_IN, UIE2F401.128
& U_ROWS_IN,U_ROWS_OUT,REALHD_IN, UIE2F404.354
& ROW_LENGTH_OUT,ROW_LENGTH_IN,POSU,POSV) UIE2F401.129
CONTROL1.899
ENDIF CONTROL1.900
CONTROL1.901
C--------------------------------------------------------------- CONTROL1.902
C Convert to THL & QT only if input file contains TH (& therefore Q) CONTROL1.903
C--------------------------------------------------------------- CONTROL1.904
CONTROL1.905
IF(.NOT.OCEAN)THEN CONTROL1.906
CONTROL1.907
UIE2F404.131
! Do not enter TH_TO_THL for VAR PF dump as UIE2F404.132
! conversion to THL,QT takes place in subroutine PF2UM later. UIE2F404.133
IF ((.NOT.(RadialGridIn).AND..NOT.(RadialGridOut)) .OR. UIE2F404.134
& (.NOT.(RadialGridIn).AND.RadialGridOut)) THEN UIE2F404.135
IF(.NOT.(RM_CP))THEN UDG6F405.40
UIE2F404.136
CALL TH_TO_THL( GDG0F401.265
*CALL ARGPPX GDG0F401.266
& FIXHD_IN,LOOKUP_IN,LEVDEPC_IN,PP_ITEMC_IN, GDG0F401.267
& PP_POS_IN,N_TYPES_IN,NFTIN, GDG0F401.268
& P_FIELD_IN,P_LEVELS_IN,Q_LEVELS_IN,BL_LEVELS_IN) GDG0F401.269
CONTROL1.911
UDG6F405.41
ENDIF ! RM_CP UDG6F405.42
ENDIF ! Not PFinc2UM UDG6F405.43
UIE2F404.137
ENDIF UIE2F404.138
CONTROL1.913
!--------------------------------------------------------------- UDG4F404.16
! Adjust THL and QT if QCF in input dump but not in output dump UDG4F404.17
!--------------------------------------------------------------- UDG4F404.18
IF(.NOT.OCEAN)THEN UDG4F404.19
CALL THL_QT_ADJ(N_TYPES_IN,P_FIELD_IN,P_LEVELS_IN,Q_LEVELS_IN, UDG4F404.20
& NFTIN,L_MP_PRECIP,LOOKUP_IN,FIXHD_IN, UDG4F404.21
& LEN1_LEVDEPC_IN,LEN2_LEVDEPC_IN,LEVDEPC_IN, UDG4F404.22
*CALL ARGPPX UDG4F404.23
& PP_ITEMC_IN,PP_POS_IN) UDG4F404.24
END IF UDG4F404.25
IF(.NOT.(RadialGridIn.AND..NOT.RadialGridOut))THEN UIE2F401.209
C--------------------------------------------------------------- CONTROL1.914
C Read in ancillary fields CONTROL1.915
C--------------------------------------------------------------- CONTROL1.916
CONTROL1.917
IF(.NOT.OCEAN)THEN CONTROL1.918
CONTROL1.919
C Set up switch to control which ancillary fields are read in CONTROL1.920
DO K=1,NANCIL_FIELDS GDR1F401.23
SWITCH(K)=0 CONTROL1.922
ENDDO CONTROL1.923
CONTROL1.924
DO J=1,N_TYPES_OUT CONTROL1.925
CONTROL1.926
UDG4F304.57
IF(PP_SOURCE_OUT(J).EQ.2)THEN UDG4F304.64
CONTROL1.928
IF(PP_ITEMC_OUT(J).EQ.39)THEN CONTROL1.929
SSTANOM=.TRUE. CONTROL1.930
ELSE CONTROL1.931
CONTROL1.932
DO K=1,NANCIL_FIELDS GDR1F401.24
IF(PP_ITEMC_OUT(J).EQ.ITEM_CODES_ANCIL(K))THEN CONTROL1.934
SWITCH(K)=1 CONTROL1.935
C If one surface current specified then update the other CONTROL1.936
IF(PP_ITEMC_OUT(J).EQ.28)SWITCH(31)=1 CONTROL1.937
IF(PP_ITEMC_OUT(J).EQ.29)SWITCH(30)=1 CONTROL1.938
GOTO 1127 CONTROL1.939
ENDIF CONTROL1.940
ENDDO CONTROL1.941
CONTROL1.942
WRITE(6,'('' *ERROR* Requested ancillary field not'', CONTROL1.943
*'' supported: STASH Item code ='',I5)')PP_ITEMC_OUT(J) CONTROL1.944
1127 CONTINUE CONTROL1.945
ENDIF CONTROL1.946
CONTROL1.947
ENDIF CONTROL1.948
CONTROL1.949
ENDDO CONTROL1.950
CONTROL1.951
! Determine if Ozone Ancillary file is required. UDG6F400.8
LOZONE_ANC = .FALSE. UDG6F400.9
CALL LOCATE (60,pp_itemc_in,n_types_in,pos_in) UDG6F400.10
CALL LOCATE (60,pp_itemc_out,n_types_out,pos_out) UDG6F400.11
UDG6F400.12
IF (POS_OUT.GT.0) THEN ! Ozone fields in output dump UDG6F400.13
IF (POS_IN.GT.0) THEN ! Ozone fields in input dump UDG6F400.14
UDG6F400.15
ZONAL_IN = LOOKUP_IN (19,PP_POS_IN (POS_IN) ) .EQ. 1 UDG6F400.16
ZONAL_OUT = LOOKUP_OUT(19,PP_POS_OUT(POS_OUT)) .EQ. 1 UDG6F400.17
UDG6F400.18
IF (ZONAL_IN .and. ZONAL_OUT) THEN UDG6F400.19
! Allow interpolation between zonal fields UDG6F400.20
WRITE(6,*) ' ' UDG6F400.21
WRITE(6,*) ' Warning : Ozone data is zonal in both ', UDG6F400.22
& 'input and output dumps.' UDG6F400.23
WRITE(6,*) ' If an ozone ancillary file is not provided,' UDG6F400.24
WRITE(6,*) ' output data is interpolated from input data.' UDG6F400.25
! mod to convert the .xor. to .neqv. to compile the reconfiguration UIE2F404.1
! code with the Nag compiler. UIE2F404.2
ELSEIF (ZONAL_IN .NEQV. ZONAL_OUT) THEN UIE2F404.3
LOZONE_ANC = .TRUE. UDG6F400.27
ELSE ! Full fields in both input and output dumps UDG6F400.28
! Allow interpolation between full fields GDR9F401.1
ENDIF UDG6F400.35
UDG6F400.36
ELSEIF (POS_IN.EQ.0) THEN ! No ozone fields in input dump UDG6F400.37
LOZONE_ANC = .TRUE. UDG6F400.38
ENDIF UDG6F400.39
ENDIF UDG6F400.40
UDG6F400.41
IF (LOZONE_ANC) THEN ! Ozone anc file required UDG6F400.42
UDG6F400.43
! Check that it has been provided UDG6F400.44
DO K=1,NANCIL_FIELDS GDR1F401.25
IF (ITEM_CODES_ANCIL(K).EQ.60 .AND. SWITCH(K).EQ.0) THEN UDG6F400.46
WRITE (6,*) ' ** ERROR ** ERROR **' GDR9F401.2
WRITE (6,*) ' Reconfiguration is expecting an ozone ', UDG6F400.47
& 'ancillary file. Provide one through the UMUI.' UDG6F400.48
CMESSAGE = 'CONTROL : Ozone Ancillary file required.' UDG6F400.49
WRITE (6,*) ' CMESSAGE : ',CMESSAGE GDR9F401.3
CALL ABORT UDG6F400.50
ENDIF UDG6F400.51
ENDDO UDG6F400.52
UDG6F400.53
ENDIF UDG6F400.54
UDG6F400.55
*IF DEF,TIMER CONTROL1.952
CALL TIMER('INANCILA',3) CONTROL1.953
*ENDIF CONTROL1.954
CONTROL1.955
CALL INANCILA(LEN_FIXHD_OUT,PP_LEN_INTHD,PP_LEN_REALHD, CONTROL1.956
*LEN1_LEVDEPC_OUT,PP_LEN2_LEVDEPC,FIXHD_ANCIL,INTHD_ANCIL, CONTROL1.957
*REALHD_ANCIL,LOOKUP_ANCIL, AJS1F400.125
*FIXHD_OUT,REALHD_OUT,LEVDEPC_OUT,NDATASETS, AJS1F400.126
*NLOOKUPS,FTN_ANCIL,LOOKUP_START,LEN1_LOOKUP_OUT,ROW_LENGTH_OUT, CONTROL1.959
*P_ROWS_OUT,U_ROWS_OUT,P_LEVELS_OUT,TR_LEVELS_OUT, UJS1F401.35
*ST_LEVELS_OUT,SM_LEVELS_OUT,OZONE_LEVELS_OUT,TITLE, UJS1F401.36
&SWITCH,NANCIL_FIELDS,SSTANOM,ANCIL_ADD, GDR1F401.26
*CALL ARGPPX GDR1F401.27
&IOUNIT,ICODE,CMESSAGE,LCAL360) GDR1F401.28
IF(ICODE.NE.0)CALL ABORT_IO('INANCILA',CMESSAGE,ICODE,IOUNIT) CONTROL1.963
CONTROL1.964
*IF DEF,TIMER CONTROL1.965
CALL TIMER('INANCILA',4) CONTROL1.966
*ENDIF CONTROL1.967
CONTROL1.968
WRITE(6,'('' '')') ADR1F304.41
WRITE(6,'('' Ancillary Fields requested:(1=Y,0=N)'')') CONTROL1.969
WRITE(6,'('' Field File Stash'')') ADR1F304.42
WRITE(6,'('' No Y/N No Code '')') ADR1F304.43
DO K=1,NANCIL_FIELDS GDR1F401.29
PHRASE=' ' CONTROL1.971
CALL LOCATE(ITEM_CODES_ANCIL(K),PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.972
ID1_IN(42)=ITEM_CODES_ANCIL(K) CONTROL1.973
ITEM_CODE=MOD(ID1_IN(42),1000) UDG2F305.97
SECTION=(ID1_IN(42)-ITEM_CODE)/1000 UDG2F305.98
MODEL=MODEL_CODES_ANCIL(K) GDR1F401.30
IF(MODEL.EQ.0.AND.SECTION.EQ.0.AND.ITEM_CODE.EQ.0)THEN GDG2F405.92
! Ancillary not used in any configuration skip call to EXPPXC GDG2F405.93
ICODE = 1 GDG2F405.94
ELSE GDG2F405.95
PHRASE = EXPPXC(MODEL,SECTION,ITEM_CODE, GDG2F405.96
*CALL ARGPPX GDG2F405.97
& ICODE,CMESSAGE) GDG2F405.98
END IF GDG2F405.99
IF(ICODE.NE.0)THEN GDG0F401.270
!Don't Worry! Non-zero return code expected for unused ancillaries. UDG2F305.113
! ICODE reset to zero and program allowed to continue. UDG2F305.114
PHRASE = 'ANCILLARY NOT IN THIS CONFIGURATION' UDG2F305.115
ICODE = 0 UDG2F305.116
ENDIF UDG2F305.119
IF(K.EQ.28)PHRASE='Sea-surface temperature' CONTROL1.981
WRITE(6,'('' '',4I5,I7,3X,A80)')K,SWITCH(K), ADR1F304.44
* FILEANCIL(K),ITEM_CODES_ANCIL(K),ANCIL_ADD(K),PHRASE ADR1F304.45
ENDDO CONTROL1.984
WRITE(6,'('' '')') ADR1F304.46
CONTROL1.985
IF(.NOT.(RM_CP))THEN UDG6F405.44
C Sea Ice Fraction CONTROL1.986
CONTROL1.987
CALL LOCATE(31,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.988
IF(POS.EQ.0)THEN CONTROL1.989
WRITE(6,'('' *ERROR* sea-ice fraction not in input file'')') CONTROL1.990
CALL ABORT CONTROL1.991
ENDIF CONTROL1.992
CONTROL1.993
*IF DEF,TIMER CONTROL1.994
CALL TIMER('READFLDS',3) CONTROL1.995
*ENDIF CONTROL1.996
CONTROL1.997
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.271
& D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.272
*CALL ARGPPX GDG0F401.273
& ICODE,CMESSAGE) GDG0F401.274
IF(ICODE.EQ.1501)THEN UDG4F402.43
IF(LPOLARCHK)THEN UDG4F402.44
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.45
UDG4F402.46
! North polar row UDG4F402.47
RP_ROW_SUM=0 UDG4F402.48
DO I=1,ROW_LENGTH_IN UDG4F402.49
RP_ROW_SUM=RP_ROW_SUM+D1_IN(I) UDG4F402.50
END DO UDG4F402.51
DO I=1,ROW_LENGTH_IN UDG4F402.52
D1_IN(I)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.53
END DO UDG4F402.54
! South polar row UDG4F402.55
RP_ROW_SUM=0 UDG4F402.56
DO I=1,ROW_LENGTH_IN UDG4F402.57
RP_ROW_SUM= UDG4F402.58
& RP_ROW_SUM+D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.59
END DO UDG4F402.60
DO I=1,ROW_LENGTH_IN UDG4F402.61
D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.62
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.63
END DO UDG4F402.64
END IF UDG4F402.65
ELSE IF(ICODE.NE.0)THEN UDG4F402.66
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.67
END IF UDG4F402.68
CONTROL1.1001
*IF DEF,TIMER CONTROL1.1002
CALL TIMER('READFLDS',4) CONTROL1.1003
*ENDIF CONTROL1.1004
CONTROL1.1005
IF(HORIZ) THEN MC230493.11
MC230493.12
*IF DEF,TIMER CONTROL1.1006
CALL TIMER('HINTCTL',3) UDG1F400.150
*ENDIF CONTROL1.1008
CONTROL1.1009
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.151
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.152
&, GLOBAL,H_INT_TYPE UDG1F400.153
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.154
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.155
&, AW_COLAT_T(1,1),AW_LONG_L(1,1),D1_IN UDG1F400.156
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.157
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.158
&, ICE_FRAC) UDG1F400.159
CONTROL1.1014
*IF DEF,TIMER CONTROL1.1015
CALL TIMER('HINTCTL',4) UDG1F400.160
*ENDIF CONTROL1.1017
MC230493.13
IF(GLOBAL)THEN UDG4F402.516
! Horizontal interpolation has made polar rows non-constant UDG4F402.517
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.518
& 'non-constant' UDG4F402.519
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.520
UDG4F402.521
! North polar row UDG4F402.522
RP_ROW_SUM=0 UDG4F402.523
DO I=1,ROW_LENGTH_OUT UDG4F402.524
RP_ROW_SUM=RP_ROW_SUM+ICE_FRAC(I) UDG4F402.526
END DO UDG4F402.527
DO I=1,ROW_LENGTH_OUT UDG4F402.528
ICE_FRAC(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.529
END DO UDG4F402.530
! South polar row UDG4F402.531
RP_ROW_SUM=0 UDG4F402.532
DO I=1,ROW_LENGTH_OUT UDG4F402.533
RP_ROW_SUM= UDG4F402.536
& RP_ROW_SUM+ICE_FRAC((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG4F402.537
END DO UDG4F402.538
DO I=1,ROW_LENGTH_OUT UDG4F402.539
ICE_FRAC((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG4F402.540
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.541
END DO UDG4F402.542
END IF UDG4F402.543
ELSE MC230493.14
DO I=1,P_FIELD_OUT MC230493.15
ICE_FRAC(I)=D1_IN(I) MC230493.16
END DO MC230493.17
END IF MC230493.18
MC230493.19
CONTROL1.1018
ENDIF ! RM_CP UDG6F405.45
C Tstar CONTROL1.1019
CONTROL1.1020
CALL LOCATE(24,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.1021
IF(POS.EQ.0)THEN CONTROL1.1022
WRITE(6,'('' *ERROR* Tstar not in input file'')') CONTROL1.1023
CALL ABORT CONTROL1.1024
ENDIF CONTROL1.1025
CONTROL1.1026
*IF DEF,TIMER CONTROL1.1027
CALL TIMER('READFLDS',3) CONTROL1.1028
*ENDIF CONTROL1.1029
CONTROL1.1030
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.275
& D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.276
*CALL ARGPPX GDG0F401.277
& ICODE,CMESSAGE) GDG0F401.278
IF(ICODE.EQ.1501)THEN UDG4F402.69
IF(LPOLARCHK)THEN UDG4F402.70
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.71
UDG4F402.72
! North polar row UDG4F402.73
RP_ROW_SUM=0 UDG4F402.74
DO I=1,ROW_LENGTH_IN UDG4F402.75
RP_ROW_SUM=RP_ROW_SUM+D1_IN(I) UDG4F402.76
END DO UDG4F402.77
DO I=1,ROW_LENGTH_IN UDG4F402.78
D1_IN(I)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.79
END DO UDG4F402.80
! South polar row UDG4F402.81
RP_ROW_SUM=0 UDG4F402.82
DO I=1,ROW_LENGTH_IN UDG4F402.83
RP_ROW_SUM= UDG4F402.84
& RP_ROW_SUM+D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.85
END DO UDG4F402.86
DO I=1,ROW_LENGTH_IN UDG4F402.87
D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.88
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.89
END DO UDG4F402.90
END IF UDG4F402.91
ELSE IF(ICODE.NE.0)THEN UDG4F402.92
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.93
END IF UDG4F402.94
CONTROL1.1034
*IF DEF,TIMER CONTROL1.1035
CALL TIMER('READFLDS',4) CONTROL1.1036
*ENDIF CONTROL1.1037
CONTROL1.1038
IF(HORIZ) THEN MC230493.20
MC230493.21
*IF DEF,TIMER CONTROL1.1039
CALL TIMER('HINTCTL',3) UDG1F400.161
*ENDIF CONTROL1.1041
CONTROL1.1042
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.162
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.163
&, GLOBAL,H_INT_TYPE UDG1F400.164
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.165
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.166
&, AW_COLAT_T(1,1),AW_LONG_L(1,1),D1_IN UDG1F400.167
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.168
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.169
&, TSTAR) UDG1F400.170
CONTROL1.1047
*IF DEF,TIMER CONTROL1.1048
CALL TIMER('HINTCTL',4) UDG1F400.171
*ENDIF CONTROL1.1050
MC230493.22
IF(GLOBAL)THEN UDG4F402.544
! Horizontal Interpolation has made polar rows non-constant UDG4F402.545
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.546
& 'non-constant' UDG4F402.547
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.548
UDG4F402.549
! North polar row UDG4F402.550
RP_ROW_SUM=0 UDG4F402.551
DO I=1,ROW_LENGTH_OUT UDG4F402.552
RP_ROW_SUM=RP_ROW_SUM+TSTAR(I) UDG4F402.554
END DO UDG4F402.555
DO I=1,ROW_LENGTH_OUT UDG4F402.556
TSTAR(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.557
END DO UDG4F402.558
! South polar row UDG4F402.559
RP_ROW_SUM=0 UDG4F402.560
DO I=1,ROW_LENGTH_OUT UDG4F402.561
RP_ROW_SUM= UDG4F402.564
& RP_ROW_SUM+TSTAR((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG4F402.565
END DO UDG4F402.566
DO I=1,ROW_LENGTH_OUT UDG4F402.567
TSTAR((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG4F402.568
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.569
END DO UDG4F402.570
END IF UDG4F402.571
ELSE MC230493.23
DO I=1,P_FIELD_OUT MC230493.24
TSTAR(I)=D1_IN(I) MC230493.25
END DO MC230493.26
END IF MC230493.27
MC230493.28
IF(HORIZ)THEN UDG2F400.25
CONTROL1.1051
C Correct coastal points CONTROL1.1052
DO I=1,COASTAL_POINTS CONTROL1.1053
TSTAR(INDEX_OUT(I))=D1_IN(INDEX_IN(I)) CONTROL1.1054
ENDDO CONTROL1.1055
IF(LSPIRAL_S)THEN UDG1F304.39
MAXDIM=MIN0(P_ROWS_OUT,ROW_LENGTH_OUT) UDG1F304.40
DO I=1,P_FIELD_OUT UDG1F304.41
INDEX_TARG_SEA_X(I)=INDEX_TARG_SEA(I) UDG1F304.42
INDEX_TARG_LAND_X(I)=INDEX_TARG_LAND(I) UDG1F304.43
LAND_SEA_MASK_X(I)=0 UDG1F304.44
IF(LAND_SEA_MASK_OUT(I)) LAND_SEA_MASK_X(I)=1 UDG1F304.45
ENDDO UDG1F304.46
SEA_POINTS_UNRESX=SEA_POINTS_UNRES UDG1F304.47
LAND_POINTS_UNRESX=LAND_POINTS_UNRES UDG1F304.48
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_SEA_X UDG1F304.49
*,SEA_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT,TSTAR UDG1F304.50
*,0,CYCLIC,MAXDIM) UDG1F304.51
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_LAND_X UDG1F304.52
*,LAND_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT,TSTAR UDG1F304.53
*,1,CYCLIC,MAXDIM) UDG1F304.54
ELSE UDG1F304.55
DO I=1,LAND_POINTS_UNRES CONTROL1.1056
TSTAR(INDEX_TARG_LAND(I)) CONTROL1.1057
* =TSTAR(LAND_UNRES_INDEX(I)) CONTROL1.1058
ENDDO CONTROL1.1059
DO I=1,SEA_POINTS_UNRES CONTROL1.1060
TSTAR(INDEX_TARG_SEA(I)) CONTROL1.1061
* =TSTAR(SEA_UNRES_INDEX(I)) CONTROL1.1062
ENDDO CONTROL1.1063
CONTROL1.1064
UDG1F304.56
ENDIF UDG1F304.57
UDG2F400.26
ENDIF UDG2F400.27
*IF DEF,TIMER CONTROL1.1065
CALL TIMER('REPLANCA',3) CONTROL1.1066
*ENDIF CONTROL1.1067
CONTROL1.1068
CALL REPLANCA(FIXHD_OUT(28),FIXHD_OUT(29),FIXHD_OUT(30), GDG0F401.279
& FIXHD_OUT(31),FIXHD_OUT(32),FIXHD_OUT(33), GDG0F401.280
& FIXHD_OUT(34),0,0,P_FIELD_OUT, GDG0F401.281
& P_ROWS_OUT,U_FIELD_OUT,D1_OUT,LAND_SEA_MASK_OUT, GDG0F401.282
& ICE_FRAC,TSTAR,TSTAR_ANOM, GRS2F404.231
& REALHD_OUT(2),REALHD_OUT(3), GRS2F404.232
& LEN1_LOOKUP_OUT,256, GRS2F404.233
& PP_LEN_INTHD,PP_LEN_REALHD,LEN_ANCIL,FIXHD_ANCIL, GDG0F401.284
& INTHD_ANCIL,REALHD_ANCIL,LOOKUP_ANCIL,LOOKUP_ANCIL, GDG0F401.285
& FTN_ANCIL,LOOKUP_START,NDATASETS,NLOOKUPS, GDG0F401.286
*CALL ARGPPX GDG0F401.287
& LPOLARCHK, UDG4F402.95
& IOUNIT,ICODE,CMESSAGE,LCAL360) GDG0F401.288
CONTROL1.1076
IF(ICODE.NE.0)CALL ABORT_IO('REPLANCA',CMESSAGE,ICODE,IOUNIT) CONTROL1.1077
CONTROL1.1078
*IF DEF,TIMER CONTROL1.1079
CALL TIMER('REPLANCA',4) CONTROL1.1080
*ENDIF CONTROL1.1081
CONTROL1.1082
C--------------------------------------------------------------- CONTROL1.1083
C Initialise requested output fields with ancillary data CONTROL1.1084
C--------------------------------------------------------------- CONTROL1.1085
CONTROL1.1091
C Ignore LAND/SEA mask and surface temperature fields CONTROL1.1092
C and sea ice fraction field CONTROL1.1093
DO K=2,NANCIL_FIELDS GDR1F401.31
IF(SWITCH(K).EQ.1)THEN CONTROL1.1095
IF(K.NE.27.AND.K.NE.28)THEN CONTROL1.1096
IF (ANCIL_ADD(K).NE.0)THEN UDG2F305.120
CALL LOCATE(ITEM_CODES_ANCIL(K),PP_ITEMC_OUT CONTROL1.1097
* ,N_TYPES_OUT,POS) CONTROL1.1098
WRITE(6,'('' '',5I9,E12.5)')K,POS,PP_NUM_OUT(POS) CONTROL1.1099
* ,PP_POS_OUT(POS) CONTROL1.1100
* ,ANCIL_ADD(K) CONTROL1.1101
* ,D1_OUT(ANCIL_ADD(K)) CONTROL1.1102
END IF UDG2F305.122
CONTROL1.1103
IF(PP_LS_OUT(POS).EQ.1)THEN CONTROL1.1104
CONTROL1.1105
DO J=1,PP_NUM_OUT(POS) CONTROL1.1106
CALL TO_LAND_POINTS( UDG3F402.208
& D1_OUT(ANCIL_ADD(K)+(J-1)*P_FIELD_OUT), UDG3F402.209
& D1_OUT(ANCIL_ADD(K)+(J-1)*PP_LEN_OUT(POS)), UDG3F402.210
& LAND_SEA_MASK_OUT,P_FIELD_OUT,LAND_POINTS) UDG3F402.211
ENDDO CONTROL1.1110
CONTROL1.1111
*IF DEF,TIMER CONTROL1.1112
CALL TIMER('WRITFLDS',3) CONTROL1.1113
*ENDIF CONTROL1.1114
CONTROL1.1115
CALL WRITFLDS(NFTOUT,PP_NUM_OUT(POS),PP_POS_OUT(POS), GDG0F401.289
& LOOKUP_OUT,LEN1_LOOKUP_OUT,D1_OUT(ANCIL_ADD(K)), UDG3F402.212
& P_FIELD_OUT,FIXHD_OUT, GDG0F401.291
*CALL ARGPPX GDG0F401.292
& ICODE,CMESSAGE) GDG0F401.293
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE CONTROL1.1119
* ,NFTOUT) CONTROL1.1120
CONTROL1.1121
*IF DEF,TIMER CONTROL1.1122
CALL TIMER('WRITFLDS',4) CONTROL1.1123
*ENDIF CONTROL1.1124
CONTROL1.1125
ELSE CONTROL1.1126
CONTROL1.1127
*IF DEF,TIMER CONTROL1.1128
CALL TIMER('WRITFLDS',3) CONTROL1.1129
*ENDIF CONTROL1.1130
CONTROL1.1131
CALL WRITFLDS(NFTOUT,PP_NUM_OUT(POS),PP_POS_OUT(POS), GDG0F401.294
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.295
& D1_OUT(ANCIL_ADD(K)),P_FIELD_OUT,FIXHD_OUT, GDG0F401.296
*CALL ARGPPX GDG0F401.297
& ICODE,CMESSAGE) GDG0F401.298
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE CONTROL1.1135
* ,NFTOUT) CONTROL1.1136
CONTROL1.1137
*IF DEF,TIMER CONTROL1.1138
CALL TIMER('WRITFLDS',4) CONTROL1.1139
*ENDIF CONTROL1.1140
CONTROL1.1141
ENDIF CONTROL1.1142
CONTROL1.1143
ENDIF CONTROL1.1144
ENDIF CONTROL1.1145
ENDDO CONTROL1.1146
CONTROL1.1147
C--------------------------------------------------------------- CONTROL1.1148
C Write out tstar (updated with ancillary data in REPALACA) CONTROL1.1149
C--------------------------------------------------------------- CONTROL1.1150
CONTROL1.1151
CALL LOCATE(24,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1152
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.299
& TSTAR,P_FIELD_OUT,FIXHD_OUT, GDG0F401.300
*CALL ARGPPX GDG0F401.301
& ICODE,CMESSAGE) GDG0F401.302
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1155
CONTROL1.1156
C--------------------------------------------------------------------- CONTROL1.1157
C Write out sea ice fraction (updated with ancillary data in REPALACA) CONTROL1.1158
C--------------------------------------------------------------------- CONTROL1.1159
CONTROL1.1160
LOG_ICE_FRAC=SWITCH(27).EQ.1 CONTROL1.1161
CONTROL1.1162
IF(LOG_ICE_FRAC)THEN CONTROL1.1163
CALL LOCATE(31,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1164
CONTROL1.1165
*IF DEF,TIMER CONTROL1.1166
CALL TIMER('WRITFLDS',3) CONTROL1.1167
*ENDIF CONTROL1.1168
CONTROL1.1169
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.303
& ICE_FRAC,P_FIELD_OUT,FIXHD_OUT, GDG0F401.304
*CALL ARGPPX GDG0F401.305
& ICODE,CMESSAGE) GDG0F401.306
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1172
CONTROL1.1173
*IF DEF,TIMER CONTROL1.1174
CALL TIMER('WRITFLDS',4) CONTROL1.1175
*ENDIF CONTROL1.1176
CONTROL1.1177
ENDIF CONTROL1.1178
CONTROL1.1179
C--------------------------------------------------------------------- CONTROL1.1180
C Write out tstar anomaly (created from ancillary data in REPLANCA) CONTROL1.1181
C--------------------------------------------------------------------- CONTROL1.1182
CONTROL1.1183
IF(SSTANOM)THEN CONTROL1.1184
CALL LOCATE(39,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1185
CONTROL1.1186
*IF DEF,TIMER CONTROL1.1187
CALL TIMER('WRITFLDS',3) CONTROL1.1188
*ENDIF CONTROL1.1189
CONTROL1.1190
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.307
& TSTAR_ANOM,P_FIELD_OUT,FIXHD_OUT, GDG0F401.308
*CALL ARGPPX GDG0F401.309
& ICODE,CMESSAGE) GDG0F401.310
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1193
CONTROL1.1194
*IF DEF,TIMER CONTROL1.1195
CALL TIMER('WRITFLDS',4) CONTROL1.1196
*ENDIF CONTROL1.1197
CONTROL1.1198
ENDIF CONTROL1.1199
CONTROL1.1200
ENDIF ! No ancillary fields if ocean CONTROL1.1201
CONTROL1.1202
C--------------------------------------------------------------- CONTROL1.1203
C Save input PSTAR for use in vertical interpolation. CONTROL1.1204
C--------------------------------------------------------------- CONTROL1.1205
CONTROL1.1206
IF(.NOT.OCEAN)THEN CONTROL1.1207
CONTROL1.1208
CALL LOCATE(1,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.1209
IF(POS.EQ.0)THEN CONTROL1.1210
WRITE(6,'('' *ERROR* Pstar not in input file'')') CONTROL1.1211
CALL ABORT CONTROL1.1212
ENDIF CONTROL1.1213
CONTROL1.1214
*IF DEF,TIMER CONTROL1.1215
CALL TIMER('READFLDS',3) CONTROL1.1216
*ENDIF CONTROL1.1217
CONTROL1.1218
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.311
& D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.312
*CALL ARGPPX GDG0F401.313
& ICODE,CMESSAGE) GDG0F401.314
IF(ICODE.EQ.1501)THEN UDG4F402.96
IF(LPOLARCHK)THEN UDG4F402.97
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.98
UDG4F402.99
! North polar row UDG4F402.100
RP_ROW_SUM=0 UDG4F402.101
DO I=1,ROW_LENGTH_IN UDG4F402.102
RP_ROW_SUM=RP_ROW_SUM+D1_IN(I) UDG4F402.103
END DO UDG4F402.104
DO I=1,ROW_LENGTH_IN UDG4F402.105
D1_IN(I)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.106
END DO UDG4F402.107
! South polar row UDG4F402.108
RP_ROW_SUM=0 UDG4F402.109
DO I=1,ROW_LENGTH_IN UDG4F402.110
RP_ROW_SUM= UDG4F402.111
& RP_ROW_SUM+D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.112
END DO UDG4F402.113
DO I=1,ROW_LENGTH_IN UDG4F402.114
D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.115
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.116
END DO UDG4F402.117
END IF UDG4F402.118
ELSE IF(ICODE.NE.0)THEN UDG4F402.119
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.120
END IF UDG4F402.121
CONTROL1.1222
*IF DEF,TIMER CONTROL1.1223
CALL TIMER('READFLDS',4) CONTROL1.1224
*ENDIF CONTROL1.1225
CONTROL1.1226
IF(HORIZ) THEN MC230493.29
MC230493.30
*IF DEF,TIMER CONTROL1.1227
CALL TIMER('HINTCTL',3) UDG1F400.172
*ENDIF CONTROL1.1229
CONTROL1.1230
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.173
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.174
&, GLOBAL,H_INT_TYPE UDG1F400.175
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.176
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.177
&, AW_COLAT_T(1,1),AW_LONG_L(1,1),D1_IN UDG1F400.178
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.179
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.180
&, PSTAR_OUT) UDG1F400.181
CONTROL1.1235
IF(GLOBAL)THEN UDG4F402.572
! Horizontal Interpolation has made polar rows non-constant UDG4F402.573
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.574
& 'non-constant' UDG4F402.575
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.576
UDG4F402.577
! North polar row UDG4F402.578
RP_ROW_SUM=0 UDG4F402.579
DO I=1,ROW_LENGTH_OUT UDG4F402.580
RP_ROW_SUM=RP_ROW_SUM+PSTAR_OUT(I) UDG4F402.581
END DO UDG4F402.582
DO I=1,ROW_LENGTH_OUT UDG4F402.583
PSTAR_OUT(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.584
END DO UDG4F402.585
! South polar row UDG4F402.586
RP_ROW_SUM=0 UDG4F402.587
DO I=1,ROW_LENGTH_OUT UDG4F402.588
RP_ROW_SUM= UDG4F402.589
& RP_ROW_SUM+PSTAR_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG4F402.590
END DO UDG4F402.591
DO I=1,ROW_LENGTH_OUT UDG4F402.592
PSTAR_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG4F402.593
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.594
END DO UDG4F402.595
END IF UDG4F402.596
*IF DEF,TIMER CONTROL1.1236
CALL TIMER('HINTCTL',4) UDG1F400.182
*ENDIF CONTROL1.1238
MC230493.31
ELSE MC230493.32
DO I=1,P_FIELD_OUT MC230493.33
PSTAR_OUT(I)=D1_IN(I) MC230493.34
END DO MC230493.35
END IF MC230493.36
MC230493.37
CONTROL1.1239
ENDIF ! No pstar if ocean CONTROL1.1240
CONTROL1.1241
AD150293.56
C--------------------------------------------------------------- AD150293.57
C Increment model input fields with ECMWF perturbations AD150293.58
C--------------------------------------------------------------- AD150293.59
AD150293.60
IF(PERTURBATION.NE.0.0)THEN AD150293.61
AD150293.62
VERT=.TRUE. AD150293.63
AD150293.64
WRITE(6,*)'ADDING ECMWF PERTURBATION INCS' AD150293.65
CALL PERTURB( UDG7F400.161
*CALL ARGPPX UDG7F400.162
& NFTPER,NFTIN,LEN_FIXHD_IN,PER_ARGS(1),PER_ARGS(2), UDG7F400.163
& PER_ARGS(3),PER_ARGS(4),LEN1_LOOKUP_IN,PER_ARGS(5), UDG7F400.164
& PER_ARGS(6),FIXHD_IN,INTHD_IN,LEVDEPC_IN, UDG7F400.165
& P_LEVELS_IN,LEN1_LEVDEPC_IN,N_TYPES_IN,P_FIELD_IN, UDG7F400.166
& LOOKUP_IN,PP_POS_IN,PP_ITEMC_IN,PERTURBATION, UDG3F405.342
& P_ROWS_IN,ROW_LENGTH_IN,LPOLARCHK) UDG3F405.343
UDG3F405.344
AD150293.72
AD150293.73
ENDIF AD150293.74
C--------------------------------------------------------------- CONTROL1.1242
C If orography to be read from ancillary field then adjust PSTAR CONTROL1.1243
C--------------------------------------------------------------- CONTROL1.1244
CONTROL1.1245
IF(.NOT.(RM_CP))THEN UDG6F405.46
IF(.NOT.OCEAN)THEN CONTROL1.1246
CONTROL1.1247
WRITE(6,'('' BEFORE TOPOG ADJ'')') UDG6F304.20
CALL LOCATE(1,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1249
CALL PR_RFLD(LOOKUP_OUT,LOOKUP_OUT,PSTAR_OUT,POS) CONTROL1.1250
CONTROL1.1251
NBLP1=BL_LEVELS_IN+1 CONTROL1.1252
CALL LOCATE(33,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1253
CONTROL1.1254
IF(PP_SOURCE_OUT(POS).EQ.2)THEN UDG2F305.123
CONTROL1.1256
C Read in ancillary field orography CONTROL1.1260
CONTROL1.1261
*IF DEF,TIMER CONTROL1.1262
CALL TIMER('READFLDS',3) CONTROL1.1263
*ENDIF CONTROL1.1264
CONTROL1.1265
CALL READFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.315
& TOPOG_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.316
*CALL ARGPPX GDG0F401.317
& ICODE,CMESSAGE) GDG0F401.318
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1268
CONTROL1.1269
*IF DEF,TIMER CONTROL1.1270
CALL TIMER('READFLDS',4) CONTROL1.1271
*ENDIF CONTROL1.1272
CONTROL1.1273
C Read in orography from input file CONTROL1.1274
CALL LOCATE(33,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.1275
CONTROL1.1276
*IF DEF,TIMER CONTROL1.1277
CALL TIMER('READFLDS',3) CONTROL1.1278
*ENDIF CONTROL1.1279
CONTROL1.1280
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.319
& D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.320
*CALL ARGPPX GDG0F401.321
& ICODE,CMESSAGE) GDG0F401.322
IF(ICODE.EQ.1501)THEN UDG4F402.122
IF(LPOLARCHK)THEN UDG4F402.123
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.124
UDG4F402.125
! North polar row UDG4F402.126
RP_ROW_SUM=0 UDG4F402.127
DO I=1,ROW_LENGTH_IN UDG4F402.128
RP_ROW_SUM=RP_ROW_SUM+D1_IN(I) UDG4F402.129
END DO UDG4F402.130
DO I=1,ROW_LENGTH_IN UDG4F402.131
D1_IN(I)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.132
END DO UDG4F402.133
! South polar row UDG4F402.134
RP_ROW_SUM=0 UDG4F402.135
DO I=1,ROW_LENGTH_IN UDG4F402.136
RP_ROW_SUM= UDG4F402.137
& RP_ROW_SUM+D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.138
END DO UDG4F402.139
DO I=1,ROW_LENGTH_OUT UDG4F402.140
D1_IN((P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.141
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.142
END DO UDG4F402.143
END IF UDG4F402.144
ELSE IF(ICODE.NE.0)THEN UDG4F402.145
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.146
END IF UDG4F402.147
CONTROL1.1284
*IF DEF,TIMER CONTROL1.1285
CALL TIMER('READFLDS',4) CONTROL1.1286
*ENDIF CONTROL1.1287
UDG6F304.21
C Switch on vertical interpolation if new orography field is specified UDG6F304.22
C and is different from that in dump. UDG6F304.23
DO I=1,P_FIELD_OUT UDG6F304.24
IF(.NOT.VERT)THEN UDG6F304.25
IF(D1_IN(I).NE.TOPOG_OUT(I))THEN UDG6F304.26
VERT=.TRUE. UDG6F304.27
WRITE UDG6F304.28
& (6,*) ' VERTICAL INTERPOLATION SWITCHED ON BECAUSE'// UDG6F304.29
& ' THE OROGRAPHY IS BEING CHANGED' UDG6F304.30
ENDIF UDG6F304.31
ENDIF UDG6F304.32
ENDDO UDG6F304.33
CONTROL1.1288
IF(VERT)THEN UDG6F304.34
UDG6F304.35
IF(HORIZ)THEN UDG5F405.3
UDG5F405.4
C Interpolate old orography to new grid CONTROL1.1289
CONTROL1.1290
*IF DEF,TIMER CONTROL1.1291
CALL TIMER('HINTCTL',3) UDG1F400.183
*ENDIF CONTROL1.1293
CONTROL1.1294
CALL PR_RFLD(LOOKUP_IN,LOOKUP_IN,D1_IN,1) CONTROL1.1295
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.184
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.185
&, GLOBAL,H_INT_TYPE UDG1F400.186
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.187
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.188
&, AW_COLAT_T(1,1),AW_LONG_L(1,1),D1_IN UDG1F400.189
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.190
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.191
&, TOPOG_OLD) UDG1F400.192
CONTROL1.1300
*IF DEF,TIMER CONTROL1.1301
CALL TIMER('HINTCTL',4) UDG1F400.193
*ENDIF CONTROL1.1303
CONTROL1.1304
IF(GLOBAL)THEN UDG4F402.597
! Horizontal Interpolation has made polar rows non-constant UDG4F402.598
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.599
& 'non-constant' UDG4F402.600
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.601
UDG4F402.602
! North polar row UDG4F402.603
RP_ROW_SUM=0 UDG4F402.604
DO I=1,ROW_LENGTH_OUT UDG4F402.605
RP_ROW_SUM=RP_ROW_SUM+TOPOG_OLD(I) UDG4F402.606
END DO UDG4F402.607
DO I=1,ROW_LENGTH_OUT UDG4F402.608
TOPOG_OLD(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.609
END DO UDG4F402.610
! South polar row UDG4F402.611
RP_ROW_SUM=0 UDG4F402.612
DO I=1,ROW_LENGTH_OUT UDG4F402.613
RP_ROW_SUM= UDG4F402.614
& RP_ROW_SUM+TOPOG_OLD((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG4F402.615
END DO UDG4F402.616
DO I=1,ROW_LENGTH_OUT UDG4F402.617
TOPOG_OLD((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG4F402.618
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.619
END DO UDG4F402.620
END IF UDG4F402.621
ELSE !IF HORIZ UDG5F405.5
UDG5F405.6
DO I=1,P_FIELD_OUT UDG5F405.7
TOPOG_OLD(I)=D1_IN(I) UDG5F405.8
END DO UDG5F405.9
UDG5F405.10
END IF !IF HORIZ UDG5F405.11
UDG5F405.12
C Set ancillary orography back to interpolated orography outside CONTROL1.1305
C area specified on NAMELIST HORIZ CONTROL1.1306
DO I=1,P_FIELD_OUT CONTROL1.1307
IF(.NOT.TOPOG_MASK(I))TOPOG_OUT(I)=TOPOG_OLD(I) CONTROL1.1308
ENDDO CONTROL1.1309
UDG6F304.36
ENDIF UDG6F304.37
CONTROL1.1310
C Write updated orography to output file CONTROL1.1311
CALL LOCATE(33,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1312
*IF DEF,TIMER CONTROL1.1313
CALL TIMER('WRITFLDS',3) CONTROL1.1314
*ENDIF CONTROL1.1315
CONTROL1.1316
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, GDG0F401.323
& TOPOG_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.324
*CALL ARGPPX GDG0F401.325
& ICODE,CMESSAGE) GDG0F401.326
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1319
CONTROL1.1320
*IF DEF,TIMER CONTROL1.1321
CALL TIMER('WRITFLDS',4) CONTROL1.1322
*ENDIF CONTROL1.1323
CONTROL1.1324
C Read in THL up to first level outside boundary layer CONTROL1.1325
CALL LOCATE(5,PP_ITEMC_IN,N_TYPES_IN,POS) CONTROL1.1326
CONTROL1.1327
*IF DEF,TIMER CONTROL1.1328
CALL TIMER('READFLDS',3) CONTROL1.1329
*ENDIF CONTROL1.1330
CONTROL1.1331
CALL READFLDS(NFTIN,NBLP1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, GDG0F401.327
& D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.328
*CALL ARGPPX GDG0F401.329
& ICODE,CMESSAGE) GDG0F401.330
IF(ICODE.EQ.1501)THEN UDG4F402.148
IF(LPOLARCHK)THEN UDG4F402.149
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.150
UDG4F402.151
DO KK=1,NBLP1 UDG4F402.152
! North polar row UDG4F402.153
RP_ROW_SUM=0 UDG4F402.154
DO I=1,ROW_LENGTH_IN UDG4F402.155
RP_ROW_SUM=RP_ROW_SUM+D1_IN(I+(KK-1)*P_FIELD_IN) UDG4F402.156
END DO UDG4F402.157
DO I=1,ROW_LENGTH_IN UDG4F402.158
D1_IN(I+(KK-1)*P_FIELD_IN)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.159
END DO UDG4F402.160
! South polar row UDG4F402.161
RP_ROW_SUM=0 UDG4F402.162
DO I=1,ROW_LENGTH_IN UDG4F402.163
RP_ROW_SUM=RP_ROW_SUM+D1_IN((KK-1)*P_FIELD_IN+ UDG4F402.164
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.165
END DO UDG4F402.166
DO I=1,ROW_LENGTH_IN UDG4F402.167
D1_IN((KK-1)*P_FIELD_IN+ UDG4F402.168
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.169
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.170
END DO UDG4F402.171
END DO UDG4F402.172
END IF UDG4F402.173
ELSE IF(ICODE.NE.0)THEN UDG4F402.174
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.175
END IF UDG4F402.176
CONTROL1.1335
*IF DEF,TIMER CONTROL1.1336
CALL TIMER('READFLDS',4) CONTROL1.1337
*ENDIF CONTROL1.1338
CONTROL1.1339
IF(VERT)THEN UDG6F304.38
UDG6F304.39
IF(HORIZ)THEN UDG5F405.13
UDG5F405.14
*IF DEF,TIMER CONTROL1.1340
CALL TIMER('HINTCTL',3) UDG1F400.194
*ENDIF CONTROL1.1342
CONTROL1.1343
C Interpolate reference potential temperature to new grid CONTROL1.1344
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.195
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.196
&, GLOBAL,H_INT_TYPE UDG1F400.197
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.198
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.199
&, AW_COLAT_T(1,1),AW_LONG_L(1,1) UDG1F400.200
&, D1_IN((1+(NBLP1-1)*P_FIELD_IN)) UDG1F400.201
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.202
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.203
&, THR_OUT) UDG1F400.204
CONTROL1.1349
*IF DEF,TIMER CONTROL1.1350
CALL TIMER('HINTCTL',4) UDG1F400.205
*ENDIF CONTROL1.1352
CONTROL1.1353
IF(GLOBAL)THEN UDG4F402.622
! Horizontal Interpolation has made polar rows non-constant UDG4F402.623
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.624
& 'non-constant' UDG4F402.625
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.626
UDG4F402.627
! North polar row UDG4F402.628
RP_ROW_SUM=0 UDG4F402.629
DO I=1,ROW_LENGTH_OUT UDG4F402.630
RP_ROW_SUM=RP_ROW_SUM+THR_OUT(I) UDG4F402.631
END DO UDG4F402.632
DO I=1,ROW_LENGTH_OUT UDG4F402.633
THR_OUT(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.634
END DO UDG4F402.635
! South polar row UDG4F402.636
RP_ROW_SUM=0 UDG4F402.637
DO I=1,ROW_LENGTH_OUT UDG4F402.638
RP_ROW_SUM= UDG4F402.639
& RP_ROW_SUM+THR_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG4F402.640
END DO UDG4F402.641
DO I=1,ROW_LENGTH_OUT UDG4F402.642
THR_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG4F402.643
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.644
END DO UDG4F402.645
END IF UDG4F402.646
ELSE !IF HORIZ UDG5F405.15
UDG5F405.16
DO I=1,P_FIELD_OUT UDG5F405.17
THR_OUT(I)=D1_IN((NBLP1-1)*P_FIELD_IN+I) UDG5F405.18
END DO UDG5F405.19
UDG5F405.20
END IF !IF HORIZ UDG5F405.21
UDG5F405.22
UDG5F405.23
UDG5F405.24
C Calculate new PSTAR CONTROL1.1354
DO I=1,P_FIELD_OUT CONTROL1.1355
C Reference pressure CONTROL1.1356
PR_OUT=LEVDEPC_IN(NBLP1) CONTROL1.1357
* +PSTAR_OUT(I)*LEVDEPC_IN(NBLP1+P_LEVELS_IN) CONTROL1.1358
C Reference temperature CONTROL1.1359
TR_OUT=THR_OUT(I)*(PR_OUT/PREF)**KAPPA CONTROL1.1363
C 'Surface' temperature by extrapolating reference values to surface CONTROL1.1365
TS_OUT=TR_OUT*(PSTAR_OUT(I)/PR_OUT)**LAPSE_R_OVER_G GSS9F402.68
C New pstar CONTROL1.1371
IF(I.EQ.P_FIELD_OUT)THEN CONTROL1.1372
WRITE(6,'('' pr_out,tr_out,ts_out,pstar_in,topog_old,'', CONTROL1.1373
* ''topog_out'',6E12.5)')PR_OUT,TR_OUT,TS_OUT,PSTAR_OUT(I) CONTROL1.1374
* ,TOPOG_OLD(I),TOPOG_OUT(I) CONTROL1.1375
ENDIF CONTROL1.1376
PSTAR_OUT(I)=PSTAR_OUT(I)*((TS_OUT-LAPSE*(TOPOG_OUT(I) CONTROL1.1377
* -TOPOG_OLD(I)))/TS_OUT)**G_OVER_LAPSE_R CONTROL1.1378
ENDDO CONTROL1.1379
UDG6F304.40
ENDIF UDG6F304.41
CONTROL1.1380
WRITE(6,'('' AFTER TOPOG ADJ'')') CONTROL1.1381
CALL LOCATE(1,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1382
CALL PR_RFLD(LOOKUP_OUT,LOOKUP_OUT,PSTAR_OUT,POS) CONTROL1.1383
CONTROL1.1384
ENDIF CONTROL1.1385
C--------------------------------------------------------------- CONTROL1.1386
C Write new PSTAR to disk CONTROL1.1387
C--------------------------------------------------------------- CONTROL1.1388
CONTROL1.1389
CALL LOCATE(1,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1390
CONTROL1.1391
*IF DEF,TIMER CONTROL1.1392
CALL TIMER('WRITFLDS',3) CONTROL1.1393
*ENDIF CONTROL1.1394
CONTROL1.1395
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, DR081293.52
& PSTAR_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.331
*CALL ARGPPX GDG0F401.332
& ICODE,CMESSAGE) GDG0F401.333
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1398
CONTROL1.1399
*IF DEF,TIMER CONTROL1.1400
CALL TIMER('WRITFLDS',4) CONTROL1.1401
*ENDIF CONTROL1.1402
CONTROL1.1403
ENDIF ! No orography if ocean CONTROL1.1404
ELSE ! RM_CP UDG6F405.47
UDG6F405.48
CALL LOCATE(1,PP_ITEMC_IN,N_TYPES_IN,POS) UDG6F405.49
IF(POS.EQ.0)THEN UDG6F405.50
WRITE(6,'('' *ERROR* Pstar not in input file'')') UDG6F405.51
CALL ABORT UDG6F405.52
ENDIF UDG6F405.53
UDG6F405.54
CALL TIMER('READFLDS',3) UDG6F405.55
UDG6F405.56
CALL READFLDS(NFTIN,1,PP_POS_IN(POS),LOOKUP_IN,LEN1_LOOKUP_IN, UDG6F405.57
& PSTAR_OUT,P_FIELD_IN,FIXHD_IN, UDG6F405.58
*CALL ARGPPX UDG6F405.59
& ICODE,CMESSAGE) UDG6F405.60
UDG6F405.61
CALL TIMER('READFLDS',4) UDG6F405.62
UDG6F405.63
CALL LOCATE(1,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDG6F405.64
UDG6F405.65
CALL TIMER('WRITFLDS',3) UDG6F405.66
UDG6F405.67
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, UDG6F405.68
& PSTAR_OUT,P_FIELD_OUT,FIXHD_OUT, UDG6F405.69
*CALL ARGPPX UDG6F405.70
& ICODE,CMESSAGE) UDG6F405.71
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) UDG6F405.72
UDG6F405.73
CALL TIMER('WRITFLDS',4) UDG6F405.74
ENDIF ! RM_CP UDG6F405.75
ENDIF ! Not PFinc2UM UIE2F401.210
CONTROL1.1405
C--------------------------------------------------------------- CONTROL1.1406
C Loop over number of different STASH codes in output data block CONTROL1.1407
C--------------------------------------------------------------- CONTROL1.1408
CONTROL1.1409
DO 1400 J=1,N_TYPES_OUT CONTROL1.1410
CONTROL1.1411
ITEM_CODE=MOD(LOOKUP_OUT(42,PP_POS_OUT(J)),1000) UIE2F401.199
SECTION=(LOOKUP_OUT(42,PP_POS_OUT(J))-ITEM_CODE)/1000 UIE2F401.200
MODEL=LOOKUP_OUT(45,PP_POS_OUT(J)) UIE2F401.201
PPXREF_GRID_TYPE=EXPPXI(MODEL,SECTION,ITEM_CODE,ppx_grid_type, UIE2F401.202
*CALL ARGPPX UIE2F401.203
& ICODE,CMESSAGE) UIE2F401.204
C Land/sea mask, PSTAR, TSTAR already processed or ancillary CONTROL1.1412
C field selected CONTROL1.1413
C so skip to end of loop CONTROL1.1414
IF(RadialGridIn.AND..NOT.RadialGridOut)THEN UIE2F401.215
LOG_ICE_FRAC=.TRUE. UIE2F401.216
END IF UIE2F401.217
IF(PP_ITEMC_OUT(J).EQ.30.OR.PP_ITEMC_OUT(J).EQ.1.OR. CONTROL1.1415
*PP_ITEMC_OUT(J).EQ.24.OR.PP_SOURCE_OUT(J).EQ.2 CONTROL1.1416
& .OR. PP_SOURCE_OUT(J).EQ.8 ! Field to be initialised UDR1F400.4
*.OR.(LOG_ICE_FRAC.AND.PP_ITEMC_OUT(J).EQ.31)) GOTO1400 CONTROL1.1417
CONTROL1.1418
IF(PP_ITEMC_OUT(J).EQ.93.AND.HORIZ) THEN TJ300493.4
WRITE(6,'(''CONTROL: ERROR - Outflow data cannot be interpolated. CONTROL1.1420
& Resubmit job using request for ancillary field'')') CONTROL1.1421
CALL ABORT CONTROL1.1422
ENDIF CONTROL1.1423
CONTROL1.1424
C--------------------------------------------------------------- CONTROL1.1425
C Find position of output field in input file CONTROL1.1426
C--------------------------------------------------------------- CONTROL1.1427
CONTROL1.1428
CALL FIND(PP_ITEMC_OUT(J),PP_ITEMC_IN,PP_LEN_OUT(J),PP_LEN_IN CONTROL1.1429
& ,N_TYPES_IN,OCEAN,POS) CONTROL1.1430
IF(POS.EQ.0)THEN AD200593.188
N_FIELDS_IN=0 AD200593.189
ELSE AD200593.190
N_FIELDS_IN=PP_NUM_IN(POS) AD200593.191
ENDIF AD200593.192
N_FIELDS_OUT=PP_NUM_OUT(J) CONTROL1.1432
CONTROL1.1433
C--------------------------------------------------------------- CONTROL1.1434
C Check for inconsistency in specification of data source CONTROL1.1435
C--------------------------------------------------------------- CONTROL1.1436
CONTROL1.1437
IF(POS.EQ.0.AND.PP_SOURCE_OUT(J).EQ.1)THEN CONTROL1.1438
UDR1F400.5
GDR7F404.8
! This field is not in the input dump GDR7F404.9
GDR7F404.10
IF( GDR7F404.11
! QCF GDR7F404.12
& (PP_ITEMC_OUT(J).eq.12 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.13
& L_MP_PRECIP) GDR7F404.14
! Sea Ice Temperature GDR7F404.15
& .or. (PP_ITEMC_OUT(J).eq.49 .and. MODEL.eq. ATMOS_IM) GDR7F404.16
! Convective Cloud Amount - 3D GDR7F404.17
& .or. (PP_ITEMC_OUT(J).eq.211 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.18
& L_3D_CCA) GDR7F404.19
! Canopy Conductance GDR7F404.20
& .or. (PP_ITEMC_OUT(J).eq.213 .and. MODEL.eq. ATMOS_IM) GDR7F404.21
! Unfrozen soil moisture fraction GDR7F404.22
& .or. (PP_ITEMC_OUT(J).eq.214 .and. MODEL.eq. ATMOS_IM) GDR7F404.23
! Frozen soil moisture fraction GDR7F404.24
& .or. (PP_ITEMC_OUT(J).eq.215 .and. MODEL.eq. ATMOS_IM) GDR7F404.25
! Snow Soot Content GDR7F404.26
& .or. (PP_ITEMC_OUT(J).eq.221 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.27
& L_SNOW_ALBEDO) GDR7F404.28
! Accumulated NPP on Plant Functional Types GDR7F404.29
& .or. (PP_ITEMC_OUT(J).eq.224 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.30
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.31
! Accumulated Leaf Turnover Rate PFTS GDR7F404.32
& .or. (PP_ITEMC_OUT(J).eq.225 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.33
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.34
! Accumulated Phenological Leaf Turnover PFTS GDR7F404.35
& .or. (PP_ITEMC_OUT(J).eq.226 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.36
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.37
! Accumulated Wood Respiration PFTS GDR7F404.38
& .or. (PP_ITEMC_OUT(J).eq.227 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.39
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.40
! Accumulated Soil Respiration GDR7F404.41
& .or. (PP_ITEMC_OUT(J).eq.228 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.42
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.43
! Canopy Water on Non-Ice Tiles GDR7F404.44
& .or. (PP_ITEMC_OUT(J).eq.229 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.45
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.46
! Canopy Capacity on Non-Ice Tiles GDR7F404.47
& .or. (PP_ITEMC_OUT(J).eq.230 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.48
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.49
! Snow Grain Size GDR7F404.50
& .or. (PP_ITEMC_OUT(J).eq.231 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.51
& L_SNOW_ALBEDO) GDR7F404.52
! Snow Temperature GDR7F404.53
& .or. (PP_ITEMC_OUT(J).eq.232 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.54
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.55
! Surface Temperature on Tiles GDR7F404.56
& .or. (PP_ITEMC_OUT(J).eq.233 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.57
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.58
! Roughness Length on Tiles GDR7F404.59
& .or. (PP_ITEMC_OUT(J).eq.234 .and. MODEL.eq. ATMOS_IM .and. GDR7F404.60
& (L_TRIFFID.or.L_VEG_FRACS) ) GDR7F404.61
& ) THEN GDR7F404.62
GDR7F404.63
! Above variables not in input dump GDR7F404.64
! To initialise this field in the output dump GDR7F404.65
! set PP_SOURCE_OUT(J)=8. It will be done after all the GDR7F404.66
! fields have been set up in the output dump. The UMUI GDR7F404.67
! does not set SOURCE=8 for these fields. GDR7F404.68
GDR7F404.69
! One exception is SLAB Temperature (Stash Code 210). GDR7F404.70
! This field has SOURCE=8 set by the UMUI if it is not GDR7F404.71
! in the input dump and requires initialising for the GDR7F404.72
! output dump. GDR7F404.73
GDR7F404.74
PP_SOURCE_OUT(J) = 8 UDR1F400.10
GO TO 1400 UDR1F400.11
ENDIF UDR1F400.12
UDR1F400.13
WRITE(6,'('' *ERROR* Stash code'',I5,'' not found on input '' CONTROL1.1439
*''file'')')PP_ITEMC_OUT(J) CONTROL1.1440
CALL ABORT CONTROL1.1441
CONTROL1.1442
C--------------------------------------------------------------- CONTROL1.1443
C Initialise new field to zero or MDI CONTROL1.1444
C--------------------------------------------------------------- CONTROL1.1445
C Set output field to zero CONTROL1.1446
ELSEIF(PP_SOURCE_OUT(J).EQ.3)THEN CONTROL1.1447
CONTROL1.1448
IF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1449
DO I=1,PP_LEN_OUT(J) CONTROL1.1450
D1_OUT(I)=0. CONTROL1.1451
ENDDO CONTROL1.1452
ELSE CONTROL1.1453
DO I=1,PP_LEN_OUT(J) CONTROL1.1454
ID1_OUT(I)=0 CONTROL1.1455
ENDDO CONTROL1.1456
ENDIF CONTROL1.1457
CONTROL1.1458
C Set output field to missing data indicator CONTROL1.1459
ELSEIF(PP_SOURCE_OUT(J).EQ.4)THEN CONTROL1.1460
CONTROL1.1461
IF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1462
DO I=1,PP_LEN_OUT(J) CONTROL1.1463
D1_OUT(I)=RMDI TJ050593.13
ENDDO CONTROL1.1465
ELSE CONTROL1.1466
DO I=1,PP_LEN_OUT(J) CONTROL1.1467
ID1_OUT(I)=IMDI TJ050593.14
ENDDO CONTROL1.1469
ENDIF CONTROL1.1470
CONTROL1.1471
CONTROL1.1472
C--------------------------------------------------------------- UDG4F304.65
C INITIALISE NEW FIELD TO A CONSTANT UDG4F304.66
C--------------------------------------------------------------- UDG4F304.67
UDG4F304.68
ELSEIF(PP_SOURCE_OUT(J).EQ.6)THEN UDG4F304.69
UDG4F304.70
UDG4F304.71
IF(PP_TYPE_OUT(J).EQ.1)THEN UDG4F304.72
DO I=1,PP_LEN_OUT(J) UDG4F304.73
D1_OUT(I)=R_NAMELIST(J) UDG4F304.74
ENDDO UDG4F304.75
ELSE UDG4F304.76
DO I=1,PP_LEN_OUT(J) UDG4F304.77
ID1_OUT(I)=NINT(R_NAMELIST(J)) UDG7F400.168
ENDDO UDG4F304.79
ENDIF UDG4F304.80
UDG4F304.81
C--------------------------------------------------------------- UDG4F304.82
C INITIALISE NEW FIELD FROM AN EXTERNAL FILE UDG4F304.83
C--------------------------------------------------------------- UDG4F304.84
UDG4F304.85
ELSEIF(PP_SOURCE_OUT(J).EQ.7)THEN UDG4F304.86
UDG4F304.87
NFT_UPROG=140+J UDG4F304.88
CALL FILE_OPEN(NFT_UPROG,C_NAMELIST(J),80,0,1,JERR) GPB1F305.17
UDG4F304.90
C Buffer in fixed length header record & initialise lengths UDG4F304.91
LEN_INTHD_UPROG=1 UDG4F304.92
LEN_REALHD_UPROG=1 UDG4F304.93
LEN1_LEVDEPC_UPROG=1 UDG4F304.94
LEN2_LEVDEPC_UPROG=1 UDG4F304.95
LEN2_LOOKUP_UPROG=1 UDG4F304.96
LEN_DATA_UPROG=1 UDG4F304.97
UDG4F304.98
CALL BUFFIN(NFT_UPROG,FIXHD_UPROG,256,LEN_IO,AA) UDG4F304.99
UDG4F304.100
C Check for I/O errors and set lengths UDG4F304.101
IF(AA.NE.-1.0.OR.LEN_IO.NE.256)THEN UDG4F304.102
CALL IOERROR( UDG4F304.103
* 'buffer in of fixed length header of USER PROGNOSTIC file', UDG4F304.104
* AA,LEN_IO,256) UDG4F304.105
CALL ABORT UDG4F304.106
ELSE UDG4F304.107
LEN_INTHD_UPROG=FIXHD_UPROG(101) UDG4F304.108
LEN_REALHD_UPROG=FIXHD_UPROG(106) UDG4F304.109
LEN1_LEVDEPC_UPROG=FIXHD_UPROG(111) UDG4F304.110
LEN2_LEVDEPC_UPROG=FIXHD_UPROG(112) UDG4F304.111
LEN2_LOOKUP_UPROG=FIXHD_UPROG(152) UDG4F304.112
LEN_DATA_UPROG=FIXHD_UPROG(161) UDG4F304.113
ENDIF UDG4F304.114
UDG4F304.115
C Prevents AUX_FILE failing if data at a single level UDG4F304.116
IF(LEN1_LEVDEPC_UPROG.LT.0)LEN1_LEVDEPC_UPROG=0 UDG4F304.117
IF(LEN2_LEVDEPC_UPROG.LT.0)LEN2_LEVDEPC_UPROG=0 UDG4F304.118
UDG4F304.119
C Read in external file and write to dump UDG4F304.120
CALL AUX_FILE(NFT_UPROG,NFTOUT,LEN_FIXHD_OUT, UDG7F400.169
& LEN_INTHD_UPROG,LEN_REALHD_UPROG, UDG7F400.170
& LEN1_LEVDEPC_UPROG,LEN2_LEVDEPC_UPROG, UDG7F400.171
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_UPROG, UDG7F400.172
& LEN_DATA_UPROG,FIXHD_OUT,INTHD_OUT, UDG7F400.173
& LEVDEPC_OUT,P_LEVELS_OUT,LEN1_LEVDEPC_OUT, UDG7F400.174
& N_TYPES_OUT,P_FIELD_OUT,LOOKUP_OUT, UDG7F400.175
& PP_POS_OUT,PP_ITEMC_OUT,J_NAMELIST(J), UDG7F400.176
& ROW_LENGTH_IN,P_ROWS_IN, UDG0F404.128
& ROW_LENGTH_OUT,P_ROWS_OUT,LPOLARCHK, UDG0F404.129
*CALL ARGPPX UDG7F400.177
& PP_ITEMC_OUT(J),.TRUE.) UDG7F400.178
UDG4F304.128
C Reset after call to AUX_FILE if changed UDG4F304.129
LEN1_LEVDEPC_UPROG=FIXHD_UPROG(111) UDG4F304.130
LEN2_LEVDEPC_UPROG=FIXHD_UPROG(112) UDG4F304.131
UDG4F304.132
C--------------------------------------------------------------- CONTROL1.1473
C Initialise tracers CONTROL1.1474
C--------------------------------------------------------------- CONTROL1.1475
C CONTROL1.1476
ELSEIF(PP_SOURCE_OUT(J).EQ.5)THEN CONTROL1.1477
CONTROL1.1478
CALL AUX_FILE(NFTTRACER,NFTOUT,LEN_FIXHD_OUT, UDG7F400.179
& LEN_INTHD_TRACER,LEN_REALHD_TRACER, UDG7F400.180
& LEN1_LEVDEPC_TRACER,LEN2_LEVDEPC_TRACER, UDG7F400.181
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_TRACER, UDG7F400.182
& LEN_DATA_TRACER,FIXHD_OUT,INTHD_OUT, UDG7F400.183
& LEVDEPC_OUT,P_LEVELS_OUT,LEN1_LEVDEPC_OUT, UDG7F400.184
& N_TYPES_OUT,P_FIELD_OUT,LOOKUP_OUT, UDG7F400.185
& PP_POS_OUT,PP_ITEMC_OUT,PP_ITEMC_OUT(J), UDG7F400.186
& ROW_LENGTH_IN,P_ROWS_IN, UDG0F404.130
& ROW_LENGTH_OUT,P_ROWS_OUT,LPOLARCHK, UDG0F404.131
*CALL ARGPPX UDG7F400.187
& DUMMY,.FALSE.) UDG7F400.188
CONTROL1.1486
ELSEIF (PP_SOURCE_OUT(J).GT.9 .OR. PP_SOURCE_OUT(J).LT.1) THEN UIE2F401.179
CONTROL1.1488
WRITE(6,'('' *ERROR* S specified wrongly on NAMELIST ITEMS'')') UDR1F400.15
WRITE(6,'('' S='',I7,''ITEM CODE='',I7)')PP_SOURCE_OUT(J) CONTROL1.1490
* ,PP_ITEMC_OUT(J) CONTROL1.1491
CONTROL1.1492
C--------------------------------------------------------------- CONTROL1.1493
C Read in next set of model data fields & interpolate CONTROL1.1494
C--------------------------------------------------------------- CONTROL1.1495
CONTROL1.1496
ELSE CONTROL1.1497
CONTROL1.1498
*IF DEF,TIMER CONTROL1.1499
CALL TIMER('READFLDS',3) CONTROL1.1500
*ENDIF CONTROL1.1501
CONTROL1.1502
IF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1503
IF (PP_SOURCE_OUT(J).EQ.9) THEN UIE2F404.139
UIE2F404.140
! Read fields stored on UM B grid u, v, thetaL and qT positions UIE2F404.141
! when writing data out to VAR LS grid u, v, theta and q UIE2F404.142
! positions. Alternatively read fields stored on VAR LS grid UIE2F404.143
! u, v ,theta and q positions when writing data out to UM B grid UIE2F404.144
! u, v, thetaL and qT positions. UIE2F404.145
CALL RDVARFLD(NFTIN,LEN_FIXHD_IN,FIXHD_IN, UIE2F404.146
& LEN1_LOOKUP_IN,LEN2_LOOKUP_IN,LOOKUP_IN, UIE2F404.147
& PP_ITEMC_IN,PP_LEN_IN,N_TYPES_IN,PP_NUM_IN, UIE2F404.148
& PP_POS_IN,P_FIELD_IN,P_LEVELS_IN,N_FIELDS_IN, UIE2F404.149
& PP_ITEMC_OUT(J),PP_LEN_OUT(J), UIE2F404.150
& POS,D1_IN,OCEAN,RadialGridIn,RadialGridOut, UIE2F404.151
*CALL ARGPPX UIE2F404.152
& ICODE,CMESSAGE) UIE2F404.153
UDG4F402.178
ELSE UIE2F401.177
CALL READFLDS(NFTIN,N_FIELDS_IN,PP_POS_IN(POS),LOOKUP_IN, GDG0F401.334
& LEN1_LOOKUP_IN,D1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.335
*CALL ARGPPX GDG0F401.336
& ICODE,CMESSAGE) GDG0F401.337
IF(ICODE.EQ.1501)THEN UDG4F402.179
IF(LPOLARCHK)THEN UDG4F402.180
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.181
UDG4F402.182
DO KK=1,N_FIELDS_IN UDG4F402.183
! North polar row UDG4F402.184
RP_ROW_SUM=0 UDG4F402.185
DO I=1,ROW_LENGTH_IN UDG4F402.186
RP_ROW_SUM=RP_ROW_SUM+D1_IN((KK-1)*P_FIELD_IN+I) UDG4F402.187
END DO UDG4F402.188
DO I=1,ROW_LENGTH_IN UDG4F402.189
D1_IN((KK-1)*P_FIELD_IN+I)=RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.190
END DO UDG4F402.191
! South polar row UDG4F402.192
RP_ROW_SUM=0 UDG4F402.193
DO I=1,ROW_LENGTH_IN UDG4F402.194
RP_ROW_SUM=RP_ROW_SUM+D1_IN((KK-1)*P_FIELD_IN+ UDG4F402.195
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.196
END DO UDG4F402.197
DO I=1,ROW_LENGTH_IN UDG4F402.198
D1_IN((KK-1)*P_FIELD_IN+ UDG4F402.199
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.200
& RP_ROW_SUM/ROW_LENGTH_IN UDG4F402.201
END DO UDG4F402.202
END DO UDG4F402.203
END IF UDG4F402.204
ELSE IF(ICODE.NE.0)THEN UDG4F402.205
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.206
END IF UDG4F402.207
ENDIF UIE2F401.178
ELSEIF(PP_TYPE_OUT(J).EQ.2.OR.PP_TYPE_OUT(J).EQ.3)THEN CONTROL1.1506
CALL READFLDS(NFTIN,N_FIELDS_IN,PP_POS_IN(POS),LOOKUP_IN, GDG0F401.338
& LEN1_LOOKUP_IN,ID1_IN,P_FIELD_IN,FIXHD_IN, GDG0F401.339
*CALL ARGPPX GDG0F401.340
& ICODE,CMESSAGE) GDG0F401.341
IF(ICODE.EQ.1501)THEN UDG4F402.208
IF(LPOLARCHK)THEN UDG4F402.209
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.210
UDG4F402.211
DO KK=1,N_FIELDS_IN UDG4F402.212
! North polar row UDG4F402.213
IP_ROW_SUM=0 UDG4F402.214
DO I=1,ROW_LENGTH_IN UDG4F402.215
IP_ROW_SUM=IP_ROW_SUM+ID1_IN((KK-1)*P_FIELD_IN+I) UDG6F404.4
END DO UDG4F402.217
DO I=1,ROW_LENGTH_IN UDG4F402.218
ID1_IN((KK-1)*P_FIELD_IN+I)=IP_ROW_SUM/ROW_LENGTH_IN UDG6F404.5
END DO UDG4F402.220
! South polar row UDG4F402.221
IP_ROW_SUM=0 UDG4F402.222
DO I=1,ROW_LENGTH_IN UDG4F402.223
IP_ROW_SUM=IP_ROW_SUM+ID1_IN((KK-1)*P_FIELD_IN+ UDG6F404.6
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I) UDG4F402.225
END DO UDG4F402.226
DO I=1,ROW_LENGTH_IN UDG4F402.227
ID1_IN((KK-1)*P_FIELD_IN+ UDG6F404.7
& (P_ROWS_IN-1)*ROW_LENGTH_IN+I)= UDG4F402.229
& IP_ROW_SUM/ROW_LENGTH_IN UDG4F402.230
END DO UDG4F402.231
END DO UDG4F402.232
END IF UDG4F402.233
ELSE IF(ICODE.NE.0)THEN UDG4F402.234
CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) UDG4F402.235
END IF UDG4F402.236
ELSE CONTROL1.1509
WRITE(6,'('' Reading in new data'')') CONTROL1.1510
WRITE(6,'('' Unrecognised PP field type'',2I16)')J,PP_TYPE_OUT(J) CONTROL1.1511
CALL ABORT CONTROL1.1512
ENDIF CONTROL1.1513
CONTROL1.1515
*IF DEF,TIMER CONTROL1.1516
CALL TIMER('READFLDS',4) CONTROL1.1517
*ENDIF CONTROL1.1518
CONTROL1.1519
C------------------------------------------------------------------- CONTROL1.1520
C If no horizontal interpolation - copy across data to output arrays CONTROL1.1521
C------------------------------------------------------------------- CONTROL1.1522
CONTROL1.1523
IF(.NOT.(HORIZ.OR. CONTROL1.1524
* PP_TYPE_OUT(J).NE.PP_TYPE_IN(POS)))THEN CONTROL1.1525
IF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1526
DO K=1,N_FIELDS_IN CONTROL1.1527
DO I=1,PP_LEN_OUT(J) CONTROL1.1528
D1_TMP(I+PP_LEN_OUT(J)*(K-1))=D1_IN(I+PP_LEN_OUT(J)*(K-1)) CONTROL1.1529
ENDDO CONTROL1.1530
ENDDO CONTROL1.1531
ENDIF CONTROL1.1532
IF(PP_TYPE_OUT(J).EQ.2.OR.PP_TYPE_OUT(J).EQ.3)THEN CONTROL1.1533
DO I=1,PP_LEN_OUT(J) CONTROL1.1534
ID1_OUT(I)=ID1_IN(I) CONTROL1.1535
ENDDO CONTROL1.1536
ENDIF CONTROL1.1537
CONTROL1.1538
ELSE CONTROL1.1539
CONTROL1.1540
C--------------------------------------------------------------- CONTROL1.1541
C Horizontal interpolation of integer/logical fields CONTROL1.1542
C--------------------------------------------------------------- CONTROL1.1543
CONTROL1.1544
IF(PP_TYPE_OUT(J).EQ.2.OR.PP_TYPE_OUT(J).EQ.3)THEN CONTROL1.1545
CONTROL1.1546
IF(H_INT_TYPE)THEN UDG1F400.206
DO I=1,PP_LEN_OUT(J) UDG1F400.207
D1_IN(I)=ID1_IN(I) UDG1F400.208
END DO UDG1F400.209
CALL H_INT_CTL(IDIM,P_FIELD_OUT,ROW_LENGTH_IN,ROW_LENGTH_OUT UDG1F400.210
&, P_ROWS_IN,P_ROWS_OUT,AW_AREA_BOX(1) UDG1F400.211
&, GLOBAL,H_INT_TYPE UDG1F400.212
&, AW_INDEX_TARG_LHS(1,1),AW_INDEX_TARG_TOP(1,1) UDG1F400.213
&, BL_INDEX_B_L(1,1),BL_INDEX_B_R(1,1) UDG1F400.214
&, AW_COLAT_T(1,1),AW_LONG_L(1,1),D1_IN UDG1F400.215
&, WEIGHT_T_R(1,1),WEIGHT_B_R(1,1) UDG1F400.216
&, WEIGHT_T_L(1,1),WEIGHT_B_L(1,1) UDG1F400.217
&, D1_OUT) UDG1F400.218
DO I=1,PP_LEN_OUT(J) UDG1F400.219
ID1_OUT(I)=INT(D1_OUT(I)) UDG1F400.220
END DO UDG1F400.221
ELSE UDG1F400.222
C Use cloud base and top of nearest point on input grid CONTROL1.1547
IF(PP_ITEMC_OUT(J).EQ.14.OR.PP_ITEMC_OUT(J).EQ.15)THEN CONTROL1.1548
DO I=1,PP_LEN_OUT(J) CONTROL1.1549
ID1_OUT(I)=ID1_IN(BL_INDEX_NEAREST(I)) UDG1F400.223
ENDDO CONTROL1.1551
ENDIF CONTROL1.1552
CONTROL1.1553
END IF UDG6F404.8
! Make polar rows constant UDG6F404.9
! North polar row UDG6F404.10
IP_ROW_SUM=0 UDG6F404.11
DO I=1,ROW_LENGTH_OUT UDG6F404.12
IP_ROW_SUM=IP_ROW_SUM+ID1_OUT(I) UDG6F404.13
END DO UDG6F404.14
DO I=1,ROW_LENGTH_OUT UDG6F404.15
ID1_OUT(I)=INT(IP_ROW_SUM/ROW_LENGTH_OUT) UDG6F404.16
END DO UDG6F404.17
! South polar row UDG6F404.18
IP_ROW_SUM=0 UDG6F404.19
DO I=1,ROW_LENGTH_OUT UDG6F404.20
IP_ROW_SUM=IP_ROW_SUM+ID1_OUT( UDG6F404.21
& (P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG6F404.22
END DO UDG6F404.23
DO I=1,ROW_LENGTH_OUT UDG6F404.24
ID1_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) = UDG6F404.25
& INT(IP_ROW_SUM/ROW_LENGTH_OUT) UDG6F404.26
END DO UDG6F404.27
UDG6F404.28
CONTROL1.1554
C--------------------------------------------------------------- CONTROL1.1555
C Horizontal interpolation of real fields CONTROL1.1556
C--------------------------------------------------------------- CONTROL1.1557
CONTROL1.1558
ELSEIF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1559
CONTROL1.1560
C Expand those surface fields stored at land points to full grid CONTROL1.1561
IF(PP_LS_IN(POS).EQ.1)THEN CONTROL1.1562
DO K=1,N_FIELDS_IN CONTROL1.1563
CALL FROM_LAND_POINTS(D1_IN_TMP(1+(K-1)*P_FIELD_IN) CONTROL1.1564
* ,D1_IN(1+(K-1)*PP_LEN_IN(POS)),LAND_SEA_MASK_IN,P_FIELD_IN CONTROL1.1565
* ,LAND_POINTS) CONTROL1.1566
ENDDO CONTROL1.1567
DO I=1,P_FIELD_IN*N_FIELDS_IN CONTROL1.1568
D1_IN(I)=D1_IN_TMP(I) CONTROL1.1569
ENDDO CONTROL1.1570
ENDIF CONTROL1.1571
CONTROL1.1572
POS_D1_IN=1 CONTROL1.1573
POS_D1_OUT=1 CONTROL1.1574
CONTROL1.1575
C Select indices and weights according to grid CONTROL1.1576
IF(GRID_TYPE(J).EQ.1)THEN UDG1F400.225
TYPE=1 UDG1F400.226
X_ROWS_IN=P_ROWS_IN UDG1F400.227
X_ROWS_OUT=P_ROWS_OUT UDG1F400.228
X_COLS_IN=ROW_LENGTH_IN UDG1F400.229
X_COLS_OUT=ROW_LENGTH_OUT UDG1F400.230
X_FIELD_IN=P_FIELD_IN UDG1F400.231
X_FIELD_OUT=P_FIELD_OUT UDG1F400.232
ELSE IF(GRID_TYPE(J).EQ.2.OR.GRID_TYPE(J).EQ.3)THEN UDG1F400.233
IF(C_GRID_IN)THEN UDG1F400.234
IF((PP_ITEMC_OUT(J).EQ.2).OR.(PPXREF_GRID_TYPE.EQ.18))THEN UIE2F401.188
X_ROWS_IN=P_ROWS_IN UIE2F401.189
X_FIELD_IN=P_FIELD_IN UIE2F401.190
ELSEIF((PP_ITEMC_OUT(J).EQ.3).OR. UIE2F401.191
& (PPXREF_GRID_TYPE.EQ.19))THEN UIE2F401.192
X_ROWS_IN=P_ROWS_IN-1 UIE2F401.193
X_FIELD_IN=P_FIELD_IN-ROW_LENGTH_IN UIE2F401.194
ENDIF UIE2F401.195
ELSE UDG1F400.237
X_ROWS_IN=U_ROWS_IN UDG1F400.238
X_FIELD_IN=U_FIELD_IN UDG1F400.239
ENDIF UDG1F400.240
IF(C_GRID_OUT)THEN UDG1F400.241
IF((PP_ITEMC_OUT(J).EQ.2).OR.(PPXREF_GRID_TYPE.EQ.18))THEN UIE2F401.180
X_ROWS_OUT=P_ROWS_OUT UIE2F401.181
X_FIELD_OUT=P_FIELD_OUT UIE2F401.182
ELSEIF((PP_ITEMC_OUT(J).EQ.3).OR. UIE2F401.183
& (PPXREF_GRID_TYPE.EQ.19))THEN UIE2F401.184
X_ROWS_OUT=P_ROWS_OUT-1 UIE2F401.185
X_FIELD_OUT=P_FIELD_OUT-ROW_LENGTH_OUT UIE2F401.186
ENDIF UIE2F401.187
ELSE UDG1F400.244
X_ROWS_OUT=U_ROWS_OUT UDG1F400.245
X_FIELD_OUT=U_FIELD_OUT UDG1F400.246
ENDIF UDG1F400.247
X_COLS_IN=ROW_LENGTH_IN UDG1F400.248
X_COLS_OUT=ROW_LENGTH_OUT UDG1F400.249
UDG1F400.250
IF(PPXREF_GRID_TYPE.EQ.18)TYPE=2 UIE2F401.196
IF(PPXREF_GRID_TYPE.EQ.19)TYPE=3 UIE2F401.197
IF(PP_ITEMC_OUT(J).EQ.2.OR.PP_ITEMC_OUT(J).EQ.28.OR. UDG1F400.251
& PP_ITEMC_OUT(J).EQ.121.OR.PP_ITEMC_OUT(J).EQ.135.OR. UDG1F400.252
& PP_ITEMC_OUT(J).EQ.139.OR.PP_ITEMC_OUT(J).EQ.148.OR. UDG1F400.253
& PP_ITEMC_OUT(J).EQ.150.OR.PP_ITEMC_OUT(J).EQ.202.OR. UDG1F400.254
& PP_ITEMC_OUT(J).EQ.211)THEN UDG1F400.255
TYPE=2 UDG1F400.256
ELSEIF(PP_ITEMC_OUT(J).EQ.3.OR.PP_ITEMC_OUT(J).EQ.29.OR. UDG1F400.257
& PP_ITEMC_OUT(J).EQ.122.OR.PP_ITEMC_OUT(J).EQ.136.OR. UDG1F400.258
& PP_ITEMC_OUT(J).EQ.140.OR.PP_ITEMC_OUT(J).EQ.149.OR. UDG1F400.259
& PP_ITEMC_OUT(J).EQ.151.OR.PP_ITEMC_OUT(J).EQ.203.OR. UDG1F400.260
& PP_ITEMC_OUT(J).EQ.212)THEN UDG1F400.261
TYPE=3 UDG1F400.262
ENDIF UDG1F400.263
ELSEIF(GRID_TYPE(J).EQ.4)THEN UDG1F400.264
TYPE=4 UDG1F400.265
X_ROWS_IN=P_ROWS_IN UDG1F400.266
X_ROWS_OUT=P_ROWS_OUT UDG1F400.267
X_COLS_IN=1 UDG1F400.268
X_COLS_OUT=1 UDG1F400.269
X_FIELD_IN=P_ROWS_IN UDG1F400.270
X_FIELD_OUT=P_ROWS_OUT UDG1F400.271
ENDIF UDG1F400.272
CONTROL1.1598
DO 2000 K=1,N_FIELDS_IN CONTROL1.1599
CONTROL1.1600
C Do horizontal interpolation CONTROL1.1601
CONTROL1.1602
*IF DEF,TIMER CONTROL1.1603
CALL TIMER('HINTCTL',3) UDG1F400.273
*ENDIF CONTROL1.1605
CONTROL1.1606
CALL H_INT_CTL(IDIM,X_FIELD_OUT,X_COLS_IN,X_COLS_OUT UDG1F400.274
&, X_ROWS_IN,X_ROWS_OUT,AW_AREA_BOX(TYPE) UDG1F400.275
&, GLOBAL,H_INT_TYPE UDG1F400.276
&, AW_INDEX_TARG_LHS(1,TYPE),AW_INDEX_TARG_TOP(1,TYPE) UDG1F400.277
&, BL_INDEX_B_L(1,TYPE),BL_INDEX_B_R(1,TYPE) UDG1F400.278
&, AW_COLAT_T(1,TYPE),AW_LONG_L(1,TYPE) UDG1F400.279
&, D1_IN(POS_D1_IN) UDG1F400.280
&, WEIGHT_T_R(1,TYPE),WEIGHT_B_R(1,TYPE) UDG1F400.281
&, WEIGHT_T_L(1,TYPE),WEIGHT_B_L(1,TYPE) UDG1F400.282
&, D1_TMP(POS_D1_OUT)) UDG1F400.283
CONTROL1.1611
*IF DEF,TIMER CONTROL1.1612
CALL TIMER('HINTCTL',4) UDG1F400.284
*ENDIF DR211293.3
AD200593.163
IF(GLOBAL)THEN UDG4F402.647
IF(PPXREF_GRID_TYPE.LE.3)THEN UDG4F402.648
! Horizontal Interpolation has made polar rows non-constant UDG4F402.649
write(6,*) 'Horizontal Interpolation has made polar rows ', UDG4F402.650
& 'non-constant' UDG4F402.651
write(6,*) 'Averaging polar rows to make them constant' UDG4F402.652
UDG4F402.653
! North polar row UDG4F402.654
RP_ROW_SUM=0 UDG4F402.655
DO I=1,ROW_LENGTH_OUT UDG4F402.656
RP_ROW_SUM=RP_ROW_SUM+D1_TMP(POS_D1_OUT+I-1) UDG4F402.657
END DO UDG4F402.658
DO I=1,ROW_LENGTH_OUT UDG4F402.659
D1_TMP(POS_D1_OUT+I-1)=RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.660
END DO UDG4F402.661
! South polar row UDG4F402.662
RP_ROW_SUM=0 UDG4F402.663
DO I=1,ROW_LENGTH_OUT UDG4F402.664
RP_ROW_SUM= UDG4F402.665
& RP_ROW_SUM+D1_TMP(POS_D1_OUT+ UDG4F402.666
& (P_ROWS_OUT-1)*ROW_LENGTH_OUT+I-1) UDG4F402.667
END DO UDG4F402.668
DO I=1,ROW_LENGTH_OUT UDG4F402.669
D1_TMP(POS_D1_OUT+(P_ROWS_OUT-1)*ROW_LENGTH_OUT+I-1)= UDG4F402.670
& RP_ROW_SUM/ROW_LENGTH_OUT UDG4F402.671
END DO UDG4F402.672
END IF UDG4F402.673
END IF UDG4F402.674
C Reset u-wind polar values to mean of adjacent row if C_GRID_OUT=T AD200593.164
IF(PP_ITEMC_OUT(J).EQ.2.AND.C_GRID_OUT)THEN AD200593.165
C N.H. AD200593.166
IF(FIXHD_OUT(4).LT.2)THEN AD200593.167
DO I=ROW_LENGTH_OUT+1,2*ROW_LENGTH_OUT AD200593.168
SUM=SUM+D1_TMP(POS_D1_OUT+I-1) AD200593.169
ENDDO AD200593.170
SUM=SUM/ROW_LENGTH_OUT AD200593.171
DO I=1,ROW_LENGTH_OUT AD200593.172
D1_TMP(POS_D1_OUT+I-1)=SUM AD200593.173
ENDDO AD200593.174
ENDIF AD200593.175
C S.H. AD200593.176
IF(FIXHD_OUT(4).EQ.0.OR.FIXHD_OUT(4).EQ.2)THEN AD200593.177
DO I=U_FIELD_OUT-2*ROW_LENGTH_OUT+1 AD200593.178
& ,U_FIELD_OUT-ROW_LENGTH_OUT AD200593.179
SUM=SUM+D1_TMP(POS_D1_OUT+I-1) AD200593.180
ENDDO AD200593.181
SUM=SUM/ROW_LENGTH_OUT AD200593.182
DO I=U_FIELD_OUT-ROW_LENGTH_OUT+1,U_FIELD_OUT AD200593.183
D1_TMP(POS_D1_OUT+I-1)=SUM AD200593.184
ENDDO AD200593.185
ENDIF AD200593.186
ENDIF AD200593.187
CONTROL1.1615
IF(.NOT.(RadialGridIn.AND..NOT.RadialGridOut))THEN UIE2F401.213
IF(.NOT.(RM_CP))THEN UDG6F405.76
C Calculate sea-ice fraction from TSTAR < TFS CONTROL1.1616
IF(PP_ITEMC_OUT(J).EQ.31) THEN CONTROL1.1617
DO I=1,PP_LEN_OUT(J) CONTROL1.1618
D1_TMP(I)=0.0 CONTROL1.1619
IF(TSTAR(I).LE.TFS.AND..NOT.LAND_SEA_MASK_OUT(I)) CONTROL1.1620
* D1_TMP(I)=1.0 CONTROL1.1621
ENDDO CONTROL1.1622
ENDIF CONTROL1.1623
C Calculate sea-ice thickness from TSTAR < TFS CONTROL1.1624
C Takes values of 2 in N.H. and 1 in S.H. CONTROL1.1625
IF(PP_ITEMC_OUT(J).EQ.32) THEN CONTROL1.1626
C Regional model CONTROL1.1627
IF(GH_TO_LAM)THEN CONTROL1.1628
C N.H. regional model CONTROL1.1629
IF(REALHD_OUT(5).GT.0.)THEN CONTROL1.1630
DO I=1,PP_LEN_OUT(J) CONTROL1.1631
D1_TMP(I)=0.0 CONTROL1.1632
IF(TSTAR(I).LE.TFS.AND..NOT.LAND_SEA_MASK_OUT(I)) CONTROL1.1633
* D1_TMP(I)=2.0 CONTROL1.1634
ENDDO CONTROL1.1635
ELSE CONTROL1.1636
C S.H. regional model CONTROL1.1637
DO I=1,PP_LEN_OUT(J) CONTROL1.1638
D1_TMP(I)=0.0 CONTROL1.1639
IF(TSTAR(I).LE.TFS.AND..NOT.LAND_SEA_MASK_OUT(I)) CONTROL1.1640
* D1_TMP(I)=1.0 CONTROL1.1641
ENDDO CONTROL1.1642
ENDIF CONTROL1.1643
ELSE CONTROL1.1644
C Global model CONTROL1.1645
DO I=1,PP_LEN_OUT(J)/2 CONTROL1.1646
D1_TMP(I)=0.0 CONTROL1.1647
IF(TSTAR(I).LE.TFS.AND..NOT.LAND_SEA_MASK_OUT(I)) CONTROL1.1648
* D1_TMP(I)=2.0 CONTROL1.1649
ENDDO CONTROL1.1650
DO I=PP_LEN_OUT(J)/2+1,PP_LEN_OUT(J) CONTROL1.1651
D1_TMP(I)=0.0 CONTROL1.1652
IF(TSTAR(I).LE.TFS.AND..NOT.LAND_SEA_MASK_OUT(I)) CONTROL1.1653
* D1_TMP(I)=1.0 CONTROL1.1654
ENDDO CONTROL1.1655
ENDIF CONTROL1.1656
ENDIF CONTROL1.1657
UDG2F400.28
IF(HORIZ)THEN UDG2F400.29
CONTROL1.1658
C Correct land-compressed fields along coasts after interpolation as TJ050593.15
C missing data will have been interpolated from sea pts on source grid. TJ050593.16
C Also fill in data at unresolved land and sea points on target grid. TJ050593.17
IF(PP_LS_IN(POS).EQ.1) THEN TJ050593.18
CONTROL1.1668
DO I=1,COASTAL_POINTS CONTROL1.1669
D1_TMP(POS_D1_OUT-1+INDEX_OUT(I))=D1_IN(POS_D1_IN-1 CONTROL1.1670
* +INDEX_IN(I)) CONTROL1.1671
ENDDO CONTROL1.1672
CONTROL1.1673
IF(LSPIRAL_S)THEN UDG1F304.58
DO I=1,P_FIELD_OUT UDG1F304.59
INDEX_TARG_SEA_X(I)=INDEX_TARG_SEA(I) UDG1F304.60
INDEX_TARG_LAND_X(I)=INDEX_TARG_LAND(I) UDG1F304.61
LAND_SEA_MASK_X(I)=0 UDG1F304.62
IF(LAND_SEA_MASK_OUT(I)) LAND_SEA_MASK_X(I)=1 UDG1F304.63
ENDDO UDG1F304.64
SEA_POINTS_UNRESX=SEA_POINTS_UNRES UDG1F304.65
LAND_POINTS_UNRESX=LAND_POINTS_UNRES UDG1F304.66
UDG1F304.67
C UDG1F304.68
C Call INTF_COAST_AJ to find values for unresolved points UDG1F304.69
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_SEA_X UDG1F304.70
*,SEA_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT, UDG1F304.71
* D1_TMP(POS_D1_OUT),0,CYCLIC,MAXDIM) UDG1F304.72
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_LAND_X UDG1F304.73
*,LAND_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT, UDG1F304.74
* D1_TMP(POS_D1_OUT),1,CYCLIC,MAXDIM) UDG1F304.75
UDG1F304.76
ELSE UDG1F304.77
UDG1F304.78
DO I=1,LAND_POINTS_UNRES CONTROL1.1674
D1_TMP(POS_D1_OUT-1+INDEX_TARG_LAND(I)) CONTROL1.1675
1 =D1_TMP(POS_D1_OUT-1+LAND_UNRES_INDEX(I)) CONTROL1.1676
ENDDO CONTROL1.1677
DO I=1,SEA_POINTS_UNRES CONTROL1.1678
D1_TMP(POS_D1_OUT-1+INDEX_TARG_SEA(I)) CONTROL1.1679
1 =D1_TMP(POS_D1_OUT-1+SEA_UNRES_INDEX(I)) CONTROL1.1680
ENDDO CONTROL1.1681
CONTROL1.1682
UDG1F304.79
ENDIF UDG1F304.80
UDG1F304.81
UDG1F304.82
ENDIF CONTROL1.1683
UDG2F400.30
ENDIF UDG2F400.31
CONTROL1.1684
C Ensure that conv cloud amount is not negative CONTROL1.1685
IF(PP_ITEMC_OUT(J).EQ.13.OR.PP_ITEMC_OUT(J).EQ.16)THEN CONTROL1.1686
DO I=1,PP_LEN_OUT(J) CONTROL1.1687
IF(D1_TMP(I).LT.0.)D1_TMP(I)=0. CONTROL1.1688
ENDDO CONTROL1.1689
ENDIF CONTROL1.1690
ENDIF ! RM_CP UDG6F405.77
ENDIF ! Not PFinc2UM UIE2F401.214
CONTROL1.1691
POS_D1_IN=POS_D1_IN+X_FIELD_IN CONTROL1.1692
POS_D1_OUT=POS_D1_OUT+X_FIELD_OUT CONTROL1.1693
CONTROL1.1694
2000 CONTINUE CONTROL1.1695
CONTROL1.1696
C Store selected surface fields at land point CONTROL1.1697
IF(PP_LS_OUT(J).EQ.1)THEN CONTROL1.1698
DO K=1,N_FIELDS_IN CONTROL1.1699
CALL TO_LAND_POINTS(D1_TMP(1+(K-1)*P_FIELD_OUT) CONTROL1.1700
& ,D1_TMP(1+(K-1)*PP_LEN_OUT(J)) UDG3F402.213
* ,LAND_SEA_MASK_OUT,P_FIELD_OUT,LAND_POINTS) CONTROL1.1702
ENDDO CONTROL1.1703
ENDIF CONTROL1.1707
CONTROL1.1708
ENDIF CONTROL1.1709
ENDIF CONTROL1.1710
CONTROL1.1711
C Copy across from temporary space to output space in case vertical CONTROL1.1712
C interpolation not required. CONTROL1.1713
DO I=1,PP_LEN_OUT(J)*N_FIELDS_IN CONTROL1.1714
D1_OUT(I)=D1_TMP(I) CONTROL1.1715
ENDDO CONTROL1.1716
CONTROL1.1717
CONTROL1.1718
C--------------------------------------------------------------- CONTROL1.1719
C Vertical interpolation of real fields CONTROL1.1720
C--------------------------------------------------------------- CONTROL1.1721
LOZONE=(OZONE_LEVELS_IN.NE.OZONE_LEVELS_OUT) UDG3F402.256
& .AND.PP_ITEMC_OUT(J).EQ.60 UDG3F402.257
IF(.NOT.(RadialGridIn.AND..NOT.RadialGridOut))THEN UDG3F402.258
IF((VERT.AND.N_FIELDS_OUT.GT.1).OR.LOZONE)THEN UDG3F402.259
UDG3F402.260
UDG3F402.290
! This block processes u and v components of wind (2 & 3) UDG3F402.291
IF(PP_ITEMC_OUT(J).EQ.2.OR.PP_ITEMC_OUT(J).EQ.3)THEN UDG3F402.292
UDG3F402.293
! Pressure on input levels UDG3F402.309
DO K=1,N_FIELDS_IN UDG3F402.310
DO I=1,PP_LEN_OUT(J) UDG3F402.317
P_TMP(I+(K-1)*PP_LEN_OUT(J))=LEVDEPC_IN(K) UDG3F402.318
& +PSTAR_OUT(I)*LEVDEPC_IN(K+P_LEVELS_IN) UDG3F402.319
END DO UDG3F402.320
END DO UDG3F402.322
UDG3F402.323
POS_D1_TMP=1 UDG3F402.324
DO K=1,N_FIELDS_OUT UDG3F402.325
UDG3F402.326
! Pressure of kth output level UDG3F402.327
DO I=1,PP_LEN_OUT(J) UDG3F402.334
P_OUT(I)=LEVDEPC_OUT(K) UDG3F402.335
& +PSTAR_OUT(I)*LEVDEPC_OUT(K+P_LEVELS_OUT) UDG3F402.336
END DO UDG3F402.337
UDG3F402.339
! Interpolate to find field on new level UDG3F402.340
UDG3F402.341
*IF DEF,TIMER UDG3F402.342
CALL TIMER('V_INT ',3) UDG3F402.343
*ENDIF UDG3F402.344
UDG3F402.345
CALL V_INT(P_TMP,P_OUT,D1_TMP,D1_OUT(POS_D1_TMP), UDG3F402.350
& PP_LEN_OUT(J),N_FIELDS_IN,TEMP,TEMP,.FALSE. UDG4F405.56
& ,1,PP_LEN_OUT(J)) UDG4F405.57
UDG3F402.353
*IF DEF,TIMER UDG3F402.354
CALL TIMER('V_INT ',4) UDG3F402.355
*ENDIF UDG3F402.356
UDG3F402.357
UDG3F402.386
POS_D1_TMP=POS_D1_TMP+PP_LEN_OUT(J) UDG3F402.387
END DO UDG3F402.388
END IF UDG3F402.389
UDG3F402.390
! This block processes QT (11) UDG3F402.391
IF(PP_ITEMC_OUT(J).EQ.11)THEN UDG3F402.392
UDG3F402.393
! Pressure on input levels UDG3F402.409
DO K=1,N_FIELDS_IN UDG3F402.410
DO I=1,PP_LEN_OUT(J) UDG3F402.417
P_TMP(I+(K-1)*PP_LEN_OUT(J))=LEVDEPC_IN(K) UDG3F402.418
& +PSTAR_OUT(I)*LEVDEPC_IN(K+P_LEVELS_IN) UDG3F402.419
END DO UDG3F402.420
END DO UDG3F402.422
UDG3F402.423
POS_D1_TMP=1 UDG3F402.424
DO K=1,N_FIELDS_OUT UDG3F402.425
UDG3F402.426
! Pressure of kth output level UDG3F402.427
DO I=1,PP_LEN_OUT(J) UDG3F402.434
P_OUT(I)=LEVDEPC_OUT(K) UDG3F402.435
& +PSTAR_OUT(I)*LEVDEPC_OUT(K+P_LEVELS_OUT) UDG3F402.436
END DO UDG3F402.437
UDG3F402.439
! Interpolate to find field on new level UDG3F402.440
UDG3F402.441
*IF DEF,TIMER UDG3F402.442
CALL TIMER('V_INT ',3) UDG3F402.443
*ENDIF UDG3F402.444
UDG3F402.445
CALL V_INT(P_TMP,P_OUT,D1_TMP,D1_OUT(POS_D1_TMP), UDG3F402.450
& PP_LEN_OUT(J),N_FIELDS_IN,TEMP,TEMP,.FALSE. UDG4F405.58
& ,1,PP_LEN_OUT(J)) UDG4F405.59
UDG3F402.453
*IF DEF,TIMER UDG3F402.454
CALL TIMER('V_INT ',4) UDG3F402.455
*ENDIF UDG3F402.456
UDG3F402.457
POS_D1_TMP=POS_D1_TMP+PP_LEN_OUT(J) UDG3F402.485
END DO UDG3F402.486
END IF UDG3F402.487
UDG3F402.488
! This block processes Ozone (60) UDG3F402.489
IF(PP_ITEMC_OUT(J).EQ.60)THEN UDG3F402.490
UDG3F402.491
! Pressure on input levels UDG3F402.508
DO K=1+P_LEVELS_IN-N_FIELDS_IN,P_LEVELS_IN UDG3F402.509
DO I=1,PP_LEN_OUT(J) UDG3F402.525
P_TMP(I+(K-(P_LEVELS_IN-N_FIELDS_IN)-1)*PP_LEN_OUT(J))= UDG3F402.526
& LEVDEPC_IN(K)+PSTAR_OUT(I)*LEVDEPC_IN(K+P_LEVELS_IN) UDG3F402.527
END DO UDG3F402.528
END DO UDG3F402.530
UDG3F402.531
POS_D1_TMP=1 UDG3F402.532
DO K=1+P_LEVELS_OUT-N_FIELDS_OUT,P_LEVELS_OUT UDG3F402.533
UDG3F402.534
! Pressure of kth output level UDG3F402.535
DO I=1,PP_LEN_OUT(J) UDG3F402.551
P_OUT(I)=LEVDEPC_OUT(K) UDG3F402.552
& +PSTAR_OUT(I)*LEVDEPC_OUT(K+P_LEVELS_OUT) UDG3F402.553
END DO UDG3F402.554
UDG3F402.556
! Interpolate to find field on new level UDG3F402.557
UDG3F402.558
*IF DEF,TIMER UDG3F402.559
CALL TIMER('V_INT ',3) UDG3F402.560
*ENDIF UDG3F402.561
UDG3F402.562
CALL V_INT(P_TMP,P_OUT,D1_TMP,D1_OUT(POS_D1_TMP), UDG3F402.572
& PP_LEN_OUT(J),N_FIELDS_IN,TEMP,TEMP,.FALSE. UDG4F405.60
& ,1,PP_LEN_OUT(J)) UDG4F405.61
UDG3F402.575
*IF DEF,TIMER UDG3F402.576
CALL TIMER('V_INT ',4) UDG3F402.577
*ENDIF UDG3F402.578
UDG3F402.579
POS_D1_TMP=POS_D1_TMP+PP_LEN_OUT(J) UDG3F402.610
END DO UDG3F402.611
END IF UDG3F402.612
UDG3F402.613
! This block processes THL (5) UDG3F402.614
IF(PP_ITEMC_OUT(J).EQ.5)THEN UDG3F402.615
UDG3F402.616
! Pressure on input levels UDG3F402.631
DO K=1,N_FIELDS_IN UDG3F402.632
DO I=1,PP_LEN_OUT(J) UDG3F402.639
P_TMP(I+(K-1)*PP_LEN_OUT(J))=LEVDEPC_IN(K) UDG3F402.640
& +PSTAR_OUT(I)*LEVDEPC_IN(K+P_LEVELS_IN) UDG3F402.641
END DO UDG3F402.642
END DO UDG3F402.644
UDG3F402.645
! Calculate pressure and exner pressure at output half levels UDG3F402.646
DO K=1,N_FIELDS_OUT+1 UDG3F402.647
DO I=1,PP_LEN_OUT(J) UDG3F402.654
P_HALF_TMP(I,K)=AKH_OUT(K)+BKH_OUT(K)*PSTAR_OUT(I) UDG3F402.655
P_EXNER_HALF_TMP(I,K)=(P_HALF_TMP(I,K)/PREF)**KAPPA GSS9F402.69
END DO UDG3F402.656
END DO UDG3F402.658
UDG3F402.659
! Convert input theta to temperature UDG3F402.660
DO K=1,N_FIELDS_IN UDG3F402.661
DO I=1,PP_LEN_OUT(J) UDG3F402.668
D1_TMP(I+(K-1)*PP_LEN_OUT(J))=D1_TMP(I+(K-1)*PP_LEN_OUT(J)) CONTROL1.1835
* *(P_TMP(I+(K-1)*PP_LEN_OUT(J))/PREF)**KAPPA GSS9F402.70
END DO UDG3F402.669
END DO UDG3F402.671
UDG3F402.672
POS_D1_TMP=1 UDG3F402.673
DO K=1,N_FIELDS_OUT UDG3F402.674
UDG3F402.675
! Pressure of kth output level UDG3F402.676
DO I=1,PP_LEN_OUT(J) UDG3F402.683
P_OUT(I)=LEVDEPC_OUT(K) UDG3F402.684
& +PSTAR_OUT(I)*LEVDEPC_OUT(K+P_LEVELS_OUT) UDG3F402.685
END DO UDG3F402.686
UDG3F402.688
! Interpolate to find field on new level UDG3F402.689
UDG3F402.690
*IF DEF,TIMER UDG3F402.691
CALL TIMER('V_INT ',3) UDG3F402.692
*ENDIF UDG3F402.693
UDG3F402.694
CALL V_INT(P_TMP,P_OUT,D1_TMP,D1_OUT(POS_D1_TMP), UDG3F402.699
& PP_LEN_OUT(J),N_FIELDS_IN,TEMP,TEMP,.FALSE. UDG4F405.62
& ,1,PP_LEN_OUT(J)) UDG4F405.63
UDG3F402.702
*IF DEF,TIMER UDG3F402.703
CALL TIMER('V_INT ',4) UDG3F402.704
*ENDIF UDG3F402.705
UDG3F402.706
! Convert output temperature to thetal UDG3F402.707
DO I=1,PP_LEN_OUT(J) UDG3F402.741
D1_OUT(I+(K-1)*PP_LEN_OUT(J))=D1_OUT(I+(K-1)*PP_LEN_OUT(J)) UDG3F402.742
& /P_EXNER_C(P_EXNER_HALF_TMP(I,K+1),P_EXNER_HALF_TMP(I,K), UDG3F402.743
& P_HALF_TMP(I,K+1),P_HALF_TMP(I,K),KAPPA) UDG3F402.744
END DO UDG3F402.745
POS_D1_TMP=POS_D1_TMP+PP_LEN_OUT(J) UDG3F402.747
END DO UDG3F402.748
END IF UDG3F402.749
UDG3F402.750
END IF ! VERT+multilevel or change in number of ozone levels UDG3F402.754
UDG6F404.29
! This block processes convective cloud base level number (14) UDG6F404.30
! and convective cloud top level number (15) UDG6F404.31
IF(VERT.AND.(PP_ITEMC_OUT(J).EQ.14.OR.PP_ITEMC_OUT(J).EQ.15))THEN UDG6F404.32
UDG6F404.33
CALL VERT_CLD(P_FIELD_OUT,Q_LEVELS_IN,Q_LEVELS_OUT, UDG6F404.34
& LEN1_LEVDEPC_IN,LEN2_LEVDEPC_IN,LEVDEPC_IN, UDG6F404.35
& ID1_OUT) UDG6F404.36
END IF UDG6F404.37
END IF ! Not PFinc2UM UDG3F402.755
ENDIF ! Block starts at test of POS=0 UDG3F402.767
CONTROL1.1883
C--------------------------------------------------------------- CONTROL1.1884
C Write out this set of real/integer/logical data fields CONTROL1.1885
C--------------------------------------------------------------- CONTROL1.1886
CONTROL1.1887
*IF DEF,TIMER CONTROL1.1888
CALL TIMER('WRITFLDS',3) CONTROL1.1889
*ENDIF CONTROL1.1890
CONTROL1.1891
IF(PP_SOURCE_OUT(J).NE.5.AND.PP_SOURCE_OUT(J).NE.7)THEN UDG4F304.136
IF(PP_TYPE_OUT(J).EQ.1)THEN CONTROL1.1892
C Real data CONTROL1.1893
IF(PP_SOURCE_OUT(J).EQ.3.OR.PP_SOURCE_OUT(J).EQ.4.OR. UDG7F400.189
& PP_SOURCE_OUT(J).EQ.6)THEN UDG7F400.190
DO K=1,N_FIELDS_OUT CONTROL1.1895
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(J)+K-1,LOOKUP_OUT, GDG0F401.342
& LEN1_LOOKUP_OUT, GDG0F401.343
& D1_OUT,PP_LEN_OUT(J),FIXHD_OUT, GDG0F401.344
*CALL ARGPPX GDG0F401.345
& ICODE,CMESSAGE) GDG0F401.346
ENDDO CONTROL1.1898
ELSE CONTROL1.1899
CALL WRITFLDS(NFTOUT,N_FIELDS_OUT,PP_POS_OUT(J),LOOKUP_OUT, GDG0F401.347
& LEN1_LOOKUP_OUT,D1_OUT,PP_LEN_OUT(J),FIXHD_OUT, GDG0F401.348
*CALL ARGPPX GDG0F401.349
& ICODE,CMESSAGE) GDG0F401.350
ENDIF CONTROL1.1902
C Integer/Logical data CONTROL1.1903
ELSEIF(PP_TYPE_OUT(J).EQ.2.OR.PP_TYPE_OUT(J).EQ.3)THEN CONTROL1.1904
IF(PP_SOURCE_OUT(J).EQ.3.OR.PP_SOURCE_OUT(J).EQ.4.OR. UDG7F400.191
& PP_SOURCE_OUT(J).EQ.6)THEN UDG7F400.192
DO K=1,N_FIELDS_OUT CONTROL1.1906
CALL WRITFLDS(NFTOUT,1,PP_POS_OUT(J)+K-1,LOOKUP_OUT, GDG0F401.351
& LEN1_LOOKUP_OUT, GDG0F401.352
& ID1_OUT,PP_LEN_OUT(J),FIXHD_OUT, GDG0F401.353
*CALL ARGPPX GDG0F401.354
& ICODE,CMESSAGE) GDG0F401.355
ENDDO CONTROL1.1909
ELSE CONTROL1.1910
CALL WRITFLDS(NFTOUT,N_FIELDS_OUT,PP_POS_OUT(J),LOOKUP_OUT, GDG0F401.356
& LEN1_LOOKUP_OUT,ID1_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.357
*CALL ARGPPX GDG0F401.358
& ICODE,CMESSAGE) GDG0F401.359
ENDIF CONTROL1.1913
ELSE CONTROL1.1914
WRITE(6,'('' Writing out new data'')') CONTROL1.1915
WRITE(6,'('' Unrecognised PP field type'',2I16)')J,PP_TYPE_OUT(J) CONTROL1.1916
CALL ABORT CONTROL1.1917
ENDIF CONTROL1.1918
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1919
ENDIF AD200193.5
CONTROL1.1920
*IF DEF,TIMER CONTROL1.1921
CALL TIMER('WRITFLDS',4) CONTROL1.1922
*ENDIF CONTROL1.1923
CONTROL1.1924
1400 CONTINUE CONTROL1.1925
UDG6F404.38
! Check convective cloud base and top after vertical interpolation. UDG6F404.39
! If convective cloud top and base are at the same level then UDG6F404.40
! increment convective cloud top by on level. UDG6F404.41
IF(VERT)THEN UDG6F404.42
CALL CNV_CLD_CHK(P_FIELD_OUT,N_TYPES_OUT,NFTOUT,FIXHD_OUT, UDG6F404.43
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT,LOOKUP_OUT, UDG6F404.44
*CALL ARGPPX UDG6F404.45
& Q_LEVELS_OUT,PP_POS_OUT,PP_ITEMC_OUT) UDG6F404.46
END IF UDG6F404.47
UDG6F404.48
UDG6F404.49
UDR1F400.16
! Now that output dump is set up, initialise fields if required. UDR1F400.17
! To initialise fields, S=8 in ITEMS Namelist. UDR1F400.18
! From 4.1, R=n to be added to ITEMS Namelist to allow different UDR1F400.19
! ways of initialising a field. UDR1F400.20
UDR1F400.21
DO J = 1,N_TYPES_OUT UDR1F400.22
UDR1F400.24
! Get model number for this field GDR7F404.75
MODEL = LOOKUP_OUT(45,PP_POS_OUT(J)) GDR7F404.76
IF (PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.77
write (6,*) ' SOURCE=8 : Stash No ',pp_itemc_out(j), GDR7F404.78
& ' Model No ',Model GDR7F404.79
ENDIF GDR7F404.80
GDR7F404.81
IF (PP_ITEMC_OUT(J).EQ.49.AND. ! Initialise SEA ICE temp UCB1F402.1
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.82
& PP_SOURCE_OUT(J).EQ.8) THEN ! if not in dump UCB1F402.2
UDR1F400.26
! S=8 is not set in the UMUI for this field. It is set in UDR1F400.27
! loop 1400 if no field is found in the input dump. UDR1F400.28
UDR1F400.29
WRITE (6,*) ' ' UDR1F400.30
WRITE (6,*) ' No Sea Ice Temperature in input dump' UDR1F400.31
WRITE (6,*) ' Sea Ice Temperature being initialised.' UDR1F400.32
CALL LOCATE (24,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDR1F400.33
IF (POS.EQ.0) THEN UDR1F400.34
CMESSAGE = UDR1F400.35
& 'CONTROL : Problem with initialising sea ice temperature' UDR1F400.36
WRITE (6,*) 'T* not found in output dump.' UDR1F400.37
WRITE (6,*) 'Sea Ice Temperature in output dump cannot ', UDR1F400.38
& 'be initialised' UDR1F400.39
CALL ABORT UDR1F400.40
ELSE UDR1F400.41
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UDR1F400.42
& LEN1_LOOKUP_OUT,TSTAR,P_FIELD_OUT,FIXHD_OUT, UDR1F400.43
*CALL ARGPPX GDG0F401.360
& ICODE,CMESSAGE) UDR1F400.44
IF (ICODE.GT.0) THEN UDR1F400.45
WRITE (6,*) ' Problem with reading T* field.' UDR1F400.46
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDR1F400.47
ENDIF UDR1F400.48
CALL LOCATE (49,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDR1F400.49
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UDR1F400.50
& LEN1_LOOKUP_OUT,TSTAR,P_FIELD_OUT,FIXHD_OUT, UDR1F400.51
*CALL ARGPPX GDG0F401.361
& ICODE,CMESSAGE) UDR1F400.52
IF (ICODE.GT.0) THEN UDR1F400.53
WRITE (6,*) ' Problem with writing sea ice temp field' UDR1F400.54
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDR1F400.55
ENDIF UDR1F400.56
WRITE (6,*) ' SEA ICE TEMPERATURE (Stash Code 49) has ', UDR1F400.57
& 'been initialised from T*.' UDR1F400.58
ENDIF UDR1F400.59
! UJS1F401.61
ELSEIF (PP_ITEMC_OUT(J).EQ.214.AND. ! Unfrozen soil moisture UCB1F402.3
& MODEL.EQ.ATMOS_IM .AND. ! fraction GDR7F404.83
& (PP_SOURCE_OUT(J).EQ.8.OR. ! not in dump or UCB1F402.5
& SWITCH(10).EQ.1.OR. ! deep soil temp.or UCB1F402.6
& SWITCH(36).EQ.1)) THEN ! soil moisture in layer UCB1F402.7
! ! ancilliary fields UCB1F402.8
! ! requested UCB1F402.9
! S=8 is not set in the UMUI for this field. It is set in UJS1F401.64
! loop 1400 if no field is found in the input dump. UJS1F401.65
! UJS1F401.66
CALL INIT_MOSES(P_FIELD_OUT,SM_LEVELS_OUT,ST_LEVELS_OUT, UDG4F404.26
& FIXHD_OUT,LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT, UDG4F404.27
& LOOKUP_OUT,LAND_POINTS_OUT,NFTOUT, UDG4F404.28
& N_TYPES_OUT,PP_ITEMC_OUT,PP_POS_OUT, UDG4F404.29
*CALL ARGPPX UDG4F404.30
& D1_OUT(1),D1_OUT(SM_LEVELS_OUT*P_FIELD_OUT+1), UDG4F404.31
& D1_OUT((SM_LEVELS_OUT+ST_LEVELS_OUT) UDG4F404.32
& *P_FIELD_OUT+1), UDG4F404.33
& D1_OUT((SM_LEVELS_OUT+ST_LEVELS_OUT+1) UDG4F404.34
& *P_FIELD_OUT+1), UDG4F404.35
& D1_OUT((SM_LEVELS_OUT+ST_LEVELS_OUT+2) UDG4F404.36
& *P_FIELD_OUT+1)) UDG4F404.37
UDG4F404.38
UJS1F401.192
ELSEIF (PP_ITEMC_OUT(J).EQ.213.AND. ! Canopy Conductance UCB1F402.10
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.84
& PP_SOURCE_OUT(J).EQ.8) THEN ! if not in dump UCB1F402.11
! S=8 is not set in the UMUI for this field. It is set in UJS1F401.195
! loop 1400 if no field is found in the input dump. UJS1F401.196
UJS1F401.197
WRITE (6,*) ' ' UJS1F401.198
WRITE (6,*) ' No Canopy Conductance in input dump' UJS1F401.199
WRITE (6,*) ' Canopy Conductance being initialised.' UJS1F401.200
CALL LOCATE (54,PP_ITEMC_OUT,N_TYPES_OUT,POS) UJS1F401.201
IF (POS.EQ.0) THEN UJS1F401.202
CMESSAGE = UJS1F401.203
& 'CONTROL : Problem with initialising canopy conductance' UJS1F401.204
WRITE (6,*) 'Resistance not found in output dump.' UJS1F401.205
WRITE (6,*) 'Canopy Conductance in output dump cannot ', UJS1F401.206
& 'be initialised' UJS1F401.207
CALL ABORT UJS1F401.208
ELSE UJS1F401.209
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UJS1F401.210
& LEN1_LOOKUP_OUT,D1_TEMP,P_FIELD_OUT,FIXHD_OUT, UDG4F404.39
*CALL ARGPPX UJS1F401.212
& ICODE,CMESSAGE) UJS1F401.213
IF (ICODE.GT.0) THEN UJS1F401.214
WRITE (6,*) ' Problem with reading Resistance field.' UJS1F401.215
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UJS1F401.216
ENDIF UJS1F401.217
DO I=1,P_FIELD_OUT UJS1F401.218
IF (D1_TEMP(I).NE.0.0) THEN UDG4F404.40
D1_TEMP(I) = 1./ D1_TEMP(I) UDG4F404.41
ELSE UJS1F401.221
D1_TEMP(I) = RMDI UDG4F404.42
ENDIF UJS1F401.223
ENDDO UJS1F401.224
CALL LOCATE (213,PP_ITEMC_OUT,N_TYPES_OUT,POS) UJS1F401.225
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UJS1F401.226
& LEN1_LOOKUP_OUT,D1_TEMP,P_FIELD_OUT,FIXHD_OUT, UDG4F404.43
*CALL ARGPPX UJS1F401.228
& ICODE,CMESSAGE) UJS1F401.229
IF (ICODE.GT.0) THEN UJS1F401.230
WRITE (6,*) ' Problem with writing conductance field.' UJS1F401.231
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UJS1F401.232
ENDIF UJS1F401.233
WRITE (6,*) ' CANOPY CONDUCTANCE (Stash Code 213) has ', UJS1F401.234
& 'been initialised from 1./ RESIST' UJS1F401.235
ENDIF UJS1F401.236
UDR1F400.60
ELSEIF (PP_ITEMC_OUT(J).EQ.12 .AND. ! Initialize QCF UDG4F404.44
& MODEL.EQ.ATMOS_IM .AND. ! if not in dump UDG4F404.45
& PP_SOURCE_OUT(J).EQ.8) THEN UDG4F404.46
UDG4F404.47
! S=8 is not set in the UMUI for this field. It is set in UDG4F404.48
! loop 1400 if no field is found in the input dump. UDG4F404.49
UDG4F404.50
WRITE (6,*) ' ' UDG4F404.51
WRITE (6,*) ' No QCF found in input dump ' UDG4F404.52
WRITE (6,*) 'QCF being initialised ' UDG4F404.53
UDG4F404.54
DO I= 1,P_FIELD_OUT*Q_LEVELS_OUT UDG4F404.55
D1_OUT(I) = 0.0 UDG4F404.56
END DO UDG4F404.57
UDG4F404.58
CALL LOCATE (12,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDG4F404.59
CALL WRITFLDS (NFTOUT,Q_LEVELS_OUT, UDG4F404.60
& PP_POS_OUT(POS),LOOKUP_OUT, UDG4F404.61
& LEN1_LOOKUP_OUT,D1_OUT,P_FIELD_OUT,FIXHD_OUT, UDG4F404.62
*CALL ARGPPX UDG4F404.63
& ICODE,CMESSAGE) UDG4F404.64
IF (ICODE.GT.0) THEN UDG4F404.65
WRITE (6,*) ' Problem with writing QCF field' UDG4F404.66
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDG4F404.67
END IF UDG4F404.68
WRITE (6,*) ' QCF (Stash Code 12) has been ', UDG4F404.69
& 'initialised to zero' UDG4F404.70
UDG4F404.71
ELSEIF (PP_ITEMC_OUT(J).EQ.210.AND. ! Slab Temperature UCB1F402.12
& MODEL.EQ.SLAB_IM .AND. GDR7F404.85
& PP_SOURCE_OUT(J).EQ.8) THEN ! if not in dump UCB1F402.13
UDR1F400.62
WRITE (6,*) ' ' UDR1F400.63
WRITE (6,*) ' Slab Temperature being Initialised' UDR1F400.64
UDR1F400.65
! Get T* field from output dump UDR1F400.66
CALL LOCATE (24,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDR1F400.67
IF (POS.EQ.0) THEN UDR1F400.68
CMESSAGE = UDR1F400.69
& 'CONTROL : Problem with initialising Slab Temperature' UDR1F400.70
WRITE (6,*) ' T* not found in output dump.' UDR1F400.71
WRITE (6,*) ' Slab Temperature cannot be initialised.' UDR1F400.72
CALL ABORT UDR1F400.73
ELSE UDR1F400.74
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UDR1F400.75
& LEN1_LOOKUP_OUT,TSTAR,P_FIELD_OUT,FIXHD_OUT, UDR1F400.76
*CALL ARGPPX GDG0F401.362
& ICODE,CMESSAGE) UDR1F400.77
IF (ICODE.GT.0) THEN UDR1F400.78
WRITE (6,*) ' Problem with reading T* field.' UDR1F400.79
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDR1F400.80
ENDIF UDR1F400.81
ENDIF UDR1F400.82
UDR1F400.83
! Get Ice Fraction field from output dump UDR1F400.84
CALL LOCATE (31,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDR1F400.85
IF (POS.EQ.0) THEN UDR1F400.86
CMESSAGE = UDR1F400.87
& 'CONTROL : Problem with initialising Slab Temperature' UDR1F400.88
WRITE (6,*) ' Ice fraction not found in output dump.' UDR1F400.89
WRITE (6,*) ' Slab Temperature cannot be initialised.' UDR1F400.90
CALL ABORT UDR1F400.91
ELSE UDR1F400.92
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UDR1F400.93
& LEN1_LOOKUP_OUT,D1_TEMP,P_FIELD_OUT,FIXHD_OUT, UDR1F400.94
*CALL ARGPPX GDG0F401.363
& ICODE,CMESSAGE) UDR1F400.95
IF (ICODE.GT.0) THEN UDR1F400.96
WRITE (6,*) ' Problem with reading Ice Fration field.' UDR1F400.97
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDR1F400.98
ENDIF UDR1F400.99
ENDIF UDR1F400.100
UDR1F400.101
! Derive Slab Temperature from T* and Ice Fraction UDR1F400.102
DO I=1,P_FIELD_OUT UDR1F400.103
IF (D1_TEMP(I).EQ.0) THEN UDR1F400.104
D1_TEMP(I) = TSTAR(I)-273.15 UDR1F400.105
ELSEIF (D1_TEMP(I).GT.0) THEN UDR1F400.106
D1_TEMP(I) = -1.8 UDR1F400.107
ELSE UDR1F400.108
D1_TEMP(I) = RMDI UDR1F400.109
ENDIF UDR1F400.110
ENDDO UDR1F400.111
UDR1F400.112
! Write out Slab Temperature field UDR1F400.113
CALL LOCATE (210,PP_ITEMC_OUT,N_TYPES_OUT,POS) UDR1F400.114
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT, UDR1F400.115
& LEN1_LOOKUP_OUT,D1_TEMP,P_FIELD_OUT,FIXHD_OUT, UDR1F400.116
*CALL ARGPPX GDG0F401.364
& ICODE,CMESSAGE) UDR1F400.117
IF (ICODE.GT.0) THEN UDR1F400.118
WRITE (6,*) ' Problem with writing Slab Temp. field.' UDR1F400.119
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) UDR1F400.120
ENDIF UDR1F400.121
WRITE (6,*) ' SLAB TEMPERATURE (Stash Code 210) has been ', UDR1F400.122
& 'initialised as follows :' UDR1F400.123
WRITE (6,*) ' If Ice Fraction = 0 : Slab T = T*-273.15' UDR1F400.124
WRITE (6,*) ' If Ice Fraction > 0 : Slab T = -1.8' UDR1F400.125
WRITE (6,*) ' Otherwise : Slab T = RMDI' UDR1F400.126
UDR1F400.127
ELSEIF( (PP_ITEMC_OUT(J).EQ.211) .AND. ! If 3D CCA AJX1F404.20
& (MODEL.EQ.ATMOS_IM) .AND. ! not in dump AJX1F404.21
& (PP_SOURCE_OUT(J).EQ.8 ) .AND. AJX1F404.22
& (L_3D_CCA) ) THEN AJX1F404.23
AJX1F404.24
WRITE (6,*) ' ' AJX1F404.25
WRITE (6,*) ' 3D CCA being Initialised' AJX1F404.26
! AJX1F404.27
! Get 2D CCA field from input dump AJX1F404.28
CALL LOCATE (13,PP_ITEMC_IN,N_TYPES_IN,POS) AJX1F404.29
IF (POS.EQ.0) THEN AJX1F404.30
CMESSAGE = AJX1F404.31
& 'CONTROL : Problem with initialising 3D CCA' AJX1F404.32
WRITE (6,*) ' 2D CCA not found in input dump.' AJX1F404.33
WRITE (6,*) ' 3D CCA cannot be initialised.' AJX1F404.34
CALL ABORT AJX1F404.35
ELSE AJX1F404.36
CALL READFLDS (NFTIN,1,PP_POS_IN(POS),LOOKUP_IN, AJX1F404.37
& LEN1_LOOKUP_IN,D1_IN,P_FIELD_IN,FIXHD_IN, AJX1F404.38
*CALL ARGPPX AJX1F404.39
& ICODE,CMESSAGE) AJX1F404.40
IF (ICODE.GT.0) THEN AJX1F404.41
WRITE (6,*) ' Problem with reading 2D CCA field.' AJX1F404.42
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTIN) AJX1F404.43
ENDIF AJX1F404.44
ENDIF AJX1F404.45
! do horizontal interpolation: AJX1F404.46
TYPE=1 AJX1F404.47
X_ROWS_IN=P_ROWS_IN AJX1F404.48
X_ROWS_OUT=P_ROWS_OUT AJX1F404.49
X_COLS_IN=ROW_LENGTH_IN AJX1F404.50
X_COLS_OUT=ROW_LENGTH_OUT AJX1F404.51
X_FIELD_IN=P_FIELD_IN AJX1F404.52
X_FIELD_OUT=P_FIELD_OUT AJX1F404.53
CALL H_INT_CTL(IDIM,X_FIELD_OUT,X_COLS_IN,X_COLS_OUT AJX1F404.54
&, X_ROWS_IN,X_ROWS_OUT,AW_AREA_BOX(TYPE) AJX1F404.55
&, GLOBAL,H_INT_TYPE AJX1F404.56
&,AW_INDEX_TARG_LHS(1,TYPE),AW_INDEX_TARG_TOP(1,TYPE) AJX1F404.57
&, BL_INDEX_B_L(1,TYPE),BL_INDEX_B_R(1,TYPE) AJX1F404.58
&, AW_COLAT_T(1,TYPE),AW_LONG_L(1,TYPE),D1_IN AJX1F404.59
&, WEIGHT_T_R(1,TYPE),WEIGHT_B_R(1,TYPE) AJX1F404.60
&, WEIGHT_T_L(1,TYPE),WEIGHT_B_L(1,TYPE),D1_OUT) AJX1F404.61
! AJX1F404.62
! make sure polar rows are constant. AJX1F404.63
! AJX1F404.64
IF(GLOBAL)THEN AJX1F404.65
IF(PPXREF_GRID_TYPE.LE.3)THEN AJX1F404.66
! Horizontal Interpolation has made polar rows non-constant AJX1F404.67
write(6,*) 'Horizontal Interpolation has made polar rows ', AJX1F404.68
& 'non-constant' AJX1F404.69
write(6,*) 'Averaging polar rows to make them constant' AJX1F404.70
! AJX1F404.71
! North polar row AJX1F404.72
RP_ROW_SUM=0 AJX1F404.73
DO I=1,ROW_LENGTH_OUT AJX1F404.74
RP_ROW_SUM=RP_ROW_SUM+D1_OUT(I) AJX1F404.75
END DO AJX1F404.76
DO I=1,ROW_LENGTH_OUT AJX1F404.77
D1_OUT(I)=RP_ROW_SUM/ROW_LENGTH_OUT AJX1F404.78
END DO AJX1F404.79
! South polar row AJX1F404.80
RP_ROW_SUM=0 AJX1F404.81
DO I=1,ROW_LENGTH_OUT AJX1F404.82
RP_ROW_SUM= AJX1F404.83
& RP_ROW_SUM+D1_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) AJX1F404.84
END DO AJX1F404.85
DO I=1,ROW_LENGTH_OUT AJX1F404.86
D1_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= AJX1F404.87
& RP_ROW_SUM/ROW_LENGTH_OUT AJX1F404.88
END DO AJX1F404.89
END IF AJX1F404.90
END IF AJX1F404.91
! AJX1F404.92
! Ensure that conv cloud amount is not negative AJX1F404.93
DO I=1,P_FIELD_OUT AJX1F404.94
IF(D1_OUT(I).LT.0.)D1_OUT(I)=0. AJX1F404.95
ENDDO AJX1F404.96
! AJX1F404.97
! Call DERV_CCA_3D to derive 3D cca from 2D cca. AJX1F404.98
! AJX1F404.99
CALL DERV_3D_CCA(D1_OUT,NFTOUT,PP_POS_OUT,LOOKUP_OUT AJX1F404.100
& ,LEN1_LOOKUP_OUT,LEN2_LOOKUP_OUT AJX1F404.101
& ,P_FIELD_OUT,Q_LEVELS_OUT,BL_LEVELS_OUT AJX1F404.102
& ,P_LEVELS_OUT,ANVIL_FACTOR,TOWER_FACTOR AJX1F404.103
& ,L_CLOUD_DEEP AJX3F405.221
& ,PP_ITEMC_OUT,N_TYPES_OUT,FIXHD_OUT, AJX1F404.104
*CALL ARGPPX AJX1F404.105
& AKH_OUT,BKH_OUT,P_HALF_TMP,PSTAR_OUT) AJX1F404.106
GDR7F404.86
ELSEIF (PP_ITEMC_OUT(J).EQ.221 .AND. ! Snow Soot Content GDR7F404.87
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.88
& L_SNOW_ALBEDO .AND. GDR7F404.89
& PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.90
GDR7F404.91
! S=8 is not set in the UMUI for this field. It is set in GDR7F404.92
! loop 1400 if no field is found in the input dump. GDR7F404.93
GDR7F404.94
WRITE (6,*) ' ' GDR7F404.95
WRITE (6,*) ' No SNOW SOOT CONTENT found in input dump ' GDR7F404.96
WRITE (6,*) ' SNOW SOOT CONTENT being initialised ' GDR7F404.97
GDR7F404.98
DO I= 1,P_FIELD_OUT GDR7F404.99
D1_TEMP(I) = 0.0 GDR7F404.100
END DO GDR7F404.101
GDR7F404.102
CALL LOCATE (221,PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.103
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS), GDR7F404.104
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.105
& D1_TEMP,P_FIELD_OUT,FIXHD_OUT, GDR7F404.106
*CALL ARGPPX GDR7F404.107
& ICODE,CMESSAGE) GDR7F404.108
IF (ICODE.GT.0) THEN GDR7F404.109
WRITE (6,*) ' Problem with writing SNOW SOOT field' GDR7F404.110
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.111
END IF GDR7F404.112
WRITE (6,*) ' SNOW SOOT CONTENT (Stash Code 221) has ', GDR7F404.113
& 'been initialised to zero' GDR7F404.114
GDR7F404.115
ELSEIF ((PP_ITEMC_OUT(J).EQ.224 .OR. GDR7F404.116
& PP_ITEMC_OUT(J).EQ.225 .OR. GDR7F404.117
& PP_ITEMC_OUT(J).EQ.226 .OR. GDR7F404.118
& PP_ITEMC_OUT(J).EQ.227 .OR. GDR7F404.119
& PP_ITEMC_OUT(J).EQ.228 .OR. GDR7F404.120
& PP_ITEMC_OUT(J).EQ.230 .OR. GDR7F404.121
& PP_ITEMC_OUT(J).EQ.234) .AND. GDR7F404.122
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.123
& (L_TRIFFID.OR.L_VEG_FRACS) .AND. GDR7F404.124
& PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.125
GDR7F404.126
! S=8 is not set in the UMUI for this field. It is set in GDR7F404.127
! loop 1400 if no field is found in the input dump. GDR7F404.128
GDR7F404.129
WRITE (6,*) ' ' GDR7F404.130
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.131
& ' - not found in input dump.' GDR7F404.132
GDR7F404.133
! If not present in the input dump, Items 224, 225, 226, 227, 228, 230 GDR7F404.134
! and 234 are initialised properly in the atmosphere routine INIT_VEG. GDR7F404.135
! Here they are initialised to an arbitrary value to avoid handling of GDR7F404.136
! non-numeric data. A physically unrealistic value of -1.0 is intended GDR7F404.137
! to help warn of incorrect use of the fields prior to INIT_VEG. GDR7F404.138
! All fields are land fields GDR7F404.139
DO I= 1,LAND_POINTS GDR7F404.140
D1_TEMP(I) = -1.0 GDR7F404.141
END DO GDR7F404.142
GDR7F404.143
! Find position in output dump GDR7F404.144
CALL LOCATE (PP_ITEMC_OUT(J),PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.145
GDR7F404.146
! Get no of pseudo-levels GDR7F404.147
N_PSL = NPFT GDR7F404.148
IF(PP_ITEMC_OUT(J).EQ.228) N_PSL=1 GDR7F404.149
IF(PP_ITEMC_OUT(J).EQ.230) N_PSL=NTYPE-1 GDR7F404.150
IF(PP_ITEMC_OUT(J).EQ.234) N_PSL=NTYPE GDR7F404.151
GDR7F404.152
! Write fields into output dump GDR7F404.153
DO I=1,N_PSL GDR7F404.154
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS)+I-1, GDR7F404.155
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.156
& D1_TEMP,LAND_POINTS,FIXHD_OUT, GDR7F404.157
*CALL ARGPPX GDR7F404.158
& ICODE,CMESSAGE) GDR7F404.159
IF (ICODE.GT.0) THEN GDR7F404.160
WRITE (6,*) ' Problem in WRITFLDS - ', GDR7F404.161
& ' Stash Code ',PP_ITEMC_OUT(J), GDR7F404.162
& ' Pseudo Level ',I GDR7F404.163
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.164
END IF GDR7F404.165
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.166
& ' Pseudo Level ',I, GDR7F404.167
& ' has been initialised to -1.0' GDR7F404.168
END DO GDR7F404.169
GDR7F404.170
ELSEIF (PP_ITEMC_OUT(J).EQ.229 .AND. GDR7F404.171
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.172
& (L_TRIFFID.OR.L_VEG_FRACS) .AND. GDR7F404.173
& PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.174
GDR7F404.175
! S=8 is not set in the UMUI for this field. It is set in GDR7F404.176
! loop 1400 if no field is found in the input dump. GDR7F404.177
GDR7F404.178
WRITE (6,*) ' ' GDR7F404.179
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.180
& ' - not found in input dump.' GDR7F404.181
GDR7F404.182
! If not present in the input dump, item 229 (canopy water on non-ice GDR7F404.183
! tiles) is initialised from item 22 (gridbox mean canopy water). GDR7F404.184
! However, item 22 is not expected in the output dump if item 229 is GDR7F404.185
! required, so take item 22 from input dump. GDR7F404.186
GDR7F404.187
! Find Gridbox Mean Canopy Water (item 22) in input dump GDR7F404.188
CALL LOCATE (22,PP_ITEMC_IN,N_TYPES_IN,POS) GDR7F404.189
IF (POS.EQ.0) THEN GDR7F404.190
WRITE (6,*) ' Gridbox Mean Canopy Water Stash Code 22', GDR7F404.191
& ' not found in input dump.' GDR7F404.192
WRITE (6,*) ' Canopy Water on non-ice tiles', GDR7F404.193
& ' cannot be initialised.' GDR7F404.194
CALL ABORT GDR7F404.195
ENDIF GDR7F404.196
GDR7F404.197
! Read in Gridbox Mean Canopy Water from input dump GDR7F404.198
CALL READFLDS (NFTIN,1,PP_POS_IN(POS), GDR7F404.199
& LOOKUP_IN,LEN1_LOOKUP_IN, GDR7F404.200
! & D1_IN,LAND_POINTS,FIXHD_IN, GDR7F404.201
& D1_IN,P_FIELD_IN,FIXHD_IN, GDR7F404.202
*CALL ARGPPX GDR7F404.203
& ICODE,CMESSAGE) GDR7F404.204
IF (ICODE.GT.0) THEN GDR7F404.205
WRITE (6,*) ' Problem in READFLDS for Gridbox Mean ', GDR7F404.206
& ' Canopy Water Stash Code 22.' GDR7F404.207
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTIN) GDR7F404.208
END IF GDR7F404.209
GDR7F404.210
! if input and output dumps on different grids then interpolate canopy GDR7F404.211
! water content from input grid to output grid GDR7F404.212
IF(HORIZ)THEN GDR7F404.213
GDR7F404.214
! expand from land points to full grid before interpolation GDR7F404.215
CALL FROM_LAND_POINTS (D1_IN_TMP,D1_IN, GDR7F404.216
& LAND_SEA_MASK_IN,P_FIELD_IN,LAND_POINTS) GDR7F404.217
GDR7F404.218
! do horizontal interpolation: GDR7F404.219
TYPE = 1 GDR7F404.220
X_ROWS_IN = P_ROWS_IN GDR7F404.221
X_ROWS_OUT = P_ROWS_OUT GDR7F404.222
X_COLS_IN = ROW_LENGTH_IN GDR7F404.223
X_COLS_OUT = ROW_LENGTH_OUT GDR7F404.224
X_FIELD_IN = P_FIELD_IN GDR7F404.225
X_FIELD_OUT = P_FIELD_OUT GDR7F404.226
POS_D1_IN = 1 GDR7F404.227
POS_D1_OUT = 1 GDR7F404.228
CALL H_INT_CTL(IDIM,X_FIELD_OUT,X_COLS_IN,X_COLS_OUT GDR7F404.229
&, X_ROWS_IN,X_ROWS_OUT,AW_AREA_BOX(TYPE) GDR7F404.230
&, GLOBAL,H_INT_TYPE GDR7F404.231
&, AW_INDEX_TARG_LHS(1,TYPE),AW_INDEX_TARG_TOP(1,TYPE) GDR7F404.232
&, BL_INDEX_B_L(1,TYPE),BL_INDEX_B_R(1,TYPE) GDR7F404.233
&, AW_COLAT_T(1,TYPE),AW_LONG_L(1,TYPE),D1_IN_TMP GDR7F404.234
&, WEIGHT_T_R(1,TYPE),WEIGHT_B_R(1,TYPE) GDR7F404.235
&, WEIGHT_T_L(1,TYPE),WEIGHT_B_L(1,TYPE),D1_OUT) GDR7F404.236
! GDR7F404.237
! make sure polar rows are constant. GDR7F404.238
! GDR7F404.239
IF(GLOBAL)THEN GDR7F404.240
IF(PPXREF_GRID_TYPE.LE.3)THEN GDR7F404.241
! Horizontal Interpolation has made polar rows non-constant GDR7F404.242
WRITE(6,*) 'Horizontal Interpolation has made polar ', GDR7F404.243
& 'rows non-constant' GDR7F404.244
WRITE(6,*) 'Averaging polar rows to make them ', GDR7F404.245
& 'constant' GDR7F404.246
! GDR7F404.247
! North polar row GDR7F404.248
RP_ROW_SUM=0 GDR7F404.249
DO I=1,ROW_LENGTH_OUT GDR7F404.250
RP_ROW_SUM=RP_ROW_SUM+D1_OUT(POS_D1_OUT+I-1) GDR7F404.251
END DO GDR7F404.252
DO I=1,ROW_LENGTH_OUT GDR7F404.253
D1_OUT(POS_D1_OUT+I-1)=RP_ROW_SUM/ROW_LENGTH_OUT GDR7F404.254
END DO GDR7F404.255
! South polar row GDR7F404.256
RP_ROW_SUM=0 GDR7F404.257
DO I=1,ROW_LENGTH_OUT GDR7F404.258
RP_ROW_SUM= GDR7F404.259
& RP_ROW_SUM+D1_OUT(POS_D1_OUT+ GDR7F404.260
& (P_ROWS_OUT-1)*ROW_LENGTH_OUT+I-1) GDR7F404.261
END DO GDR7F404.262
DO I=1,ROW_LENGTH_OUT GDR7F404.263
D1_OUT(POS_D1_OUT+(P_ROWS_OUT-1)* GDR7F404.264
& ROW_LENGTH_OUT+I-1)=RP_ROW_SUM/ROW_LENGTH_OUT GDR7F404.265
ENDDO GDR7F404.266
ENDIF GDR7F404.267
ENDIF GDR7F404.268
GDR7F404.269
C Correct land-compressed fields along coasts after interpolation as GDR7F404.270
C missing data will have been interpolated from sea pts on source grid. GDR7F404.271
C Also fill in data at unresolved land and sea points on target grid. GDR7F404.272
IF(PP_LS_IN(POS).EQ.1) THEN GDR7F404.273
GDR7F404.274
DO I=1,COASTAL_POINTS GDR7F404.275
D1_OUT(POS_D1_OUT-1+INDEX_OUT(I))=D1_IN(POS_D1_IN-1 GDR7F404.276
& +INDEX_IN(I)) GDR7F404.277
ENDDO GDR7F404.278
GDR7F404.279
IF(LSPIRAL_S)THEN GDR7F404.280
DO I=1,P_FIELD_OUT GDR7F404.281
INDEX_TARG_SEA_X(I)=INDEX_TARG_SEA(I) GDR7F404.282
INDEX_TARG_LAND_X(I)=INDEX_TARG_LAND(I) GDR7F404.283
LAND_SEA_MASK_X(I)=0 GDR7F404.284
IF(LAND_SEA_MASK_OUT(I)) LAND_SEA_MASK_X(I)=1 GDR7F404.285
ENDDO GDR7F404.286
SEA_POINTS_UNRESX=SEA_POINTS_UNRES GDR7F404.287
LAND_POINTS_UNRESX=LAND_POINTS_UNRES GDR7F404.288
GDR7F404.289
C GDR7F404.290
C Call INTF_COAST_AJ to find values for unresolved points GDR7F404.291
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_SEA_X GDR7F404.292
&, SEA_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT, GDR7F404.293
& D1_OUT(POS_D1_OUT),0,CYCLIC,MAXDIM) GDR7F404.294
CALL INTF_COAST_AJ(LAND_SEA_MASK_X,INDEX_TARG_LAND_X GDR7F404.295
&, LAND_POINTS_UNRESX,P_ROWS_OUT,ROW_LENGTH_OUT, GDR7F404.296
& D1_OUT(POS_D1_OUT),1,CYCLIC,MAXDIM) GDR7F404.297
GDR7F404.298
ELSE GDR7F404.299
GDR7F404.300
DO I=1,LAND_POINTS_UNRES GDR7F404.301
D1_OUT(POS_D1_OUT-1+INDEX_TARG_LAND(I)) GDR7F404.302
& =D1_OUT(POS_D1_OUT-1+LAND_UNRES_INDEX(I)) GDR7F404.303
ENDDO GDR7F404.304
DO I=1,SEA_POINTS_UNRES GDR7F404.305
D1_OUT(POS_D1_OUT-1+INDEX_TARG_SEA(I)) GDR7F404.306
& =D1_OUT(POS_D1_OUT-1+SEA_UNRES_INDEX(I)) GDR7F404.307
ENDDO GDR7F404.308
GDR7F404.309
ENDIF GDR7F404.310
ENDIF GDR7F404.311
GDR7F404.312
! Ensure that canopy water content is not negative GDR7F404.313
DO I=1,P_FIELD_OUT GDR7F404.314
IF(D1_OUT(I).LT.0.)D1_OUT(I)=0. GDR7F404.315
ENDDO GDR7F404.316
GDR7F404.317
! interpolate back to land points GDR7F404.318
CALL TO_LAND_POINTS (D1_OUT,D1_OUT, GDR7F404.319
& LAND_SEA_MASK_OUT,P_FIELD_OUT,LAND_POINTS) GDR7F404.320
GDR7F404.321
ELSE ! No horiz interpolation GDR7F404.322
GDR7F404.323
DO I=1,LAND_POINTS GDR7F404.324
D1_OUT(I) = D1_IN(I) GDR7F404.325
ENDDO GDR7F404.326
GDR7F404.327
ENDIF ! end of test on HORIZ GDR7F404.328
GDR7F404.329
! write out canopy water on non-ice tiles to output dump GDR7F404.330
CALL LOCATE (229,PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.331
DO I=1,NTYPE-1 GDR7F404.332
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS)+I-1, GDR7F404.333
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.334
& D1_OUT,LAND_POINTS,FIXHD_OUT, GDR7F404.335
*CALL ARGPPX GDR7F404.336
& ICODE,CMESSAGE) GDR7F404.337
IF (ICODE.GT.0) THEN GDR7F404.338
WRITE (6,*) ' Problem in WRITFLDS - ', GDR7F404.339
& ' Stash Code ',PP_ITEMC_OUT(J), GDR7F404.340
& ' Pseudo level ',I GDR7F404.341
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.342
END IF GDR7F404.343
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.344
& ' Pseudo Level ',I,' initialised', GDR7F404.345
& ' from Gridbox Mean Canopy Water' GDR7F404.346
GDR7F404.347
ENDDO GDR7F404.348
GDR7F404.349
ELSEIF (PP_ITEMC_OUT(J).EQ.231 .AND. ! Snow Grain Size GDR7F404.350
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.351
& L_SNOW_ALBEDO .AND. GDR7F404.352
& PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.353
GDR7F404.354
! S=8 is not set in the UMUI for this field. It is set in GDR7F404.355
! loop 1400 if no field is found in the input dump. GDR7F404.356
GDR7F404.357
WRITE (6,*) ' ' GDR7F404.358
WRITE (6,*) ' No SNOW GRAIN SIZE found in input dump ' GDR7F404.359
WRITE (6,*) ' SNOW GRAIN SIZE being initialised ' GDR7F404.360
GDR7F404.361
DO I= 1,P_FIELD_OUT GDR7F404.362
D1_TEMP(I) = 50.0 GDR7F404.363
END DO GDR7F404.364
GDR7F404.365
CALL LOCATE (231,PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.366
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS), GDR7F404.367
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.368
& D1_TEMP,P_FIELD_OUT,FIXHD_OUT, GDR7F404.369
*CALL ARGPPX GDR7F404.370
& ICODE,CMESSAGE) GDR7F404.371
IF (ICODE.GT.0) THEN GDR7F404.372
WRITE (6,*) ' Problem with writing SNOW GRAIN SIZE field' GDR7F404.373
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.374
END IF GDR7F404.375
WRITE (6,*) ' SNOW GRAIN SIZE (Stash Code 231) has ', GDR7F404.376
& 'been initialised to 50.0' GDR7F404.377
GDR7F404.378
ELSEIF ((PP_ITEMC_OUT(J).EQ.232) .AND. ABX2F405.3
& MODEL.EQ.ATMOS_IM .AND. ABX2F405.4
& (L_TRIFFID.OR.L_VEG_FRACS) .AND. ABX2F405.5
& PP_SOURCE_OUT(J).EQ.8) THEN ABX2F405.6
ABX2F405.7
! S=8 is not set in the UMUI for this field. It is set in ABX2F405.8
! loop 1400 if no field is found in the input dump. ABX2F405.9
ABX2F405.10
WRITE (6,*) ' ' ABX2F405.11
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), ABX2F405.12
& ' - not found in input dump.' ABX2F405.13
ABX2F405.14
! If not present in the input dump, item 232 (snow temperature) is ABX2F405.15
! initialised to item 20 level 1 (temperature of top soil layer). ABX2F405.16
ABX2F405.17
! Find surface temperature in output dump ABX2F405.18
CALL LOCATE (20,PP_ITEMC_OUT,N_TYPES_OUT,POS) ABX2F405.19
IF (POS.EQ.0) THEN ABX2F405.20
WRITE (6,*) ' Soil Layer Temperature not in output dump.' ABX2F405.21
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), ABX2F405.22
& ' cannot be initialised.' ABX2F405.23
CALL ABORT ABX2F405.24
ENDIF ABX2F405.25
ABX2F405.26
! Read in temperature of top soil layer ABX2F405.27
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS), ABX2F405.28
& LOOKUP_OUT,LEN1_LOOKUP_OUT, ABX2F405.29
& D1_TEMP,LAND_POINTS,FIXHD_OUT, ABX2F405.30
*CALL ARGPPX ABX2F405.31
& ICODE,CMESSAGE) ABX2F405.32
IF (ICODE.GT.0) THEN ABX2F405.33
WRITE (6,*) ' Problem in READFLDS for Soil Temp.', ABX2F405.34
& ' Stash Code ',PP_ITEMC_OUT(J) ABX2F405.35
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) ABX2F405.36
END IF ABX2F405.37
ABX2F405.38
! Find position of field in output dump ABX2F405.39
CALL LOCATE (PP_ITEMC_OUT(J),PP_ITEMC_OUT,N_TYPES_OUT,POS) ABX2F405.40
ABX2F405.41
! Write fields to output dump. ABX2F405.42
ABX2F405.43
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS), ABX2F405.44
& LOOKUP_OUT,LEN1_LOOKUP_OUT, ABX2F405.45
& D1_TEMP,LAND_POINTS,FIXHD_OUT, ABX2F405.46
*CALL ARGPPX ABX2F405.47
& ICODE,CMESSAGE) ABX2F405.48
IF (ICODE.GT.0) THEN ABX2F405.49
WRITE (6,*) ' Problem in WRITFLDS - ', ABX2F405.50
& ' Stash Code ',PP_ITEMC_OUT(J) ABX2F405.51
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) ABX2F405.52
END IF ABX2F405.53
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), ABX2F405.54
& ' initialised to top soil layer temperature' ABX2F405.55
ABX2F405.56
ELSEIF ((PP_ITEMC_OUT(J).EQ.233) .AND. ABX2F405.57
& MODEL.EQ.ATMOS_IM .AND. GDR7F404.381
& (L_TRIFFID.OR.L_VEG_FRACS) .AND. GDR7F404.382
& PP_SOURCE_OUT(J).EQ.8) THEN GDR7F404.383
GDR7F404.384
! S=8 is not set in the UMUI for this field. It is set in GDR7F404.385
! loop 1400 if no field is found in the input dump. GDR7F404.386
GDR7F404.387
WRITE (6,*) ' ' GDR7F404.388
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.389
& ' - not found in input dump.' GDR7F404.390
GDR7F404.391
! If not present in the input dump, item 232 (surface temperature on ABX2F405.58
! tiles) is initialised to item 24 (surface temperature). ABX2F405.59
GDR7F404.395
! Find surface temperature in output dump GDR7F404.396
CALL LOCATE (24,PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.397
IF (POS.EQ.0) THEN GDR7F404.398
WRITE (6,*) ' Surface Temperature not in output dump.' GDR7F404.399
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.400
& ' cannot be initialised.' GDR7F404.401
CALL ABORT GDR7F404.402
ENDIF GDR7F404.403
GDR7F404.404
! Read in surface temperature GDR7F404.405
CALL READFLDS (NFTOUT,1,PP_POS_OUT(POS), GDR7F404.406
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.407
& D1_TEMP,P_FIELD_OUT,FIXHD_OUT, GDR7F404.408
*CALL ARGPPX GDR7F404.409
& ICODE,CMESSAGE) GDR7F404.410
IF (ICODE.GT.0) THEN GDR7F404.411
WRITE (6,*) ' Problem in READFLDS for Surface Temp.', GDR7F404.412
& ' Stash Code ',PP_ITEMC_OUT(J) GDR7F404.413
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.414
END IF GDR7F404.415
GDR7F404.416
! Set up field on land points GDR7F404.417
CALL TO_LAND_POINTS(D1_TEMP,D1_TEMP, GDR7F404.418
& LAND_SEA_MASK_OUT,P_FIELD_OUT,LAND_POINTS) GDR7F404.419
GDR7F404.420
! Find position of field in output dump GDR7F404.421
CALL LOCATE (PP_ITEMC_OUT(J),PP_ITEMC_OUT,N_TYPES_OUT,POS) GDR7F404.422
GDR7F404.423
! Set no of pseudo levels ABX2F405.60
N_PSL = NTYPE ABX2F405.61
GDR7F404.427
! Write fields to output dump. GDR7F404.428
DO I=1,N_PSL GDR7F404.429
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS)+I-1, GDR7F404.430
& LOOKUP_OUT,LEN1_LOOKUP_OUT, GDR7F404.431
& D1_TEMP,LAND_POINTS,FIXHD_OUT, GDR7F404.432
*CALL ARGPPX GDR7F404.433
& ICODE,CMESSAGE) GDR7F404.434
IF (ICODE.GT.0) THEN GDR7F404.435
WRITE (6,*) ' Problem in WRITFLDS - ', GDR7F404.436
& ' Stash Code ',PP_ITEMC_OUT(J), GDR7F404.437
& ' Pseudo level ',I GDR7F404.438
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTOUT) GDR7F404.439
END IF GDR7F404.440
WRITE (6,*) ' Prognostic - Stash Code ',PP_ITEMC_OUT(J), GDR7F404.441
& ' Pseudo level ',I, GDR7F404.442
& ' initialised to Surface Temperature' GDR7F404.443
ENDDO GDR7F404.444
UDG7F405.12
ELSEIF ((RadialGridIn.AND..NOT.RadialGridOut).AND. UDG7F405.13
& PP_ITEMC_OUT(J).EQ.90.AND. UDG7F405.14
& PP_SOURCE_OUT(J).EQ.8)THEN UDG7F405.15
UDG7F405.16
! S=8 is not set in the UMUI for this field. It is set in UDG7F405.17
! loop 1400 if no field is found in the input dump. UDG7F405.18
UDG7F405.19
WRITE (6,*) ' ' UDG7F405.20
WRITE (6,*) ' No log aerosol concentration in input dump' UDG7F405.21
WRITE (6,*) ' Log aerosol concentration being initialised.' UDG7F405.22
UDG7F405.23
! Getting level one log aerosol concentration from input dump UDG7F405.24
! Stash code 155 UDG7F405.25
CALL LOCATE (155,PP_ITEMC_IN,N_TYPES_IN,POS) UDG7F405.26
IF (POS.EQ.0) THEN UDG7F405.27
CMESSAGE = UDG7F405.28
& 'CONTROL : Problem initialising log aerosol concentration' UDG7F405.29
WRITE (6,*) ' Log aerosol concentration', UDG7F405.30
& ' not found in input dump.' UDG7F405.31
WRITE (6,*) ' Total aerosol concentration', UDG7F405.32
& ' cannot be initialised' UDG7F405.33
CALL ABORT UDG7F405.34
ELSE UDG7F405.35
CALL READFLDS (NFTIN,1,PP_POS_IN(POS),LOOKUP_IN, UDG7F405.36
& LEN1_LOOKUP_IN,D1_IN,P_FIELD_IN,FIXHD_IN, UDG7F405.37
*CALL ARGPPX UDG7F405.38
& ICODE,CMESSAGE) UDG7F405.39
IF (ICODE.GT.0) THEN UDG7F405.40
WRITE (6,*) ' Problem with reading log aerosol', UDG7F405.41
& ' concentration' UDG7F405.42
CALL ABORT_IO ('CONTROL',CMESSAGE,ICODE,NFTIN) UDG7F405.43
ENDIF UDG7F405.44
ENDIF UDG7F405.45
! do horizontal interpolation: UDG7F405.46
TYPE=1 UDG7F405.47
X_ROWS_IN=P_ROWS_IN UDG7F405.48
X_ROWS_OUT=P_ROWS_OUT UDG7F405.49
X_COLS_IN=ROW_LENGTH_IN UDG7F405.50
X_COLS_OUT=ROW_LENGTH_OUT UDG7F405.51
X_FIELD_IN=P_FIELD_IN UDG7F405.52
X_FIELD_OUT=P_FIELD_OUT UDG7F405.53
CALL H_INT_CTL(IDIM,X_FIELD_OUT,X_COLS_IN,X_COLS_OUT UDG7F405.54
&, X_ROWS_IN,X_ROWS_OUT,AW_AREA_BOX(TYPE) UDG7F405.55
&, GLOBAL,H_INT_TYPE UDG7F405.56
&, AW_INDEX_TARG_LHS(1,TYPE) UDG7F405.57
&, AW_INDEX_TARG_TOP(1,TYPE) UDG7F405.58
&, BL_INDEX_B_L(1,TYPE),BL_INDEX_B_R(1,TYPE) UDG7F405.59
&, AW_COLAT_T(1,TYPE),AW_LONG_L(1,TYPE),D1_IN UDG7F405.60
&, WEIGHT_T_R(1,TYPE),WEIGHT_B_R(1,TYPE) UDG7F405.61
&, WEIGHT_T_L(1,TYPE),WEIGHT_B_L(1,TYPE),D1_OUT) UDG7F405.62
! UDG7F405.63
! make sure polar rows are constant. UDG7F405.64
! UDG7F405.65
IF(GLOBAL)THEN UDG7F405.66
IF(PPXREF_GRID_TYPE.LE.3)THEN UDG7F405.67
! Horizontal Interpolation has made polar rows non-constant UDG7F405.68
write(6,*) 'Horizontal Interpolation has made ', UDG7F405.69
& 'polar rows non-constant' UDG7F405.70
write(6,*) 'Averaging polar rows to make them constant' UDG7F405.71
! UDG7F405.72
! North polar row UDG7F405.73
RP_ROW_SUM=0 UDG7F405.74
DO I=1,ROW_LENGTH_OUT UDG7F405.75
RP_ROW_SUM=RP_ROW_SUM+D1_OUT(I) UDG7F405.76
END DO UDG7F405.77
DO I=1,ROW_LENGTH_OUT UDG7F405.78
D1_OUT(I)=RP_ROW_SUM/ROW_LENGTH_OUT UDG7F405.79
END DO UDG7F405.80
! South polar row UDG7F405.81
RP_ROW_SUM=0 UDG7F405.82
DO I=1,ROW_LENGTH_OUT UDG7F405.83
RP_ROW_SUM= UDG7F405.84
& RP_ROW_SUM+D1_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I) UDG7F405.85
END DO UDG7F405.86
DO I=1,ROW_LENGTH_OUT UDG7F405.87
D1_OUT((P_ROWS_OUT-1)*ROW_LENGTH_OUT+I)= UDG7F405.88
& RP_ROW_SUM/ROW_LENGTH_OUT UDG7F405.89
END DO UDG7F405.90
END IF UDG7F405.91
END IF UDG7F405.92
UDG7F405.93
! Find position of field in output dump UDG7F405.94
CALL LOCATE (PP_ITEMC_OUT(J),PP_ITEMC_OUT,N_TYPES_OUT,POS) UDG7F405.95
UDG7F405.96
! Write out log aerosol concentration increment at level one in UDG7F405.97
! the total aerosol concentration at level one. UDG7F405.98
! This will be converted to total aerosol concentration in PF_inc2UM UDG7F405.99
CALL WRITFLDS (NFTOUT,1,PP_POS_OUT(POS), UDG7F405.100
& LOOKUP_OUT,LEN1_LOOKUP_OUT, UDG7F405.101
& D1_OUT,P_FIELD_OUT,FIXHD_OUT, UDG7F405.102
*CALL ARGPPX UDG7F405.103
& ICODE,CMESSAGE) UDG7F405.104
UDG7F405.105
UDG7F405.106
GDR7F404.445
ENDIF ! PP_ITEMC etc UCB1F402.14
UDR1F400.129
ENDDO ! N_TYPES UCB1F402.15
CONTROL1.1926
C--------------------------------------------------------------------- CONTROL1.1927
C If output grid on rotated grid read in U & V fields from output CONTROL1.1928
C file, rotate winds and then write back to output file. CONTROL1.1929
C--------------------------------------------------------------------- CONTROL1.1930
CONTROL1.1931
IF(ROT_OUT.AND.HORIZ)THEN UDG4F400.5
CONTROL1.1933
! Locate start position of u & v fields on O/P file UIE2F401.90
IF (C_GRID_OUT) THEN UIE2F401.91
CALL LOCATE(153,PP_ITEMC_OUT,N_TYPES_OUT,POSU) UIE2F401.92
CALL LOCATE(154,PP_ITEMC_OUT,N_TYPES_OUT,POSV) UIE2F401.93
ELSE UIE2F401.94
CALL LOCATE(2,PP_ITEMC_OUT,N_TYPES_OUT,POSU) UIE2F401.95
CALL LOCATE(3,PP_ITEMC_OUT,N_TYPES_OUT,POSV) UIE2F401.96
END IF UIE2F401.97
UIE2F401.98
! Find number of levels in O/P dump. UIE2F401.99
N_FIELDS_OUT=PP_NUM_OUT(POSU) UIE2F401.100
UIE2F401.101
! ROTATE dimensions u,v separately to take account of UIE2F401.102
! the extra u row (v unchanged) on the C grid. UIE2F401.103
CALL ROTATE( UIE2F401.104
*CALL ARGPPX UIE2F401.105
& PP_ITEMC_OUT,PP_NUM_OUT,PP_POS_OUT,N_TYPES_OUT, UIE2F401.106
& LOOKUP_OUT,FIXHD_OUT,U_FIELD_OUT,COEFF1,COEFF2, UIE2F401.107
& NFTOUT,1,C_GRID_OUT,C_GRID_IN,N_FIELDS_OUT, UIE2F401.108
& U_ROWS_IN,U_ROWS_OUT,REALHD_OUT, UIE2F404.355
& ROW_LENGTH_OUT,ROW_LENGTH_IN,POSU,POSV) UIE2F401.109
CONTROL1.1936
ENDIF CONTROL1.1937
CONTROL1.1938
C--------------------------------------------------------------- CONTROL1.1939
C Reset QT in stratosphere CONTROL1.1940
C--------------------------------------------------------------- CONTROL1.1941
CONTROL1.1942
IF(STRAT_Q)THEN CONTROL1.1943
CONTROL1.1944
C Calculate exner pressure at output half levels CONTROL1.1945
DO K=1,P_LEVELS_OUT+1 CONTROL1.1946
DO I=1,P_FIELD_OUT CONTROL1.1947
PR_OUT=AKH_OUT(K)+BKH_OUT(K)*PSTAR_OUT(I) CONTROL1.1948
P_EXNER_HALF_TMP(I,K)=(PR_OUT/PREF)**KAPPA GSS9F402.71
ENDDO CONTROL1.1954
ENDDO CONTROL1.1955
CONTROL1.1956
C Read THL into array D1_OUT CONTROL1.1957
CALL LOCATE(5,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1958
CALL READFLDS(NFTOUT,P_LEVELS_OUT,PP_POS_OUT(POS),LOOKUP_OUT, GDG0F401.365
& LEN1_LOOKUP_OUT,D1_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.366
*CALL ARGPPX GDG0F401.367
& ICODE,CMESSAGE) GDG0F401.368
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1961
CONTROL1.1962
C Read QT into array P_HALF_TMP CONTROL1.1963
CALL LOCATE(11,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1964
CALL READFLDS(NFTOUT,Q_LEVELS_OUT,PP_POS_OUT(POS),LOOKUP_OUT, GDG0F401.369
& LEN1_LOOKUP_OUT,P_HALF_TMP,P_FIELD_OUT,FIXHD_OUT, GDG0F401.370
*CALL ARGPPX GDG0F401.371
& ICODE,CMESSAGE) GDG0F401.372
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1967
CONTROL1.1968
C Read in topography CONTROL1.1969
CALL LOCATE(33,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1970
CALL READFLDS(NFTOUT,1,PP_POS_OUT(POS),LOOKUP_OUT,LEN1_LOOKUP_OUT, DR081293.64
& TOPOG_OUT,P_FIELD_OUT,FIXHD_OUT, GDG0F401.373
*CALL ARGPPX GDG0F401.374
& ICODE,CMESSAGE) GDG0F401.375
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1973
CONTROL1.1974
C Reset stratospheric Q(=QT) CONTROL1.1975
NBLP1=BL_LEVELS_OUT+1 CONTROL1.1976
CALL STRATQ( PSTAR_OUT,P_HALF_TMP,D1_OUT,TOPOG_OUT CONTROL1.1977
&,P_EXNER_HALF_TMP CONTROL1.1978
&,DUMMY,DUMMY ! Dummy for QCF and QCL CONTROL1.1979
&,P_LEVELS_OUT,Q_LEVELS_OUT,P_FIELD_OUT CONTROL1.1980
&,LEVDEPC_OUT,LEVDEPC_OUT(P_LEVELS_OUT+1),AKH_OUT,BKH_OUT CONTROL1.1981
&,DUMMY ! Dummy for RHCRIT CONTROL1.1982
&,NBLP1,ICODE,CMESSAGE) CONTROL1.1983
CONTROL1.1984
IF(ICODE.NE.0)THEN CONTROL1.1985
WRITE(6,'('' *ERROR* in CONTROL'')') CONTROL1.1986
WRITE(6,'(''ICODE='',I6)')ICODE CONTROL1.1987
WRITE(6,'(A80)')CMESSAGE CONTROL1.1988
CALL ABORT CONTROL1.1989
ENDIF CONTROL1.1990
CONTROL1.1991
C Write out QT from array P_HALF_TMP CONTROL1.1992
CALL LOCATE(11,PP_ITEMC_OUT,N_TYPES_OUT,POS) CONTROL1.1993
CALL WRITFLDS(NFTOUT,Q_LEVELS_OUT,PP_POS_OUT(POS),LOOKUP_OUT, GDG0F401.376
& LEN1_LOOKUP_OUT,P_HALF_TMP,P_FIELD_OUT,FIXHD_OUT, GDG0F401.377
*CALL ARGPPX GDG0F401.378
& ICODE,CMESSAGE) GDG0F401.379
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTOUT) CONTROL1.1996
CONTROL1.1997
ENDIF CONTROL1.1998
CONTROL1.1999
C--------------------------------------------------------------- CONTROL1.2000
C Read in pre-analysed UARS fields and overwrite output file CONTROL1.2001
C--------------------------------------------------------------- CONTROL1.2002
CONTROL1.2003
IF(UARS)THEN CONTROL1.2004
CONTROL1.2005
CALL AUX_FILE(NFTUARS,NFTOUT,LEN_FIXHD_OUT, UDG7F400.193
& LEN_INTHD_UARS,LEN_REALHD_UARS, UDG7F400.194
& LEN1_LEVDEPC_UARS,LEN2_LEVDEPC_UARS, UDG7F400.195
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_UARS, UDG7F400.196
& LEN_DATA_UARS,FIXHD_OUT,INTHD_OUT, UDG7F400.197
& LEVDEPC_OUT,P_LEVELS_OUT,LEN1_LEVDEPC_OUT, UDG7F400.198
& N_TYPES_OUT,P_FIELD_OUT,LOOKUP_OUT, UDG7F400.199
& PP_POS_OUT,PP_ITEMC_OUT,-1, UDG7F400.200
& ROW_LENGTH_IN,P_ROWS_IN, UDG0F404.132
& ROW_LENGTH_OUT,P_ROWS_OUT,LPOLARCHK, UDG0F404.133
*CALL ARGPPX UDG7F400.201
& IMDI,.FALSE.) UDG7F400.202
CONTROL1.2012
CONTROL1.2013
ENDIF CONTROL1.2014
AD221292.101
C--------------------------------------------------------------- AD221292.102
C Transplant data from another dump file AD221292.103
C--------------------------------------------------------------- AD221292.104
AD221292.105
IF(TRANS)THEN AD221292.106
AD221292.107
WRITE(6,*)'TRANSPLANTING DATA' UDG7F400.203
CALL AUX_FILE(NFTTRANS,NFTOUT,LEN_FIXHD_OUT, UDG7F400.204
& LEN_INTHD_TRANS,LEN_REALHD_TRANS, UDG7F400.205
& LEN1_LEVDEPC_TRANS,LEN2_LEVDEPC_TRANS, UDG7F400.206
& LEN1_LOOKUP_OUT,LEN2_LOOKUP_TRANS, UDG7F400.207
& LEN_DATA_TRANS,FIXHD_OUT,INTHD_OUT, UDG7F400.208
& LEVDEPC_OUT,P_LEVELS_OUT,LEN1_LEVDEPC_OUT, UDG7F400.209
& N_TYPES_OUT,P_FIELD_OUT,LOOKUP_OUT, UDG7F400.210
& PP_POS_OUT,PP_ITEMC_OUT,0, UDG7F400.211
& ROW_LENGTH_IN,P_ROWS_IN, UDG0F404.134
& ROW_LENGTH_OUT,P_ROWS_OUT,LPOLARCHK, UDG0F404.135
*CALL ARGPPX UDG7F400.212
& IMDI,.FALSE.) UDG7F400.213
AD221292.115
AD221292.116
ENDIF AD221292.117
DEALLOCATE (D1_IN,STAT=STATUS) UDG4F405.64
DEALLOCATE (D1_OUT,STAT=STATUS) UDG4F405.65
DEALLOCATE (D1_TMP,STAT=STATUS) UDG4F405.66
DEALLOCATE (D1_TEMP,STAT=STATUS) UDG4F405.67
DEALLOCATE (D1_IN_TMP,STAT=STATUS) UDG4F405.68
DEALLOCATE (P_TMP,STAT=STATUS) UDG4F405.69
DEALLOCATE (PSTAR_OUT,STAT=STATUS) UDG4F405.70
DEALLOCATE (P_OUT,STAT=STATUS) UDG4F405.71
DEALLOCATE (P_HALF_TMP,STAT=STATUS) UDG4F405.72
DEALLOCATE (P_EXNER_HALF_TMP,STAT=STATUS) UDG4F405.73
DEALLOCATE (TOPOG_OUT,STAT=STATUS) UDG4F405.74
DEALLOCATE (TOPOG_OLD,STAT=STATUS) UDG4F405.75
DEALLOCATE (THR_OUT,STAT=STATUS) UDG4F405.76
UDG4F405.77
UDG3F402.775
RETURN UDG3F402.776
END CONTROL1.2021
CONTROL1.2022
*ENDIF CONTROL1.2023