*IF DEF,CONTROL INITHDR1.2
C ******************************COPYRIGHT****************************** GTS2F400.4753
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.4754
C GTS2F400.4755
C Use, duplication or disclosure of this code is subject to the GTS2F400.4756
C restrictions as set forth in the contract. GTS2F400.4757
C GTS2F400.4758
C Meteorological Office GTS2F400.4759
C London Road GTS2F400.4760
C BRACKNELL GTS2F400.4761
C Berkshire UK GTS2F400.4762
C RG12 2SZ GTS2F400.4763
C GTS2F400.4764
C If no contract has been raised with this copy of the code, the use, GTS2F400.4765
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.4766
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.4767
C Modelling at the above address. GTS2F400.4768
C ******************************COPYRIGHT****************************** GTS2F400.4769
C GTS2F400.4770
CLL SUBROUTINE INITHDRS ----------------------------------------------- INITHDR1.3
CLL INITHDR1.4
CLL PURPOSE: Initialises dump LOOKUP headers reserved for diagnostic INITHDR1.5
CLL fields with size and other basic information to allow INITHDR1.6
CLL dump IO routines to work correctly before STASH has INITHDR1.7
CLL updated the addressed fields. INITHDR1.8
CLL INITHDR1.9
CLL programmers of some or all of previous code & changes include: INITHDR1.10
CLL T JOHNS INITHDR1.11
CLL INITHDR1.12
CLL Model Modification history: INITHDR1.13
CLL version Date INITHDR1.14
CLL 3.2 28/07/93 Introduced as new deck to initialise diagnostic INITHDR1.15
CLL LOOKUP headers at the start of an NRUN. INITHDR1.16
CLL 3.3 26/10/93 Correct the routine to set all headers of a MC261093.119
CLL multi-level item. MC261093.120
CLL 3.3 26/10/93 M. Carter. Part of an extensive mod that: MC261093.121
CLL 1.Removes the limit on primary STASH item numbers. MC261093.122
CLL 2.Removes the assumption that (section,item) MC261093.123
CLL defines the sub-model. MC261093.124
CLL 3.Thus allows for user-prognostics. MC261093.125
CLL 3.4 27/07/94 Initialise LOOKUP(lbnrec) to 0 so that IO routines GRR2F304.1
CLL can recognise diagnostic field as belonging GRR2F304.2
CLL in a dump. R. Rawlins GRR2F304.3
CLL 3.4 07/09/94 Bug fix to initialisation of ocean lookup. GJT0F304.1
CLL J Thomson GJT0F304.2
CLL 3.5 May 95 Submodels project. GSS1F305.487
CLL Values of 'idump' now read from STASH list array; GSS1F305.488
CLL reference to INDEX_PPXREF removed. GSS1F305.489
CLL References to PP_XREF array replaced by EXPPXI GSS1F305.490
CLL function calls. GSS1F305.491
CLL Certain *CALLs introduced in conjunction with GSS1F305.492
CLL the above - ARGPPX, CSUBMODL, PPXLOOK. GSS1F305.493
CLL S.J.Swarbrick GSS1F305.494
CLL 4.0 10/10/95 Rationalise use of internal model and submodel GDR7F400.1
CLL partition idents. Set internal model ids in GDR7F400.2
CLL lookups. R. Rawlins GDR7F400.3
CLL 4.1 26/03/96 Introduce Wave sub-model. RTHBarnes. WRB1F401.432
! 4.1 03/04/96 Use DUMP_PACKim to control packing in Dump. GDR2F401.38
! D. Robinson GDR2F401.39
!LL 4.2 27/11/96 MPP code: Correct setting up of LBLREC and GPB1F402.321
!LL NADDR elements of lookup P.Burton GPB1F402.322
!LL 4.4 27/11/96 New option mean timeseries. R A Stratton. GRS1F404.240
! 4.4 25/04/97 Changes to make the addresses well-formed for GBC5F404.142
! Cray I/O. GBC5F404.143
! Author: Bob Carruthers, Cray Research GBC5F404.144
CLL INITHDR1.17
CLL PROGRAMMING STANDARD: UNIFIED MODEL DP NO. 3, VERSION 3 INITHDR1.18
CLL INITHDR1.19
CLL SYSTEM TASK: C4 INITHDR1.20
CLL INITHDR1.21
CLL SYSTEM COMPONENTS: C401 INITHDR1.22
CLL INITHDR1.23
CLL EXTERNAL DOCUMENTATION: UMDP NO. C4 VERSION NO. 8 INITHDR1.24
CLL INITHDR1.25
CLLEND------------------------------------------------------------- INITHDR1.26
INITHDR1.27
SUBROUTINE INITHDRS( 1,9INITHDR1.28
*CALL ARGSIZE 
INITHDR1.29
*CALL ARGDUMA INITHDR1.30
*CALL ARGDUMO INITHDR1.31
*CALL ARGDUMW WRB1F401.433
*CALL ARGSTS INITHDR1.32
*CALL ARGPPX GSS1F305.495
& ICODE,CMESSAGE) INITHDR1.33
INITHDR1.34
IMPLICIT NONE INITHDR1.35
INITHDR1.36
C*L Arguments INITHDR1.37
CL INITHDR1.38
*CALL CSUBMODL GSS1F305.496
*CALL TYPSIZE INITHDR1.39
*CALL TYPDUMA INITHDR1.40
*CALL TYPDUMO INITHDR1.41
*CALL TYPDUMW WRB1F401.434
*CALL TYPSTS ! Contains *CALL CPPXREF GSS1F305.497
INTEGER INITHDR1.43
& ICODE ! OUT: Error return code INITHDR1.44
C INITHDR1.45
CHARACTER*80 CMESSAGE ! OUT: Error return message WRB1F401.435
INITHDR1.48
C PARAMETERs INITHDR1.49
INITHDR1.50
*CALL CHSUNITS GDR2F401.40
*CALL CCONTROL GDR2F401.41
*CALL C_MDI INITHDR1.52
*CALL CLOOKADD INITHDR1.53
*CALL STPARAM INITHDR1.54
GSS1F305.498
! PPXREF lookup arrays GSS1F305.499
GSS1F305.500
*CALL PPXLOOK GSS1F305.501
INITHDR1.55
C Local variables INITHDR1.56
INITHDR1.57
REAL INITHDR1.58
& r_eqv_rmdi INITHDR1.59
INTEGER INITHDR1.60
& i_eqv_rmdi INITHDR1.61
&,disk_address ! Current rounded disk address GBC5F404.145
&,number_of_data_words_on_disk ! Number of data words on disk GBC5F404.146
&,number_of_data_words_in_memory ! Number of Data Words in memory GBC5F404.147
INTEGER INITHDR1.62
& i,ii,is,im,iproc,ilookup,iheaders,ilength,imean,j GDR7F400.4
& ,im_ident ! internal model identifier GDR7F400.5
& ,sm_ident ! submodel partition (dump) identifier GDR7F400.6
& ,N1 ! Packing Indicator for Lookup(21) GDR2F401.42
INITHDR1.64
EQUIVALENCE(r_eqv_rmdi,i_eqv_rmdi) INITHDR1.65
INITHDR1.66
! Function and subroutine calls: GSS1F305.503
INTEGER EXPPXI GSS1F305.504
EXTERNAL EXPPXI GSS1F305.505
GSS1F305.506
CL---------------------------------------------------------------------- INITHDR1.67
CL 1. Set dump LOOKUP headers with basic information needed by INITHDR1.68
CL READDUMP and WRITDUMP, by scanning STASHlist items for INITHDR1.69
CL diagnostics destined for dump addresses. NB: timeseries INITHDR1.70
CL fields cannot be 32-bit packed in dumps as the extra data INITHDR1.71
CL will contain integers. INITHDR1.72
CL INITHDR1.73
r_eqv_rmdi=rmdi INITHDR1.74
C INITHDR1.75
DO II=1,totitems INITHDR1.76
IF (stlist(st_output_code,II).EQ.st_dump) THEN INITHDR1.77
C output is to addressed D1 MC261093.128
MC261093.129
im_ident =stlist(st_model_code,II) ! internal model GDR7F400.7
sm_ident =SUBMODEL_PARTITION_INDEX(im_ident)! submodel GDR7F400.8
GDR7F400.9
is =stlist(st_sect_no_code,II) GSS1F305.508
im =stlist(st_item_code,II) INITHDR1.79
iproc =stlist(st_proc_no_code,II) INITHDR1.81
ilookup=stlist(st_lookup_ptr,II) INITHDR1.82
GSS1F305.509
*IF -DEF,ATMOS INITHDR1.104
IF (sm_ident.EQ.atmos_sm) THEN GDR7F400.10
icode=111 INITHDR1.106
cmessage='INITHDRS : Atmos diagnostic request not possible' INITHDR1.107
GOTO 999 INITHDR1.108
ENDIF INITHDR1.109
*ENDIF MC261093.140
*IF -DEF,OCEAN INITHDR1.130
IF (sm_ident.EQ.ocean_sm) THEN GDR7F400.11
icode=222 INITHDR1.132
cmessage='INITHDRS : Ocean diagnostic request not possible' INITHDR1.133
GOTO 999 INITHDR1.134
ENDIF INITHDR1.135
*ENDIF MC261093.141
*IF -DEF,WAVE WRB1F401.436
IF (sm_ident.EQ.wave_sm) THEN WRB1F401.437
icode=444 WRB1F401.438
cmessage='INITHDRS : Wave diagnostic request not possible' WRB1F401.439
GOTO 999 WRB1F401.440
ENDIF WRB1F401.441
*ENDIF WRB1F401.442
MC261093.142
C Calculate the total number of headers required by this MC261093.143
C stashlist record. MC261093.144
imean=(stlist(st_gridpoint_code,II)/block_size)*block_size MC261093.145
IF (stlist(st_output_bottom,II).EQ.100) THEN MC261093.146
C single level MC261093.147
iheaders=1 MC261093.148
ELSE IF (stlist(st_proc_no_code,II) .EQ. MC261093.149
& st_time_series_code.OR. GRS1F404.241
& stlist(st_proc_no_code,II).eq.st_time_series_mean) THEN GRS1F404.242
C time series MC261093.151
iheaders=1 MC261093.152
ELSE IF (stlist(st_proc_no_code,II) .EQ. MC261093.153
& st_append_traj_code) THEN MC261093.154
C append trajectories MC261093.155
iheaders=1 MC261093.156
ELSE IF (imean.eq.vert_mean_base) THEN MC261093.157
C vertical mean MC261093.158
iheaders=1 MC261093.159
ELSE IF (imean.eq.global_mean_base) THEN MC261093.160
C total 3-D mean MC261093.161
iheaders=1 MC261093.162
ELSE IF (stlist(st_output_bottom,II).LT.0) THEN MC261093.163
C level list, not vertical mean. MC261093.164
iheaders=STASH_LEVELS(1, -stlist(st_output_bottom,II) ) MC261093.165
ELSE MC261093.166
C level range, not vertical mean. MC261093.167
iheaders=stlist(st_output_top,II)- MC261093.168
& stlist(st_output_bottom,II)+1 MC261093.169
END IF MC261093.170
IF(stlist(st_pseudo_out,II).GT.0) THEN !Output pseudo levs MC261093.171
iheaders=iheaders* MC261093.172
* STASH_PSEUDO_LEVELS(1,stlist(st_pseudo_out,II)) MC261093.173
END IF MC261093.174
MC261093.175
*IF -DEF,MPP GPB1F402.323
ilength=stlist(st_output_length,II) / iheaders MC261093.176
*ELSE GPB1F402.324
ilength=stlist(st_dump_output_length,II) / iheaders GPB1F402.325
*ENDIF GPB1F402.326
C Loop down the headers. MC261093.177
DO I=0,iheaders-1 MC261093.178
*IF DEF,ATMOS MC261093.179
IF (sm_ident.EQ.atmos_sm) THEN GDR7F400.12
DO j=1,len1_lookup MC261093.181
a_lookup(j,ilookup+I)=imdi MC261093.182
ENDDO MC261093.183
DO j=46,len1_lookup MC261093.184
a_lookup(j,ilookup+I)=i_eqv_rmdi MC261093.185
ENDDO MC261093.186
a_lookup(lbnrec ,ilookup+I)=0 GRR2F304.4
a_lookup(item_code,ilookup+I)=is*1000+im MC261093.187
a_lookup(model_code,ilookup+I)=im_ident GDR7F400.13
a_lookup(data_type,ilookup+I)= GSS1F305.512
& EXPPXI(im_ident,is,im,ppx_data_type, GDR7F400.14
*CALL ARGPPX GSS1F305.514
& ICODE,CMESSAGE) GSS1F305.515
a_lookup(lblrec,ilookup+I)=ilength MC261093.189
*IF -DEF,MPP GPB1F402.327
a_lookup(naddr ,ilookup+I)=stlist(st_output_addr ,II)+ MC261093.190
& ( ilength * I ) MC261093.191
*ELSE GPB1F402.328
a_lookup(naddr ,ilookup+I)= GPB1F402.329
& stlist(st_dump_output_addr ,II)+( ilength * I ) GPB1F402.330
*ENDIF GPB1F402.331
IF (iproc.EQ.st_time_series_code .OR. MC261093.192
& iproc.EQ.st_time_series_mean .OR. GRS1F404.243
& iproc.EQ.st_append_traj_code) THEN MC261093.193
a_lookup(lbpack,ilookup+I)=2000 MC261093.194
ELSE MC261093.195
a_lookup(lbpack,ilookup+I)=2000+ MC261093.196
& EXPPXI(im_ident,is,im,ppx_dump_packing, GDR7F400.15
*CALL ARGPPX GSS1F305.517
& ICODE,CMESSAGE) GSS1F305.518
IF (DUMP_PACKim(sm_ident).eq.3 ) THEN GDR2F401.43
! Do not pack data ; Override PPXREF packing indicator GDR2F401.44
N1 = 0 ! No packing GDR2F401.45
a_lookup(lbpack,ilookup+I) = GDR2F401.46
& (a_lookup(lbpack,ilookup+I)/10)*10 + N1 GDR2F401.47
ENDIF GDR2F401.48
ENDIF MC261093.198
END IF MC261093.199
*ENDIF MC261093.200
*IF DEF,OCEAN MC261093.201
IF (sm_ident.EQ.ocean_sm) THEN GDR7F400.16
DO j=1,len1_lookup MC261093.203
o_lookup(j,ilookup+I)=imdi GJT0F304.3
ENDDO MC261093.205
DO j=46,len1_lookup MC261093.206
o_lookup(j,ilookup+I)=i_eqv_rmdi GJT0F304.4
ENDDO MC261093.208
o_lookup(lbnrec ,ilookup+I)=0 GRR2F304.5
o_lookup(item_code,ilookup+I)=is*1000+im MC261093.209
o_lookup(model_code,ilookup+I)=im_ident GDR7F400.17
o_lookup(data_type,ilookup+I)= GSS1F305.519
& EXPPXI(im_ident,is,im,ppx_data_type, GDR7F400.18
*CALL ARGPPX GSS1F305.521
& ICODE,CMESSAGE) GSS1F305.522
o_lookup(lblrec,ilookup+I)=ilength MC261093.211
*IF -DEF,MPP GPB1F402.332
o_lookup(naddr ,ilookup+I)=stlist(st_output_addr ,II)+ MC261093.212
& ( ilength * I ) MC261093.213
*ELSE GPB1F402.333
o_lookup(naddr ,ilookup+I)= GPB1F402.334
& stlist(st_dump_output_addr ,II)+( ilength * I ) GPB1F402.335
*ENDIF GPB1F402.336
IF (iproc.EQ.st_time_series_code .OR. MC261093.214
& iproc.EQ.st_time_series_mean .OR. GRS1F404.244
& iproc.EQ.st_append_traj_code) THEN MC261093.215
o_lookup(lbpack,ilookup+I)=2000 MC261093.216
ELSE MC261093.217
o_lookup(lbpack,ilookup+I)=2000+ MC261093.218
& EXPPXI(im_ident,is,im,ppx_dump_packing, GDR7F400.19
*CALL ARGPPX GSS1F305.524
& ICODE,CMESSAGE) GSS1F305.525
IF (DUMP_PACKim(sm_ident).eq.3 ) THEN GDR2F401.49
! Do not pack data ; Override PPXREF packing indicator GDR2F401.50
N1 = 0 ! No packing GDR2F401.51
o_lookup(lbpack,ilookup+I) = GDR2F401.52
& (o_lookup(lbpack,ilookup+I)/10)*10 + N1 GDR2F401.53
ENDIF GDR2F401.54
GSS1F305.526
ENDIF WRB1F401.443
ENDIF WRB1F401.444
*ENDIF WRB1F401.445
*IF DEF,WAVE WRB1F401.446
IF (sm_ident.EQ.wave_sm) THEN WRB1F401.447
DO j=1,len1_lookup WRB1F401.448
w_lookup(j,ilookup+I)=imdi WRB1F401.449
ENDDO WRB1F401.450
DO j=46,len1_lookup WRB1F401.451
w_lookup(j,ilookup+I)=i_eqv_rmdi WRB1F401.452
ENDDO WRB1F401.453
w_lookup(lbnrec ,ilookup+I)=0 WRB1F401.454
w_lookup(item_code,ilookup+I)=is*1000+im WRB1F401.455
w_lookup(model_code,ilookup+I)=im_ident WRB1F401.456
w_lookup(data_type,ilookup+I)= WRB1F401.457
& EXPPXI(im_ident,is,im,ppx_data_type, WRB1F401.458
*CALL ARGPPX WRB1F401.459
& ICODE,CMESSAGE) WRB1F401.460
w_lookup(lblrec,ilookup+I)=ilength WRB1F401.461
*IF -DEF,MPP GPB1F402.337
w_lookup(naddr ,ilookup+I)=stlist(st_output_addr ,II)+ WRB1F401.462
& ( ilength * I ) WRB1F401.463
*ELSE GPB1F402.338
w_lookup(naddr ,ilookup+I)= GPB1F402.339
& stlist(st_dump_output_addr ,II)+( ilength * I ) GPB1F402.340
*ENDIF GPB1F402.341
IF (iproc.EQ.st_time_series_code .OR. WRB1F401.464
& iproc.EQ.st_time_series_mean .OR. GRS1F404.245
& iproc.EQ.st_append_traj_code) THEN WRB1F401.465
w_lookup(lbpack,ilookup+I)=2000 WRB1F401.466
ELSE WRB1F401.467
w_lookup(lbpack,ilookup+I)=2000+ WRB1F401.468
& EXPPXI(im_ident,is,im,ppx_dump_packing, WRB1F401.469
*CALL ARGPPX WRB1F401.470
& ICODE,CMESSAGE) WRB1F401.471
WRB1F401.472
IF (DUMP_PACKim(sm_ident).eq.3 ) THEN WRB1F401.473
! Do not pack data ; Override PPXREF packing indicator WRB1F401.474
N1 = 0 ! No packing WRB1F401.475
w_lookup(lbpack,ilookup+I) = WRB1F401.476
& (w_lookup(lbpack,ilookup+I)/10)*10 + N1 WRB1F401.477
ENDIF WRB1F401.478
ENDIF MC261093.220
ENDIF INITHDR1.153
*ENDIF INITHDR1.155
END DO ! I, Loop over headers for this STASHlist entry MC261093.221
MC261093.222
MC261093.223
ENDIF INITHDR1.156
END DO ! II LOOP OVER TOTITEMS MC261093.224
INITHDR1.158
c GBC5F404.148
c--reset the disk addresses and lengths for well-formed I/O GBC5F404.149
*IF DEF,ATMOS GBC5F404.150
if (sm_ident.eq.atmos_sm) then GBC5F404.151
call set_dumpfile_address(a_fixhd, len_fixhd, GBC5F404.152
& a_lookup, len1_lookup, GBC5F404.153
& a_len2_lookup, GBC5F404.154
& number_of_data_words_in_memory, GBC5F404.155
& number_of_data_words_on_disk, GBC5F404.156
& disk_address) GBC5F404.157
endif GBC5F404.158
*ENDIF GBC5F404.159
*IF DEF,OCEAN GBC5F404.160
if (sm_ident.eq.ocean_sm) then GBC5F404.161
call set_dumpfile_address(o_fixhd, len_fixhd, GBC5F404.162
& o_lookup, len1_lookup, GBC5F404.163
& o_len2_lookup, GBC5F404.164
& number_of_data_words_in_memory, GBC5F404.165
& number_of_data_words_on_disk, GBC5F404.166
& disk_address) GBC5F404.167
endif GBC5F404.168
*ENDIF GBC5F404.169
*IF DEF,WAVE GBC5F404.170
if (sm_ident.eq.wave_sm) then GBC5F404.171
call set_dumpfile_address(w_fixhd, len_fixhd, GBC5F404.172
& w_lookup, len1_lookup, GBC5F404.173
& w_len2_lookup, GBC5F404.174
& number_of_data_words_in_memory, GBC5F404.175
& number_of_data_words_on_disk, GBC5F404.176
& disk_address) GBC5F404.177
endif GBC5F404.178
*ENDIF GBC5F404.179
999 CONTINUE INITHDR1.159
RETURN INITHDR1.160
END INITHDR1.161
INITHDR1.162
*ENDIF INITHDR1.163