SUBROUTINE UM_WRITDUMP(NFTOUT,FIXHD,LEN_FIXHD, 4,21GPB4F403.754
& INTHD,LEN_INTHD, GDG0F401.1598
& REALHD,LEN_REALHD, GDG0F401.1599
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.1600
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.1601
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.1602
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.1603
& EXTCNST,LEN_EXTCNST, GDG0F401.1604
& DUMPHIST,LEN_DUMPHIST, GDG0F401.1605
& CFI1,LEN_CFI1, GDG0F401.1606
& CFI2,LEN_CFI2, GDG0F401.1607
& CFI3,LEN_CFI3, GDG0F401.1608
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP, GSM1F403.252
*IF DEF,MPP GSM1F403.253
& MPP_LOOKUP,MPP_LEN1_LOOKUP, GSM1F403.254
*ENDIF GSM1F403.255
& BUFLEN, GSM1F403.256
& SUBMODEL_ID, GPB4F403.755
& N_OBJS_D1,D1_ADDR, GPB4F403.756
& LEN_DATA,D1, GDG0F401.1610
*CALL ARGPPX 
GDG0F401.1611
& ICODE,CMESSAGE) GDG0F401.1612
WRITDM1A.40
IMPLICIT NONE WRITDM1A.41
WRITDM1A.42
INTEGER WRITDM1A.43
* NFTOUT !IN Unit no of dump WRITDM1A.44
*,LEN_FIXHD !IN Length of fixed length header WRITDM1A.45
*,LEN_INTHD !IN Length of integer header WRITDM1A.46
*,LEN_REALHD !IN Length of real header WRITDM1A.47
*,LEN1_LEVDEPC !IN 1st dim of level dep consts WRITDM1A.48
*,LEN2_LEVDEPC !IN 2ndt dim of level dep consts WRITDM1A.49
*,LEN1_ROWDEPC !IN 1st dim of row dep consts WRITDM1A.50
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts WRITDM1A.51
&,LEN1_COLDEPC !IN 1st dim of column dep consts WRITDM1A.52
&,LEN2_COLDEPC !IN 2nd dim of column dep consts WRITDM1A.53
&,LEN1_FLDDEPC !IN 1st dim of field dep consts WRITDM1A.54
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts WRITDM1A.55
&,LEN_EXTCNST !IN Length of extra constants WRITDM1A.56
&,LEN_DUMPHIST !IN Length of history block WRITDM1A.57
&,LEN_CFI1 !IN Length of comp field index 1 WRITDM1A.58
&,LEN_CFI2 !IN Length of comp field index 2 WRITDM1A.59
&,LEN_CFI3 !IN Length of comp field index 3 WRITDM1A.60
&,LEN1_LOOKUP !IN 1st dim of lookup WRITDM1A.61
&,LEN2_LOOKUP !IN 2nd dim of lookup WRITDM1A.62
*IF DEF,MPP GSM1F403.257
&,MPP_LEN1_LOOKUP !IN 1st dim of MPP lookup GSM1F403.258
*ENDIF GSM1F403.259
WRITDM1A.63
&,SUBMODEL_ID !IN submodel of dump GPB4F403.757
&,N_OBJS_D1 !IN number of objects (3D fields) in D1 GPB4F403.758
GPB4F403.759
! Parameters required for dimensioning the D1_ADDR array GPB4F403.760
*CALL D1_ADDR GPB4F403.761
GPB4F403.762
INTEGER GPB4F403.763
& D1_ADDR(D1_LIST_LEN,N_OBJS_D1) ! IN D1 addressing info GPB4F403.764
INTEGER WRITDM1A.64
* BUFLEN !IN Maximum length of single field in dump WRITDM1A.65
*,LEN_DATA !IN Length of real data WRITDM1A.66
*,ICODE !OUT Return code; successful=0 WRITDM1A.67
* ! error > 0 WRITDM1A.68
WRITDM1A.69
CHARACTER*(80) TS150793.212
* CMESSAGE !OUT Error message if ICODE > 0 WRITDM1A.71
WRITDM1A.72
INTEGER WRITDM1A.73
* FIXHD(LEN_FIXHD) !IN Fixed length header WRITDM1A.74
*,INTHD(LEN_INTHD) !IN Integer header WRITDM1A.75
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables WRITDM1A.76
*IF DEF,MPP GSM1F403.260
C Local addressing of D1 GSM1F403.261
*,MPP_LOOKUP(MPP_LEN1_LOOKUP,LEN2_LOOKUP) ! OUT GSM1F403.262
*ENDIF GSM1F403.263
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 WRITDM1A.77
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 WRITDM1A.78
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 WRITDM1A.79
WRITDM1A.80
REAL WRITDM1A.81
& REALHD(LEN_REALHD) !IN Real header WRITDM1A.82
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts WRITDM1A.83
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts WRITDM1A.84
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts WRITDM1A.85
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts WRITDM1A.86
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants WRITDM1A.87
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block WRITDM1A.88
*,D1(LEN_DATA) !IN Real equivalence of data block WRITDM1A.89
WRITDM1A.90
*CALL CSUBMODL GDG0F401.1613
*CALL C_MDI GBC5F404.449
*CALL AMAXSIZE GBC5F404.450
*CALL CNTL_IO GBC5F404.451
*CALL CPPXREF GDG0F401.1614
*CALL PPXLOOK GDG0F401.1615
*CALL CLOOKADD WRITDM1A.91
*IF DEF,MPP GPB0F305.386
*CALL DECOMPTP GPB4F403.765
*CALL PARVARS GPB0F305.387
*ENDIF GPB0F305.388
WRITDM1A.92
C ------------------------------------------------------------- WRITDM1A.93
C Local arrays:------------------------------------------------ WRITDM1A.94
real buf(((buflen+um_sector_size)/um_sector_size)*um_sector_size) GBC5F404.452
cdir$ cache_align buf GBC5F404.453
C ------------------------------------------------------------- WRITDM1A.96
C*L External subroutines called:------------------------------- WRITDM1A.97
EXTERNAL IOERROR,POSERROR,WRITHEAD,PR_LOOK,PR_IFLD,PR_RFLD WRITDM1A.98
*,PACK21,EXPAND21,BUFFOUT,P21BITS,PR_LFLD DR221193.223
INTEGER P21BITS WRITDM1A.100
C Cray specific functions UNIT,LENGTH WRITDM1A.101
C*------------------------------------------------------------- WRITDM1A.102
C Local variables:--------------------------------------------- WRITDM1A.103
INTEGER START_BLOCK ! Pointer to current position in file WRITDM1A.104
*,LEN_IO ! No of 64-bit words buffered in WRITDM1A.105
*,K,I ! Loop counts WRITDM1A.106
*,IPTS ! No of 64-bit words requested to be WRITDM1A.107
* ! buffered in WRITDM1A.108
*IF DEF,MPP GPB0F305.389
&, orig_decomp ! original decomposition type GPB4F403.766
&, local_len ! length of local field from buffout GPB0F305.390
&, address ! address of field in local D1 array GPB0F305.391
*ENDIF GPB0F305.392
&, word_address ! disk address of the record GBC5F404.454
&, real_start_block ! real start address and number of words moved GBC5F404.455
&, l_ipts ! record length during index search GBC5F404.456
&, um_sector_ipts ! number fo words to write, rounded up GBC5F404.457
&, ipts_write ! number of words actually write from disk GBC5F404.458
&, disk_address ! Current rounded disk address GBC5F404.459
&, number_of_data_words_on_disk ! Number of data words on disk GBC5F404.460
&, number_of_data_words_in_memory ! Number of Data Words in memory GBC5F404.461
INTEGER GPB4F403.767
& object_index, ! pointer to entry in D1_ADDR GPB4F403.768
& level ! level number of multi-level field GPB4F403.769
REAL A ! Error code returned by UNIT WRITDM1A.109
C-------------------------------------------------------------- WRITDM1A.110
WRITDM1A.111
*IF DEF,MPP GPB0F305.393
IF (mype .EQ. 0) THEN GPB0F305.394
*ENDIF GPB0F305.395
WRITE(6,'(/,'' WRITING UNIFIED MODEL DUMP ON UNIT'',I3)')NFTOUT WRITDM1A.112
WRITE(6,'('' #####################################'',/)') WRITDM1A.113
*IF DEF,MPP GPB0F305.396
ENDIF GPB0F305.397
*ENDIF GPB0F305.398
ICODE=0 WRITDM1A.114
CMESSAGE=' ' WRITDM1A.115
*IF DEF,MPP GPB4F403.770
! Select the relevant decomposition type for this dump GPB4F403.771
GPB4F403.772
orig_decomp=current_decomp_type GPB4F403.773
GPB4F403.774
IF (SUBMODEL_ID .EQ. A_IM) THEN GPB4F403.775
IF (current_decomp_type .NE. decomp_standard_atmos) GPB4F403.776
& CALL CHANGE_DECOMPOSITION(decomp_standard_atmos,ICODE) GPB4F403.777
GPB4F403.778
ELSEIF (SUBMODEL_ID .EQ. O_IM) THEN GPB4F403.779
IF (current_decomp_type .NE. decomp_standard_ocean) GPB4F403.780
& CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB4F403.781
GPB4F403.782
ELSE ! unsupported decomposition type GPB4F403.783
WRITE(6,*) 'WRITEDUMP : Error - Only atmosphere and ocean ', GPB1F404.105
& 'submodels are currently supported for MPP code.' GPB4F403.785
ICODE=1 GPB4F403.786
CMESSAGE='Unsupported submodel for MPP code' GPB4F403.787
RETURN GPB4F403.788
ENDIF GPB4F403.789
GPB4F403.790
IF (ICODE .NE. 0) THEN GPB4F403.791
WRITE(6,*) 'READDUMP : Error - Could not set decomposition ', GPB4F403.792
& 'for selected submodel.' GPB4F403.793
CMESSAGE='Unsupported decomposition selected for MPP code' GPB4F403.794
RETURN GPB4F403.795
ENDIF GPB4F403.796
*ENDIF GPB4F403.797
WRITDM1A.116
c--reset the disk addresses and lengths for well-formed I/O GBC5F404.462
call set_dumpfile_address(fixhd, len_fixhd, GBC5F404.463
& lookup, len1_lookup, GBC5F404.464
& len2_lookup, GBC5F404.465
& number_of_data_words_in_memory, GBC5F404.466
& number_of_data_words_on_disk, GBC5F404.467
& disk_address) GBC5F404.468
CL 1. Read in all header records and check for consistency WRITDM1A.117
C START_BLOCK points to position of model data block WRITDM1A.118
C on return WRITDM1A.119
WRITDM1A.120
CALL WRITHEAD(NFTOUT,FIXHD,LEN_FIXHD, GDG0F401.1616
& INTHD,LEN_INTHD, GDG0F401.1617
& REALHD,LEN_REALHD, GDG0F401.1618
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GDG0F401.1619
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GDG0F401.1620
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GDG0F401.1621
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GDG0F401.1622
& EXTCNST,LEN_EXTCNST, GDG0F401.1623
& DUMPHIST,LEN_DUMPHIST, GDG0F401.1624
& CFI1,LEN_CFI1, GDG0F401.1625
& CFI2,LEN_CFI2, GDG0F401.1626
& CFI3,LEN_CFI3, GDG0F401.1627
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GDG0F401.1628
*CALL ARGPPX GDG0F401.1629
& START_BLOCK,ICODE,CMESSAGE) GDG0F401.1630
WRITDM1A.136
IF(ICODE.GT.0)RETURN WRITDM1A.137
WRITDM1A.138
CL 2. Buffer in model data one field at a time for WRITDM1A.139
CL conversion from 64-bit to 32-bit numbers WRITDM1A.140
WRITDM1A.141
IF(FIXHD(160).GT.0)THEN WRITDM1A.142
WRITDM1A.143
C Check for error in file pointers WRITDM1A.144
real_start_block=start_block GBC5F404.469
if(start_block.ne.fixhd(160)) then GBC5F404.470
C If new format Dumpfile, we must reset the start address GBC5F404.471
if((lookup(lbnrec,1).eq.0) .or. GBC5F404.472
2 ((lookup(lbnrec,1).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.473
CMESSAGE='WRITDUMP: Addressing conflict' WRITDM1A.146
ICODE=1 WRITDM1A.147
CALL POSERROR('model data', WRITDM1A.148
* START_BLOCK,160,FIXHD(160)) WRITDM1A.149
RETURN WRITDM1A.150
else GBC5F404.474
real_start_block=fixhd(160) GBC5F404.475
endif GBC5F404.476
ENDIF WRITDM1A.151
WRITDM1A.152
C Loop over number of fields in data blocks WRITDM1A.153
*IF DEF,MPP GPB0F305.399
address=1 GPB0F305.400
*ENDIF GPB0F305.401
object_index=1 GPB4F403.798
level=1 GPB4F403.799
DO 200 K=1,FIXHD(152) WRITDM1A.154
*IF DEF,MPP GSM1F403.264
MPP_LOOKUP(P_LBLREC,K)=0 GSM1F403.265
MPP_LOOKUP(P_NADDR,K)=address GSM1F403.266
*ENDIF GSM1F403.267
IF (LOOKUP(LBLREC,K) .GT. 0) THEN ! if this isnt a zero GPB0F401.750
! ! length field GPB0F401.751
C Is the buffer length long enough for this field. TJ300394.107
IF(LOOKUP(LBLREC,K).GT.BUFLEN) THEN TJ300394.108
ICODE=100 TJ300394.109
CMESSAGE='WRITDUMP : Field length longer than buffer' TJ300394.110
WRITE(6,*) 'WRITDUMP :Field length longer than buffer, abort', TJ300394.111
& LOOKUP(LBLREC,K),'>',BUFLEN TJ300394.112
RETURN TJ300394.113
END IF TJ300394.114
*IF -DEF,MPP GPB0F305.402
C Pack if required WRITDM1A.155
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN WRITDM1A.156
C Pack 32 bit numbers WRITDM1A.157
IF(LOOKUP(DATA_TYPE,K).EQ.1) THEN WRITDM1A.158
CALL PACK21(LOOKUP(LBLREC,K),D1(LOOKUP(NADDR,K)), WRITDM1A.159
& BUF(1),P21BITS(FIXHD(12))) TJ190293.11
C Expand back to ensure reproducibility across a restart WRITDM1A.161
CALL EXPAND21(LOOKUP(LBLREC,K),BUF(1), WRITDM1A.162
& D1(LOOKUP(NADDR,K)),P21BITS(FIXHD(12))) TJ190293.12
END IF WRITDM1A.164
C Copy across if already in 64 bit WRITDM1A.165
ELSE WRITDM1A.166
DO 110 I=1,LOOKUP(LBLREC,K) WRITDM1A.167
BUF(I)=D1(LOOKUP(NADDR,K)+I-1) WRITDM1A.168
110 CONTINUE WRITDM1A.169
END IF WRITDM1A.170
*ELSE GPB0F305.403
! Data packing to 32 bits is moved down to write_multi. We only want GPB0F305.404
! to compress data after the global data has been gathered GPB0F305.405
*ENDIF GPB0F305.406
WRITDM1A.171
C Test whether data stored as 32-bit on disk WRITDM1A.172
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN WRITDM1A.173
IPTS=(LOOKUP(LBLREC,K)+1)/2 WRITDM1A.174
ELSE WRITDM1A.175
IPTS=LOOKUP(LBLREC,K) WRITDM1A.176
ENDIF WRITDM1A.177
GBC5F404.477
CL Compute word address in file from which to begin I/O GBC5F404.478
GBC5F404.479
C Old Format dumpfiles GBC5F404.480
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.481
C Prog lookups in dump before vn3.2: GBC5F404.482
2 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.483
C Dump and ancillary files GBC5F404.484
word_address=1 GBC5F404.485
if(k.gt.1) then GBC5F404.486
do i=2, k GBC5F404.487
if(mod(lookup(lbpack,i-1),10).eq.2) then GBC5F404.488
l_ipts=(lookup(lblrec,i-1)+1)/2 GBC5F404.489
else GBC5F404.490
l_ipts=(lookup(lblrec,i-1)) GBC5F404.491
endif GBC5F404.492
word_address=word_address+l_ipts GBC5F404.493
end do GBC5F404.494
endif GBC5F404.495
word_address=fixhd(160)+word_address-2 GBC5F404.496
um_sector_ipts=ipts GBC5F404.497
else ! fieldsfiles GBC5F404.498
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.499
word_address=lookup(lbegin,k) GBC5F404.500
C Use the stored round-up value GBC5F404.501
um_sector_ipts=lookup(lbnrec,k) GBC5F404.502
endif GBC5F404.503
GBC5F404.504
ipts_write=ipts GBC5F404.505
GBC5F404.506
C Position file pointer GBC5F404.507
call setpos(nftout, word_address, icode) GBC5F404.508
GBC5F404.509
WRITDM1A.178
C Write data out from buffer WRITDM1A.179
C Check that data_type is valid no: 1 to 3 or -1 to -3 WRITDM1A.180
IF((LOOKUP(DATA_TYPE,K).GE.1.AND.LOOKUP(DATA_TYPE,K).LE.3) .OR. WRITDM1A.181
+ (LOOKUP(DATA_TYPE,K).LE.-1.AND.LOOKUP(DATA_TYPE,K).GE.-3)) WRITDM1A.182
+ THEN WRITDM1A.183
*IF -DEF,MPP GPB0F305.407
CALL BUFFOUT(NFTOUT,BUF(1),IPTS,LEN_IO,A) WRITDM1A.184
*ELSE GPB0F305.408
IF (SUBMODEL_ID .EQ. O_IM) THEN GPB4F403.800
IF (D1_ADDR(d1_object_type,object_index) .EQ. diagnostic) GPB4F403.801
& THEN GPB4F403.802
CALL CHANGE_DECOMPOSITION(decomp_nowrap_ocean,ICODE) GPB4F403.803
ELSE GPB4F403.804
CALL CHANGE_DECOMPOSITION(decomp_standard_ocean,ICODE) GPB4F403.805
ENDIF GPB4F403.806
ENDIF GPB4F403.807
ipts_write=um_sector_ipts GBC5F404.510
call write_multi(nftout,d1(address),um_sector_ipts, GBC5F404.523
& len_io,local_len,a, GBC5F404.524
& LOOKUP(1,K),FIXHD(12),BUF, GPB4F403.808
& D1_ADDR(1,object_index), GPB4F403.809
& CMESSAGE) GPB4F403.810
MPP_LOOKUP(P_LBLREC,K)=local_len GSM1F403.268
address=address+local_len GPB0F305.411
*ENDIF GPB0F305.412
if((a.ne.-1.0).or.(len_io.ne.ipts_write)) then GBC5F404.525
GBC5F404.526
WRITE(6,*)'ERROR WRITING DUMP ON UNIT ',NFTOUT MC240793.3
ICODE=3 MC240793.4
CMESSAGE='WRITDUMP: BAD BUFFOUT OF DATA' MC240793.5
CALL IOERROR('BUFFER OUT FROM WRITDUMP',A,LEN_IO,IPTS) MC240793.6
RETURN MC240793.7
END IF MC240793.8
ELSE WRITDM1A.185
IF (FIXHD(5).LT.6.OR. FIXHD(5).GT.9) THEN !Not AC/VarOb/Cx/Cov VSB1F400.5
CALL PR_LOOK( GDG0F401.1631
*CALL ARGPPX GDG0F401.1632
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1633
ENDIF DR221193.225
ICODE=3 WRITDM1A.187
CMESSAGE='WRITDUMP: Invalid code in LOOKUP(DATA_TYPE,K)' WRITDM1A.188
RETURN WRITDM1A.189
END IF WRITDM1A.190
WRITDM1A.191
ENDIF ! IF this field is non-zero length GPB0F401.753
*IF DEF,DIAG81 WRITDM1A.192
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.9) THEN ! Not AC/VarObs/Cx/Cov VSB1F400.6
C Print out PP header and summary of data field WRITDM1A.193
CALL PR_LOOK( GDG0F401.1634
*CALL ARGPPX GDG0F401.1635
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1636
GDG0F401.1637
IF (FIXHD(5).NE.5) THEN ! Skip if boundary datasets DR221193.226
IF(LOOKUP(DATA_TYPE,K).EQ.1) THEN ! Real DR221193.227
CALL PR_RFLD(LOOKUP,LOOKUP,D1(LOOKUP(NADDR,K)),K) WRITDM1A.196
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.2) THEN ! Integer DR221193.228
CALL PR_IFLD(LOOKUP,LOOKUP,D1(LOOKUP(NADDR,K)),K) WRITDM1A.199
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.3) THEN ! Logical DR221193.229
CALL PR_LFLD(LOOKUP,LOOKUP,LEN1_LOOKUP,D1(LOOKUP(NADDR,K)),K) DR221193.230
END IF DR221193.231
END IF WRITDM1A.200
END IF DR260593.142
*ENDIF WRITDM1A.201
WRITDM1A.202
START_BLOCK=START_BLOCK+LOOKUP(LBLREC,K) WRITDM1A.203
real_start_block=real_start_block+ipts GBC5F404.527
GBC5F404.528
WRITDM1A.204
level=level+1 GPB4F403.811
IF (level .GT. D1_ADDR(d1_no_levels,object_index)) THEN GPB4F403.812
level=1 GPB4F403.813
object_index=object_index+1 GPB4F403.814
ENDIF GPB4F403.815
200 CONTINUE WRITDM1A.205
WRITDM1A.206
WRITDM1A.207
*IF DEF,MPP GPB0F305.413
IF (mype .EQ.0 ) THEN GPB0F305.414
*ENDIF GPB0F305.415
WRITE(6,'('' '')') WRITDM1A.208
IF (FIXHD(5).GE.6 .AND. FIXHD(5).LE.9) THEN ! AC/VarObs/Cx/Cov VSB1F400.7
WRITE(6,'('' OBSERVATION DATA'')') WRITDM1A.210
ELSE WRITDM1A.211
WRITE(6,'('' MODEL DATA'')') WRITDM1A.212
ENDIF WRITDM1A.213
WRITE(6,'('' '',I8,'' words long'')')FIXHD(161) WRITDM1A.214
*IF DEF,MPP GPB0F305.416
ENDIF ! if mype .EQ. 0 GPB0F305.417
*ENDIF GPB0F305.418
WRITDM1A.215
ENDIF WRITDM1A.216
WRITDM1A.217
*IF DEF,MPP GPB4F403.816
! Reset to original decomposition type GPB4F403.817
CALL CHANGE_DECOMPOSITION(orig_decomp,ICODE) GPB4F403.818
*ENDIF GPB4F403.819
*IF DEF,MPP GPB0F305.419
IF (mype .EQ.0 ) THEN GPB0F305.420
*ENDIF GPB0F305.421
WRITE(6,'('' '')') WRITDM1A.218
WRITE(6,'('' MODEL DUMP SUCCESSFULLY WRITTEN -'',I9, WRITDM1A.219
*'' WORDS TO UNIT'',I3)')START_BLOCK,NFTOUT WRITDM1A.220
if(real_start_block.ne.start_block) then GBC5F404.529
write(6,'(/'' Number of Words Written to Disk was '',i9)') GBC5F404.530
2 real_start_block GBC5F404.531
endif GBC5F404.532
*IF DEF,MPP GPB0F305.422
ENDIF ! if mype .EQ. 0 GPB0F305.423
*ENDIF GPB0F305.424
WRITDM1A.221
RETURN WRITDM1A.222
END WRITDM1A.223
WRITDM1A.224
CLL SUBROUTINE WRITDUMP--------------------------------------- GPB4F403.820
CLL GPB4F403.821
CLL Purpose : Writes an obs file. GPB4F403.822
CLL GPB4F403.823
CLL Code mostly copied from original WRITDUMP GPB4F403.824
CLL GPB4F403.825
CLL Model Modification history from model version 4.3: GPB4F403.826
CLL version Date GPB4F403.827
CLL 4.3 19/3/97 New routine introduced P.Burton GPB4F403.828
CLL GPB4F403.829
CLL Programming standard: Unified Model Documentation Paper No 3 GPB4F403.830
CLL Version No 1 15/1/90 GPB4F403.831
CLL GPB4F403.832
CLL Logical component: R30 GPB4F403.833
CLL GPB4F403.834
CLL Project task: F3 GPB4F403.835
CLL GPB4F403.836
CLL Purpose: Writes out model dump on unit NFTOUT and checks model GPB4F403.837
CLL and dump dimensions for consistency. GPB4F403.838
CLL GPB4F403.839
CLL Documentation: Unified Model Documentation Paper No F3 GPB4F403.840
CLL Version No 5 9/2/90 GPB4F403.841
CLLEND--------------------------------------------------------- GPB4F403.842
C GPB4F403.843
C*L Arguments:------------------------------------------------- GPB4F403.844
SUBROUTINE WRITDUMP(NFTOUT,FIXHD,LEN_FIXHD, ,10GPB4F403.845
& INTHD,LEN_INTHD, GPB4F403.846
& REALHD,LEN_REALHD, GPB4F403.847
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GPB4F403.848
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GPB4F403.849
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GPB4F403.850
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GPB4F403.851
& EXTCNST,LEN_EXTCNST, GPB4F403.852
& DUMPHIST,LEN_DUMPHIST, GPB4F403.853
& CFI1,LEN_CFI1, GPB4F403.854
& CFI2,LEN_CFI2, GPB4F403.855
& CFI3,LEN_CFI3, GPB4F403.856
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,BUFLEN, GPB4F403.857
& LEN_DATA,D1, GPB4F403.858
*CALL ARGPPX GPB4F403.859
& ICODE,CMESSAGE) GPB4F403.860
GPB4F403.861
IMPLICIT NONE GPB4F403.862
GPB4F403.863
INTEGER GPB4F403.864
* NFTOUT !IN Unit no of dump GPB4F403.865
*,LEN_FIXHD !IN Length of fixed length header GPB4F403.866
*,LEN_INTHD !IN Length of integer header GPB4F403.867
*,LEN_REALHD !IN Length of real header GPB4F403.868
*,LEN1_LEVDEPC !IN 1st dim of level dep consts GPB4F403.869
*,LEN2_LEVDEPC !IN 2ndt dim of level dep consts GPB4F403.870
*,LEN1_ROWDEPC !IN 1st dim of row dep consts GPB4F403.871
*,LEN2_ROWDEPC !IN 2nd dim of row dep consts GPB4F403.872
&,LEN1_COLDEPC !IN 1st dim of column dep consts GPB4F403.873
&,LEN2_COLDEPC !IN 2nd dim of column dep consts GPB4F403.874
&,LEN1_FLDDEPC !IN 1st dim of field dep consts GPB4F403.875
&,LEN2_FLDDEPC !IN 2nd dim of field dep consts GPB4F403.876
&,LEN_EXTCNST !IN Length of extra constants GPB4F403.877
&,LEN_DUMPHIST !IN Length of history block GPB4F403.878
&,LEN_CFI1 !IN Length of comp field index 1 GPB4F403.879
&,LEN_CFI2 !IN Length of comp field index 2 GPB4F403.880
&,LEN_CFI3 !IN Length of comp field index 3 GPB4F403.881
&,LEN1_LOOKUP !IN 1st dim of lookup GPB4F403.882
&,LEN2_LOOKUP !IN 2nd dim of lookup GPB4F403.883
GPB4F403.884
INTEGER GPB4F403.885
* BUFLEN !IN Maximum length of single field in dump GPB4F403.886
*,LEN_DATA !IN Length of real data GPB4F403.887
*,ICODE !OUT Return code; successful=0 GPB4F403.888
* ! error > 0 GPB4F403.889
GPB4F403.890
CHARACTER*(80) GPB4F403.891
* CMESSAGE !OUT Error message if ICODE > 0 GPB4F403.892
GPB4F403.893
INTEGER GPB4F403.894
* FIXHD(LEN_FIXHD) !IN Fixed length header GPB4F403.895
*,INTHD(LEN_INTHD) !IN Integer header GPB4F403.896
*,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) !IN PP lookup tables GPB4F403.897
*,CFI1(LEN_CFI1+1) !IN Compressed field index no 1 GPB4F403.898
*,CFI2(LEN_CFI2+1) !IN Compressed field index no 2 GPB4F403.899
*,CFI3(LEN_CFI3+1) !IN Compressed field index no 3 GPB4F403.900
GPB4F403.901
REAL GPB4F403.902
& REALHD(LEN_REALHD) !IN Real header GPB4F403.903
&,LEVDEPC(1+LEN1_LEVDEPC*LEN2_LEVDEPC) !IN Lev dep consts GPB4F403.904
&,ROWDEPC(1+LEN1_ROWDEPC*LEN2_ROWDEPC) !IN Row dep consts GPB4F403.905
&,COLDEPC(1+LEN1_COLDEPC*LEN2_COLDEPC) !IN Col dep consts GPB4F403.906
&,FLDDEPC(1+LEN1_FLDDEPC*LEN2_FLDDEPC) !IN Field dep consts GPB4F403.907
&,EXTCNST(LEN_EXTCNST+1) !IN Extra constants GPB4F403.908
&,DUMPHIST(LEN_DUMPHIST+1) !IN History block GPB4F403.909
*,D1(LEN_DATA) !IN Real equivalence of data block GPB4F403.910
GPB4F403.911
*CALL CSUBMODL GPB4F403.912
*CALL CPPXREF GPB4F403.913
*CALL PPXLOOK GPB4F403.914
*CALL CLOOKADD GPB4F403.915
*IF DEF,MPP GPB4F403.916
*CALL PARVARS GPB4F403.917
*ENDIF GPB4F403.918
*CALL C_MDI GBC5F404.533
*CALL AMAXSIZE GBC5F404.534
*CALL CNTL_IO GBC5F404.535
GPB4F403.919
C ------------------------------------------------------------- GPB4F403.920
C Local arrays:------------------------------------------------ GPB4F403.921
real buf(((buflen+um_sector_size)/um_sector_size)*um_sector_size) GBC5F404.536
cdir$ cache_align buf GBC5F404.537
C ------------------------------------------------------------- GPB4F403.923
C*L External subroutines called:------------------------------- GPB4F403.924
EXTERNAL IOERROR,POSERROR,WRITHEAD,PR_LOOK,PR_IFLD,PR_RFLD GPB4F403.925
*,PACK21,EXPAND21,BUFFOUT,P21BITS,PR_LFLD GPB4F403.926
INTEGER P21BITS GPB4F403.927
C Cray specific functions UNIT,LENGTH GPB4F403.928
C*------------------------------------------------------------- GPB4F403.929
C Local variables:--------------------------------------------- GPB4F403.930
INTEGER START_BLOCK ! Pointer to current position in file GPB4F403.931
*,LEN_IO ! No of 64-bit words buffered in GPB4F403.932
*,K,I ! Loop counts GPB4F403.933
*,IPTS ! No of 64-bit words requested to be GPB4F403.934
* ! buffered in GPB4F403.935
&, word_address ! disk address of the record GBC5F404.538
&, real_start_block ! real start address and number of words moved GBC5F404.539
&, l_ipts ! record length during index search GBC5F404.540
&, um_sector_ipts ! number fo words to write, rounded up GBC5F404.541
&, ipts_write ! number of words actually write from disk GBC5F404.542
&, disk_address ! Current rounded disk address GBC5F404.543
&, number_of_data_words_on_disk ! Number of data words on disk GBC5F404.544
&, number_of_data_words_in_memory ! Number of Data Words in memory GBC5F404.545
GPB4F403.936
REAL A ! Error code returned by UNIT GPB4F403.937
C-------------------------------------------------------------- GPB4F403.938
GPB4F403.939
*IF DEF,MPP GPB4F403.940
IF (mype .EQ. 0) THEN GPB4F403.941
*ENDIF GPB4F403.942
WRITE(6,'(/,'' WRITING UNIFIED MODEL DUMP ON UNIT'',I3)')NFTOUT GPB4F403.943
WRITE(6,'('' #####################################'',/)') GPB4F403.944
*IF DEF,MPP GPB4F403.945
ENDIF GPB4F403.946
*ENDIF GPB4F403.947
ICODE=0 GPB4F403.948
CMESSAGE=' ' GPB4F403.949
GPB4F403.950
CL 1. Read in all header records and check for consistency GPB4F403.951
C START_BLOCK points to position of model data block GPB4F403.952
C on return GPB4F403.953
c GBC5F404.546
c--reset the disk addresses and lengths for well-formed I/O GBC5F404.547
call set_dumpfile_address(fixhd, len_fixhd, GBC5F404.548
& lookup, len1_lookup, GBC5F404.549
& len2_lookup, GBC5F404.550
& number_of_data_words_in_memory, GBC5F404.551
& number_of_data_words_on_disk, GBC5F404.552
& disk_address) GBC5F404.553
GPB4F403.954
CALL WRITHEAD(NFTOUT,FIXHD,LEN_FIXHD, GPB4F403.955
& INTHD,LEN_INTHD, GPB4F403.956
& REALHD,LEN_REALHD, GPB4F403.957
& LEVDEPC,LEN1_LEVDEPC,LEN2_LEVDEPC, GPB4F403.958
& ROWDEPC,LEN1_ROWDEPC,LEN2_ROWDEPC, GPB4F403.959
& COLDEPC,LEN1_COLDEPC,LEN2_COLDEPC, GPB4F403.960
& FLDDEPC,LEN1_FLDDEPC,LEN2_FLDDEPC, GPB4F403.961
& EXTCNST,LEN_EXTCNST, GPB4F403.962
& DUMPHIST,LEN_DUMPHIST, GPB4F403.963
& CFI1,LEN_CFI1, GPB4F403.964
& CFI2,LEN_CFI2, GPB4F403.965
& CFI3,LEN_CFI3, GPB4F403.966
& LOOKUP,LEN1_LOOKUP,LEN2_LOOKUP,LEN_DATA, GPB4F403.967
*CALL ARGPPX GPB4F403.968
& START_BLOCK,ICODE,CMESSAGE) GPB4F403.969
GPB4F403.970
IF(ICODE.GT.0)RETURN GPB4F403.971
GPB4F403.972
CL 2. Buffer in model data one field at a time for GPB4F403.973
CL conversion from 64-bit to 32-bit numbers GPB4F403.974
GPB4F403.975
IF(FIXHD(160).GT.0)THEN GPB4F403.976
GPB4F403.977
C Check for error in file pointers GPB4F403.978
real_start_block=start_block GBC5F404.554
if(start_block.eq.fixhd(160)) then GBC5F404.555
C If new format Dumpfile, we must reset the start address GBC5F404.556
if((lookup(lbnrec,1).eq.0) .or. GBC5F404.557
C Ocean ACOBS Files (?) GBC5F404.558
2 ((lookup(lbnrec,1).eq.imdi) .or. (lookup(lbegin,1).eq.imdi)) GBC5F404.559
3 .or. GBC5F404.560
C Prog lookups in dump before vn3.2: GBC5F404.561
4 ((lookup(lbnrec,1).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.562
CMESSAGE='WRITDUMP: Addressing conflict' GPB4F403.980
ICODE=1 GPB4F403.981
CALL POSERROR('model data', GPB4F403.982
* START_BLOCK,160,FIXHD(160)) GPB4F403.983
RETURN GPB4F403.984
else GBC5F404.563
real_start_block=fixhd(160) GBC5F404.564
endif GBC5F404.565
ENDIF GPB4F403.985
GPB4F403.986
C Loop over number of fields in data blocks GPB4F403.987
GPB4F403.988
DO 200 K=1,FIXHD(152) GPB4F403.989
IF (LOOKUP(LBLREC,K) .GT. 0) THEN ! if this isnt a zero GPB4F403.990
! ! length field GPB4F403.991
C Is the buffer length long enough for this field. GPB4F403.992
IF(LOOKUP(LBLREC,K).GT.BUFLEN) THEN GPB4F403.993
ICODE=100 GPB4F403.994
CMESSAGE='WRITDUMP : Field length longer than buffer' GPB4F403.995
WRITE(6,*) 'WRITDUMP :Field length longer than buffer, abort', GPB4F403.996
& LOOKUP(LBLREC,K),'>',BUFLEN GPB4F403.997
RETURN GPB4F403.998
END IF GPB4F403.999
*IF -DEF,MPP GPB4F403.1000
C Pack if required GPB4F403.1001
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN GPB4F403.1002
C Pack 32 bit numbers GPB4F403.1003
IF(LOOKUP(DATA_TYPE,K).EQ.1) THEN GPB4F403.1004
CALL PACK21(LOOKUP(LBLREC,K),D1(LOOKUP(NADDR,K)), GPB4F403.1005
& BUF(1),P21BITS(FIXHD(12))) GPB4F403.1006
C Expand back to ensure reproducibility across a restart GPB4F403.1007
CALL EXPAND21(LOOKUP(LBLREC,K),BUF(1), GPB4F403.1008
& D1(LOOKUP(NADDR,K)),P21BITS(FIXHD(12))) GPB4F403.1009
END IF GPB4F403.1010
C Copy across if already in 64 bit GPB4F403.1011
ELSE GPB4F403.1012
DO 110 I=1,LOOKUP(LBLREC,K) GPB4F403.1013
BUF(I)=D1(LOOKUP(NADDR,K)+I-1) GPB4F403.1014
110 CONTINUE GPB4F403.1015
END IF GPB4F403.1016
*ELSE GPB4F403.1017
! Data packing to 32 bits is moved down to write_multi. We only want GPB4F403.1018
! to compress data after the global data has been gathered GPB4F403.1019
*ENDIF GPB4F403.1020
GPB4F403.1021
C Test whether data stored as 32-bit on disk GPB4F403.1022
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN GPB4F403.1023
IPTS=(LOOKUP(LBLREC,K)+1)/2 GPB4F403.1024
ELSE GPB4F403.1025
IPTS=LOOKUP(LBLREC,K) GPB4F403.1026
ENDIF GPB4F403.1027
GBC5F404.566
CL Compute word address in file from which to begin I/O GBC5F404.567
GBC5F404.568
C Old Format dumpfiles GBC5F404.569
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.570
C Ocean ACOBS Files (?) GBC5F404.571
2 ((lookup(lbnrec,k).eq.imdi) .or. (lookup(lbegin,k).eq.imdi)) GBC5F404.572
3 .or. GBC5F404.573
C Prog lookups in dump before vn3.2: GBC5F404.574
4 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.575
C Dump and ancillary files GBC5F404.576
word_address=1 GBC5F404.577
if(k.gt.1) then GBC5F404.578
do i=2, k GBC5F404.579
if(mod(lookup(lbpack,i-1),10).eq.2) then GBC5F404.580
l_ipts=(lookup(lblrec,i-1)+1)/2 GBC5F404.581
else GBC5F404.582
l_ipts=(lookup(lblrec,i-1)) GBC5F404.583
endif GBC5F404.584
word_address=word_address+l_ipts GBC5F404.585
end do GBC5F404.586
endif GBC5F404.587
word_address=fixhd(160)+word_address-2 GBC5F404.588
um_sector_ipts=ipts GBC5F404.589
else ! fieldsfiles GBC5F404.590
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.591
word_address=lookup(lbegin,k) GBC5F404.592
C Use the stored round-up value GBC5F404.593
um_sector_ipts=lookup(lbnrec,k) GBC5F404.594
endif GBC5F404.595
GBC5F404.596
ipts_write=ipts GBC5F404.597
GBC5F404.598
C Position file pointer GBC5F404.599
call setpos(nftout, word_address, icode) GBC5F404.600
GBC5F404.601
GPB4F403.1028
C Write data out from buffer GPB4F403.1029
C Check that data_type is valid no: 1 to 3 or -1 to -3 GPB4F403.1030
IF((LOOKUP(DATA_TYPE,K).GE.1.AND.LOOKUP(DATA_TYPE,K).LE.3) .OR. GPB4F403.1031
+ (LOOKUP(DATA_TYPE,K).LE.-1.AND.LOOKUP(DATA_TYPE,K).GE.-3)) GPB4F403.1032
+ THEN GPB4F403.1033
ipts_write=um_sector_ipts GBC5F404.602
ipts=ipts_write GBC5F404.603
GBC5F404.604
*IF -DEF,MPP GPB4F403.1034
CALL BUFFOUT(NFTOUT,BUF(1),IPTS,LEN_IO,A) GPB4F403.1035
*ELSE GPB4F403.1036
CALL BUFFOUT_shmem(NFTOUT,BUF(1),IPTS,LEN_IO,A) GPB4F403.1037
*ENDIF GPB4F403.1038
IF((A.NE.-1.0).OR.(LEN_IO.NE.IPTS)) THEN GPB4F403.1039
WRITE(6,*)'ERROR WRITING DUMP ON UNIT ',NFTOUT GPB4F403.1040
ICODE=3 GPB4F403.1041
CMESSAGE='WRITDUMP: BAD BUFFOUT OF DATA' GPB4F403.1042
CALL IOERROR('BUFFER OUT FROM WRITDUMP',A,LEN_IO,IPTS) GPB4F403.1043
RETURN GPB4F403.1044
END IF GPB4F403.1045
ENDIF GPB4F403.1046
GPB4F403.1047
ENDIF ! IF this field is non-zero length GPB4F403.1048
GPB4F403.1049
START_BLOCK=START_BLOCK+LOOKUP(LBLREC,K) GPB4F403.1050
real_start_block=real_start_block+ipts GBC5F404.605
GBC5F404.606
GPB4F403.1051
200 CONTINUE GPB4F403.1052
GPB4F403.1053
GPB4F403.1054
*IF DEF,MPP GPB4F403.1055
IF (mype .EQ.0 ) THEN GPB4F403.1056
*ENDIF GPB4F403.1057
WRITE(6,'('' '')') GPB4F403.1058
IF (FIXHD(5).GE.6 .AND. FIXHD(5).LE.9) THEN ! AC/VarObs/Cx/Cov GPB4F403.1059
WRITE(6,'('' OBSERVATION DATA'')') GPB4F403.1060
ELSE GPB4F403.1061
WRITE(6,'('' MODEL DATA'')') GPB4F403.1062
ENDIF GPB4F403.1063
WRITE(6,'('' '',I8,'' words long'')')FIXHD(161) GPB4F403.1064
*IF DEF,MPP GPB4F403.1065
ENDIF ! if mype .EQ. 0 GPB4F403.1066
*ENDIF GPB4F403.1067
GPB4F403.1068
ENDIF GPB4F403.1069
GPB4F403.1070
*IF DEF,MPP GPB4F403.1071
IF (mype .EQ.0 ) THEN GPB4F403.1072
*ENDIF GPB4F403.1073
WRITE(6,'('' '')') GPB4F403.1074
WRITE(6,'('' MODEL DUMP SUCCESSFULLY WRITTEN -'',I9, GPB4F403.1075
*'' WORDS TO UNIT'',I3)')START_BLOCK,NFTOUT GPB4F403.1076
if(real_start_block.ne.start_block) then GBC5F404.607
write(6,'(/'' Number of Words Written to Disk was '',i9)') GBC5F404.608
2 real_start_block GBC5F404.609
endif GBC5F404.610
*IF DEF,MPP GPB4F403.1077
ENDIF ! if mype .EQ. 0 GPB4F403.1078
*ENDIF GPB4F403.1079
GPB4F403.1080
RETURN GPB4F403.1081
END GPB4F403.1082
*ENDIF WRITDM1A.225