*IF DEF,CONTROL,AND,DEF,SLAB INITA2S1.2
C ******************************COPYRIGHT****************************** GTS2F400.4627
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4628
C GTS2F400.4629
C Use, duplication or disclosure of this code is subject to the GTS2F400.4630
C restrictions as set forth in the contract. GTS2F400.4631
C GTS2F400.4632
C Meteorological Office GTS2F400.4633
C London Road GTS2F400.4634
C BRACKNELL GTS2F400.4635
C Berkshire UK GTS2F400.4636
C RG12 2SZ GTS2F400.4637
C GTS2F400.4638
C If no contract has been raised with this copy of the code, the use, GTS2F400.4639
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4640
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4641
C Modelling at the above address. GTS2F400.4642
C ******************************COPYRIGHT****************************** GTS2F400.4643
C GTS2F400.4644
CLL Routine: INIT_A2S ------------------------------------------------- INITA2S1.3
CLL INITA2S1.4
CLL Purpose: Initialises address pointers needed by SLABCNTL INITA2S1.5
CLL when running in coupled mode. Subroutine INITA2S1.6
CLL FINDPTR is used, in this instance searching the STASHlist INITA2S1.7
CLL on section/item codes and STASHmacro tagging information. INITA2S1.8
CLL Also reads in user interface data from namelist INITA2S1.9
CLL INITA2S1.10
CLL Called by: INITIAL INITA2S1.11
CLL INITA2S1.12
CLL Author: A.B.Keen Date: 23 June 1991 INITA2S1.13
CLL Reviewer: W.Ingram Date of review: 01 March 93 INITA2S1.14
CLL INITA2S1.15
CLL Tested under compiler: cft77 INITA2S1.16
CLL Tested under OS version: UNICOS 6.1 INITA2S1.17
CLL INITA2S1.18
CLL Code version no: 1 Date: 23 June 1991 INITA2S1.19
CLL INITA2S1.20
CLL Modification History: INITA2S1.21
CLL 3.2 18/06/93 : Changes for dynamic allocation (TCJ). @DYALLOC.2845
CLL 3.4 18/05/94 : Changes for dynamic sea ice (JFT). GJT1F304.45
CLL 3.5 JUNE 95 Submodels project GSS2F305.134
CLL Added internal model to args of FINDPTR GSS2F305.135
CLL S.J.Swarbrick GSS2F305.136
CLL 3.5 05/06/95 Chgs to SI array. RTHBarnes GRB4F305.270
CLL 4.4 24/11/97 Rewind UNIT 5. D. Robinson. SDR1F404.188
CLL INITA2S1.22
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) INITA2S1.23
CLL INITA2S1.24
CLL Logical components covered: P40 INITA2S1.25
CLL INITA2S1.26
CLL Project task: C0 INITA2S1.27
CLL INITA2S1.28
CLL External documentation: INITA2S1.29
CLL Unified Model Doc Paper C0 - The top-level control system INITA2S1.30
CLL INITA2S1.31
CLL ------------------------------------------------------------------- INITA2S1.32
C*L Interface and arguments: ------------------------------------------ INITA2S1.33
C INITA2S1.34
SUBROUTINE INIT_A2S ( 1,12@DYALLOC.2846
*CALL ARGSIZE 
@DYALLOC.2847
*CALL ARGSTS @DYALLOC.2848
*CALL ARGPTRA @DYALLOC.2849
* ICODE,CMESSAGE ) @DYALLOC.2850
C INITA2S1.36
IMPLICIT NONE INITA2S1.37
C @DYALLOC.2851
*CALL CSUBMODL GSS2F305.137
*CALL TYPSIZE @DYALLOC.2852
*CALL TYPSTS @DYALLOC.2853
*CALL TYPPTRA @DYALLOC.2854
C INITA2S1.38
INTEGER ICODE ! OUT - Error return code INITA2S1.39
CHARACTER*(*) CMESSAGE ! OUT - Error return message INITA2S1.40
C*---------------------------------------------------------------------- INITA2S1.41
C Common blocks INITA2S1.42
C INITA2S1.43
*CALL CASPTR INITA2S1.46
*CALL CSLBDATA INITA2S1.47
*CALL C_MDI INITA2S1.48
C INITA2S1.49
C Subroutines called INITA2S1.50
C INITA2S1.51
EXTERNAL FINDPTR INITA2S1.52
C INITA2S1.53
C Local variables INITA2S1.54
C INITA2S1.55
INTEGER INITA2S1.56
& PROCESS_CODE, ! Processing code INITA2S1.57
& FREQ_CODE, ! Frequency code INITA2S1.58
& START,END,PERIOD, ! Start, end and period step INITA2S1.59
& GRIDPT_CODE,WEIGHT_CODE, ! Gridpt and weighting codes INITA2S1.60
& BOTTOM_LEVEL,TOP_LEVEL, ! Bottom and top input level INITA2S1.61
& GRID_N,GRID_S,GRID_W,GRID_E, ! Grid corner definitions INITA2S1.62
& STASHMACRO_TAG ! STASHmacro tag number INITA2S1.63
& ,IM_IDENT ! internal model identifier GRB4F305.271
& ,IM_INDEX ! internal model index for STASH arrays GRB4F305.272
CL---------------------------------------------------------------------- INITA2S1.64
CL 0. Set grid definition information (undefined as search is on INITA2S1.65
CL STASHmacro tag number) INITA2S1.66
CL INITA2S1.67
PROCESS_CODE=IMDI INITA2S1.68
FREQ_CODE=IMDI INITA2S1.69
START=IMDI INITA2S1.70
END=IMDI INITA2S1.71
PERIOD=IMDI INITA2S1.72
GRIDPT_CODE=IMDI INITA2S1.73
WEIGHT_CODE=IMDI INITA2S1.74
BOTTOM_LEVEL=IMDI INITA2S1.75
TOP_LEVEL=IMDI INITA2S1.76
GRID_N=IMDI INITA2S1.77
GRID_S=IMDI INITA2S1.78
GRID_E=IMDI INITA2S1.79
GRID_W=IMDI INITA2S1.80
GRB4F305.273
C Set up internal model identifier and STASH index GRB4F305.274
im_ident = slab_im GRB4F305.275
im_index = internal_model_index(im_ident) GRB4F305.276
C INITA2S1.81
CL---------------------------------------------------------------------- INITA2S1.82
CL 1. Read in user interface data from namelist INITA2S1.83
CL INITA2S1.84
CL INITA2S1.85
REWIND 5 SDR1F404.189
READ(5,SLABLIST) INITA2S1.86
CL INITA2S1.87
CL---------------------------------------------------------------------- INITA2S1.88
CL 2. Get address for each field from its STASH section/item code INITA2S1.89
CL and STASHmacro tag if a diagnostic, or from its primary pointer INITA2S1.90
CL if prognostic or ancillary field INITA2S1.91
CL INITA2S1.92
STASHMACRO_TAG=20 INITA2S1.93
INITA2S1.94
C INITA2S1.95
C INITA2S1.96
CL 2.1 Net downward shortwave flux at surface (SOLARIN) INITA2S1.97
CL (water fraction of sea points) INITA2S1.98
CALL FINDPTR(ATMOS_IM, 1,203, GSS2F305.138
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.100
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.101
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.102
& STASHMACRO_TAG,IMDI,JS_SOLARIN, @DYALLOC.2855
*CALL ARGSIZE @DYALLOC.2856
*CALL ARGSTS @DYALLOC.2857
& ICODE,CMESSAGE) @DYALLOC.2858
IF (JS_SOLARIN.EQ.0) THEN INITA2S1.106
ICODE=3219 INITA2S1.107
CMESSAGE="INIT_A2S: Coupling field not enabled - SOLARIN" INITA2S1.108
ENDIF INITA2S1.109
IF (ICODE.GT.0) GOTO 999 INITA2S1.110
C INITA2S1.111
CL 2.1a Net downward shortwave flux at surface Band 1 only (BLUEIN) GJT1F304.46
CL (water fraction of sea points) GJT1F304.47
CALL FINDPTR(ATMOS_IM, 1,204, GSS2F305.139
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, GJT1F304.49
& GRIDPT_CODE,WEIGHT_CODE, GJT1F304.50
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, GJT1F304.51
& STASHMACRO_TAG,IMDI,JS_BLUEIN, GJT1F304.52
*CALL ARGSIZE GJT1F304.53
*CALL ARGSTS GJT1F304.54
& ICODE,CMESSAGE) GJT1F304.55
IF (JS_BLUEIN.EQ.0) THEN GJT1F304.56
ICODE=1204 GJT1F304.57
CMESSAGE="INIT_A2S: Coupling field not enabled - BLUEIN" GJT1F304.58
ENDIF GJT1F304.59
IF (ICODE.GT.0) GOTO 999 GJT1F304.60
C GJT1F304.61
CL 2.2 Net downward longwave flux at surface (LONGWAVE) INITA2S1.112
CL (water fraction of sea points) INITA2S1.113
CALL FINDPTR(ATMOS_IM, 2,203, GSS2F305.140
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.115
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.116
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.117
& STASHMACRO_TAG,IMDI,JS_LONGWAVE, @DYALLOC.2859
*CALL ARGSIZE @DYALLOC.2860
*CALL ARGSTS @DYALLOC.2861
& ICODE,CMESSAGE) @DYALLOC.2862
IF (JS_LONGWAVE.EQ.0) THEN INITA2S1.121
ICODE=3219 INITA2S1.122
CMESSAGE="INIT_A2S: Coupling field not enabled - LONGWAVE" INITA2S1.123
ENDIF INITA2S1.124
IF (ICODE.GT.0) GOTO 999 INITA2S1.125
C INITA2S1.126
C INITA2S1.127
CL 2.4 Sensible heat flux (water fraction of sea points) (SENSIBLE) INITA2S1.128
CALL FINDPTR(ATMOS_IM, 3,228, GSS2F305.141
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.130
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.131
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.132
& STASHMACRO_TAG,IMDI,JS_SENSIBLE, @DYALLOC.2863
*CALL ARGSIZE @DYALLOC.2864
*CALL ARGSTS @DYALLOC.2865
& ICODE,CMESSAGE) @DYALLOC.2866
IF (JS_SENSIBLE.EQ.0) THEN INITA2S1.136
ICODE=3219 INITA2S1.137
CMESSAGE="INIT_A2S: Coupling field not enabled - SENSIBLE" INITA2S1.138
ENDIF INITA2S1.139
IF (ICODE.GT.0) GOTO 999 INITA2S1.140
C INITA2S1.141
CL 2.5 Surface evaporation from water fraction of sea points (EVAP) INITA2S1.142
CALL FINDPTR(ATMOS_IM, 3,232, GSS2F305.142
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.144
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.145
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.146
& STASHMACRO_TAG,IMDI,JS_EVAP, @DYALLOC.2867
*CALL ARGSIZE @DYALLOC.2868
*CALL ARGSTS @DYALLOC.2869
& ICODE,CMESSAGE) @DYALLOC.2870
IF (JS_EVAP.EQ.0) THEN INITA2S1.150
ICODE=3219 INITA2S1.151
CMESSAGE="INIT_A2S: Coupling field not enabled - EVAP" INITA2S1.152
ENDIF INITA2S1.153
IF (ICODE.GT.0) GOTO 999 INITA2S1.154
C INITA2S1.155
CL 2.6 Large scale snowfall rate (SNOWLS) INITA2S1.156
CALL FINDPTR(ATMOS_IM, 4,204, GSS2F305.143
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.158
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.159
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.160
& STASHMACRO_TAG,IMDI,JS_SNOWLS, @DYALLOC.2871
*CALL ARGSIZE @DYALLOC.2872
*CALL ARGSTS @DYALLOC.2873
& ICODE,CMESSAGE) @DYALLOC.2874
IF (JS_SNOWLS.EQ.0) THEN INITA2S1.164
ICODE=3219 INITA2S1.165
CMESSAGE="INIT_A2S: Coupling field not enabled - SNOWLS" INITA2S1.166
ENDIF INITA2S1.167
IF (ICODE.GT.0) GOTO 999 INITA2S1.168
C INITA2S1.169
CL 2.7 Convective snowfall rate (SNOWCONV) INITA2S1.170
CALL FINDPTR(ATMOS_IM, 5,206, GSS2F305.144
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.172
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.173
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.174
& STASHMACRO_TAG,IMDI,JS_SNOWCONV, @DYALLOC.2875
*CALL ARGSIZE @DYALLOC.2876
*CALL ARGSTS @DYALLOC.2877
& ICODE,CMESSAGE) @DYALLOC.2878
IF (JS_SNOWCONV.EQ.0) THEN INITA2S1.178
ICODE=3219 INITA2S1.179
CMESSAGE="INIT_A2S: Coupling field not enabled - SNOWCONV" INITA2S1.180
ENDIF INITA2S1.181
IF (ICODE.GT.0) GOTO 999 INITA2S1.182
C INITA2S1.183
CL 2.8 Heat convergence rate (HEATCONV) INITA2S1.184
C This is an ancilary field, so use SI rather than FINDPTR INITA2S1.185
C INITA2S1.186
JS_HEATCONV = SI(177,0,im_index) GRB4F305.277
C INITA2S1.188
IF (JS_HEATCONV.EQ.0) THEN INITA2S1.189
ICODE=3219 INITA2S1.190
CMESSAGE="INIT_A2S: Coupling field not enabled - HEATCONV" INITA2S1.191
ENDIF INITA2S1.192
IF (ICODE.GT.0) GOTO 999 INITA2S1.193
C INITA2S1.194
CL 2.9 Sublimation (SUBLIMZ) INITA2S1.195
CALL FINDPTR(ATMOS_IM, 3,231, GSS2F305.145
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.197
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.198
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.199
& STASHMACRO_TAG,IMDI,JS_SUBLIMZ, @DYALLOC.2879
*CALL ARGSIZE @DYALLOC.2880
*CALL ARGSTS @DYALLOC.2881
& ICODE,CMESSAGE) @DYALLOC.2882
IF (JS_SUBLIMZ.EQ.0) THEN INITA2S1.203
ICODE=3219 INITA2S1.204
CMESSAGE="INIT_A2S: Coupling field not enabled - SUBLIMZ" INITA2S1.205
ENDIF INITA2S1.206
IF (ICODE.GT.0) GOTO 999 INITA2S1.207
C INITA2S1.208
CL 2.10 Rate of melting of snow (TOPMELTZ) INITA2S1.209
CALL FINDPTR(ATMOS_IM, 3,235, GSS2F305.146
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.211
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.212
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.213
& STASHMACRO_TAG,IMDI,JS_TOPMELTZ, @DYALLOC.2883
*CALL ARGSIZE @DYALLOC.2884
*CALL ARGSTS @DYALLOC.2885
& ICODE,CMESSAGE) @DYALLOC.2886
IF (JS_TOPMELTZ.EQ.0) THEN INITA2S1.217
ICODE=3219 INITA2S1.218
CMESSAGE="INIT_A2S: Coupling field not enabled - TOPMELTZ" INITA2S1.219
ENDIF INITA2S1.220
IF (ICODE.GT.0) GOTO 999 INITA2S1.221
C INITA2S1.222
CL 2.11 Diffusive heat through ice (BOTMELTZ) INITA2S1.223
CALL FINDPTR(ATMOS_IM, 3,201, GSS2F305.147
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, INITA2S1.225
& GRIDPT_CODE,WEIGHT_CODE, INITA2S1.226
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, INITA2S1.227
& STASHMACRO_TAG,IMDI,JS_BOTMELTZ, @DYALLOC.2887
*CALL ARGSIZE @DYALLOC.2888
*CALL ARGSTS @DYALLOC.2889
& ICODE,CMESSAGE) @DYALLOC.2890
IF (JS_BOTMELTZ.EQ.0) THEN INITA2S1.231
ICODE=3219 INITA2S1.232
CMESSAGE="INIT_A2S: Coupling field not enabled - BOTMELTZ" INITA2S1.233
ENDIF GJT1F304.62
IF (ICODE.GT.0) GOTO 999 GJT1F304.63
C GJT1F304.64
CL 2.12 Zonal surface current (U0) GJT1F304.65
JS_USEA = JU_SEA GJT1F304.66
IF (JS_USEA.EQ.0) THEN GJT1F304.67
ICODE=28 GJT1F304.68
CMESSAGE="INIT_A2S: Ancillary field not present - USEA" GJT1F304.69
ENDIF GJT1F304.70
IF (ICODE.GT.0) GOTO 999 GJT1F304.71
C GJT1F304.72
CL 2.13 Meridional surface current (V0) GJT1F304.73
JS_VSEA = JV_SEA GJT1F304.74
IF (JS_VSEA.EQ.0) THEN GJT1F304.75
ICODE=29 GJT1F304.76
CMESSAGE="INIT_A2S: Ancillary field not present - VSEA" GJT1F304.77
ENDIF GJT1F304.78
IF (ICODE.GT.0) GOTO 999 GJT1F304.79
C GJT1F304.80
CL 2.14 Zonal component of surface wind stress GJT1F304.81
CALL FINDPTR(ATMOS_IM, 3,219, GSS2F305.148
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, GJT1F304.83
& GRIDPT_CODE,WEIGHT_CODE, GJT1F304.84
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, GJT1F304.85
& STASHMACRO_TAG,IMDI,JS_WSX, GJT1F304.86
*CALL ARGSIZE GJT1F304.87
*CALL ARGSTS GJT1F304.88
& ICODE,CMESSAGE) GJT1F304.89
IF (JS_WSX.EQ.0) THEN GJT1F304.90
ICODE=3219 GJT1F304.91
CMESSAGE="INIT_A2S: Coupling field not enabled - WSX" GJT1F304.92
ENDIF GJT1F304.93
IF (ICODE.GT.0) GOTO 999 GJT1F304.94
C GJT1F304.95
CL 2.15 Meridional component of surface wind stress GJT1F304.96
CALL FINDPTR(ATMOS_IM, 3,220, GSS2F305.149
& PROCESS_CODE,FREQ_CODE,START,END,PERIOD, GJT1F304.98
& GRIDPT_CODE,WEIGHT_CODE, GJT1F304.99
& BOTTOM_LEVEL,TOP_LEVEL,GRID_N,GRID_S,GRID_W,GRID_E, GJT1F304.100
& STASHMACRO_TAG,IMDI,JS_WSY, GJT1F304.101
*CALL ARGSIZE GJT1F304.102
*CALL ARGSTS GJT1F304.103
& ICODE,CMESSAGE) GJT1F304.104
IF (JS_WSY.EQ.0) THEN GJT1F304.105
ICODE=3220 GJT1F304.106
CMESSAGE="INIT_A2S: Coupling field not enabled - WSY" GJT1F304.107
ENDIF INITA2S1.234
IF (ICODE.GT.0) GOTO 999 INITA2S1.235
C INITA2S1.236
C INITA2S1.237
CL---------------------------------------------------------------------- INITA2S1.238
C INITA2S1.239
999 CONTINUE INITA2S1.240
RETURN INITA2S1.241
END INITA2S1.242
*ENDIF INITA2S1.243