*IF DEF,C80_1A,OR,DEF,UTILIO,OR,DEF,FLDOP,OR,DEF,RECON UIE3F404.68
*IF -DEF,SCMA AJC0F405.277
C ******************************COPYRIGHT****************************** GTS2F400.12097
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.12098
C GTS2F400.12099
C Use, duplication or disclosure of this code is subject to the GTS2F400.12100
C restrictions as set forth in the contract. GTS2F400.12101
C GTS2F400.12102
C Meteorological Office GTS2F400.12103
C London Road GTS2F400.12104
C BRACKNELL GTS2F400.12105
C Berkshire UK GTS2F400.12106
C RG12 2SZ GTS2F400.12107
C GTS2F400.12108
C If no contract has been raised with this copy of the code, the use, GTS2F400.12109
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.12110
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.12111
C Modelling at the above address. GTS2F400.12112
C ******************************COPYRIGHT****************************** GTS2F400.12113
C GTS2F400.12114
CLL SUBROUTINE WRITFLDS--------------------------------------- WRITFL1A.3
CLL WRITFL1A.4
CLL Purpose: WRITFL1A.5
CLL Buffers out NUMBER_OF_FIELDS fields from DATA block on unit WRITFL1A.6
CLL NFTOUT. 32-bit and 64-bit real numbers and integer/logical WRITFL1A.7
CLL data types are handled. The I/O starts at field number WRITFL1A.8
CLL POSITION, where POSITION is the number of the PP header WRITFL1A.9
CLL pointing to the 1st field to be written. The code uses SETP WRITFL1A.10
CLL to position the file pointer. The output file must therefor WRITFL1A.11
CLL be unblocked, ie use assign ... -su ... in the script. WRITFL1A.12
CLL WRITFL1A.13
CLL AD, DR, TJ <- programmer of some or all of previous code or changes WRITFL1A.14
CLL WRITFL1A.15
CLL Model Modification history from model version 3.0: WRITFL1A.16
CLL version Date WRITFL1A.17
CLL 3.1 19/02/93 Use FIXHD(12) not FIXHD(1) as Version no in P21BITS TJ190293.13
CLL 3.3 25/11/93 Use PR_LFLD to print logical fields. Skip DIAG81 DR221193.232
CLL diagnostics for observation files. Skip field DR221193.233
CLL summaries for boundary data. D. Robinson. DR221193.234
CLL 3.3 08/12/93 Extra argument - first dimension of lookup table. DR081293.9
CLL Remove hard-wired value of 64. D. Robinson DR081293.10
CLL 4.1 11/05/96 Allowed for Var and OPS files. Author Colin Parrett VSB1F401.391
CLL 4.1 03/01/96 Relace Char*100 with Char*80 (N Farnon) ANF0F401.3
! 4.1 18/06/96 Changes to cope with changes in STASH addressing GDG0F401.1545
! Author D.M. Goddard. GDG0F401.1546
! 4.4 25/04/97 Changes to write well-formed records if the GBC5F404.611
! input dumpfile is in that format (almost PP file GBC5F404.612
! format) GBC5F404.613
! Author: Bob Carruthers, Cray Research GBC5F404.614
! 4.5 08/07/98 Corrected error, when writing last GPB0F405.88
! field could cause data to be written from past GPB0F405.89
! the end of the input array. Paul Burton GPB0F405.90
! 4.5 28/10/98 Introduce Single Column Model. J-C Thil. AJC0F405.278
CLL WRITFL1A.18
CLL Programming standard: Unified Model Documentation Paper No 3 WRITFL1A.19
CLL Version No 1 15/1/90 WRITFL1A.20
CLL WRITFL1A.21
CLL Logical component: C25 WRITFL1A.22
CLL WRITFL1A.23
CLL Project task: F3 WRITFL1A.24
CLL WRITFL1A.25
CLL Documentation: Unified Model Documentation Paper No F3 WRITFL1A.26
CLL Version No 5 9/2/90 WRITFL1A.27
CLLEND--------------------------------------------------------- WRITFL1A.28
C*L Arguments:------------------------------------------------- WRITFL1A.29
SUBROUTINE WRITFLDS(NFTOUT,NUMBER_OF_FIELDS, ! Intent (In) 88,10GDG0F401.1547
& POSITION,LOOKUP,LEN1_LOOKUP, ! GDG0F401.1548
& D1,LEN_BUF,FIXHD, ! GDG0F401.1549
*CALL ARGPPX 
GDG0F401.1550
& ICODE,CMESSAGE) ! Intent (Out) GDG0F401.1551
WRITFL1A.32
IMPLICIT NONE WRITFL1A.33
WRITFL1A.34
INTEGER WRITFL1A.35
* NFTOUT !IN Unit number for I/O WRITFL1A.36
*,ICODE !OUT Return code =0 normal exit; >0 error WRITFL1A.37
*,NUMBER_OF_FIELDS !IN No of fields to be written WRITFL1A.38
*,LEN_BUF !IN Length of I/O buffer WRITFL1A.39
*,POSITION !IN Field number from which to begin I/O WRITFL1A.40
*,FIXHD(*) !IN Fixed length header WRITFL1A.41
*,LEN1_LOOKUP !IN First dimension of lookup table DR081293.13
*,LOOKUP(LEN1_LOOKUP,*) !IN PP lookup starting at field no 1 DR081293.14
WRITFL1A.43
REAL WRITFL1A.44
* D1(*) !IN Start address of data to be written out WRITFL1A.45
WRITFL1A.46
CHARACTER*80 ANF0F401.4
* CMESSAGE !OUT Message returned if ICODE>0 WRITFL1A.48
WRITFL1A.49
C ------------------------------------------------------------- WRITFL1A.50
C Local arrays:------------------------------------------------ WRITFL1A.51
*CALL C_MDI GBC5F404.615
*CALL CNTL_IO GBC5F404.616
real buf(((len_buf-1+um_sector_size)/ ! I/O buffer GBC5F404.617
2 um_sector_size)*um_sector_size) GBC5F404.618
cdir$ cache_align buf GBC5F404.619
C ------------------------------------------------------------- WRITFL1A.53
C External subroutines called:--------------------------------- WRITFL1A.54
EXTERNAL PR_LOOK,PR_RFLD,PR_IFLD,IOERROR,PACK21,SETPOS,BUFFIN WRITFL1A.55
* ,P21BITS,PR_LFLD DR221193.235
INTEGER P21BITS WRITFL1A.57
C*------------------------------------------------------------- WRITFL1A.58
C Local variables:--------------------------------------------- WRITFL1A.59
INTEGER WRITFL1A.60
* I,J,K ! Indicies GPB0F405.91
*,LEN_IO ! Length of I/O returned by LENGTH WRITFL1A.62
*,IPTS ! No of values to be written to disk WRITFL1A.63
*,WORD_ADDRESS ! word address to begin I/O WRITFL1A.64
&, l_ipts ! record length during index search GBC5F404.620
&, um_sector_ipts ! number fo words to write, rounded up GBC5F404.621
&, ipts_write ! number of words actually write from disk GBC5F404.622
*, kk ! local value of k for address computing GBC5F404.623
WRITFL1A.65
REAL A_IO WRITFL1A.66
C ------------------------------------------------------------- WRITFL1A.67
WRITFL1A.68
! Comdecks:---------------------------------------------------------- GDG0F401.1552
*CALL CSUBMODL GDG0F401.1553
*CALL CPPXREF GDG0F401.1554
*CALL PPXLOOK GDG0F401.1555
*CALL CLOOKADD WRITFL1A.69
WRITFL1A.70
ICODE=0 WRITFL1A.71
CMESSAGE=' ' WRITFL1A.72
WRITFL1A.73
CL 2. Buffer out NUMBER_OF_FIELDS fields of data: WRITFL1A.92
J=0 WRITFL1A.93
DO 200 K=POSITION,POSITION+NUMBER_OF_FIELDS-1 WRITFL1A.94
WRITFL1A.95
C Test whether data stored as 32-bit on disk WRITFL1A.96
IF(MOD((LOOKUP(LBPACK,K)),10).EQ.2) THEN WRITFL1A.97
C Pack 32-bit numbers using P21BITS for exponent (fn of dump release) WRITFL1A.98
IPTS=(LOOKUP(LBLREC,K)+1)/2 WRITFL1A.100
ELSE WRITFL1A.102
IPTS=LOOKUP(LBLREC,K) WRITFL1A.103
ENDIF WRITFL1A.105
GBC5F404.624
C Old Format dumpfiles GBC5F404.625
if((lookup(lbnrec,k).eq.0) .or. GBC5F404.626
C Ocean ACOBS Files (?) GBC5F404.627
2 ((lookup(lbnrec,k).eq.imdi) .or. (lookup(lbegin,k).eq.imdi)) GBC5F404.628
3 .or. GBC5F404.629
C Prog lookups in dump before vn3.2: GBC5F404.630
4 ((lookup(lbnrec,k).eq.imdi) .and. (fixhd(12).le.301))) then GBC5F404.631
word_address=1 GBC5F404.632
do kk=2, k GBC5F404.633
if(mod(lookup(lbpack,kk-1),10).eq.2) then GBC5F404.634
l_ipts=(lookup(lblrec,kk-1)+1)/2 GBC5F404.635
else GBC5F404.636
l_ipts=lookup(lblrec,kk-1) GBC5F404.637
endif GBC5F404.638
word_address=word_address+l_ipts GBC5F404.639
end do GBC5F404.640
word_address=word_address+fixhd(160)-2 GBC5F404.641
um_sector_ipts=ipts GBC5F404.642
GBC5F404.643
else GBC5F404.644
GBC5F404.645
C PP type files and new format Dumpfiles (vn4.4 onwards) GBC5F404.646
word_address=lookup(lbegin,k) GBC5F404.647
C Use the stored round-up value GBC5F404.648
um_sector_ipts=lookup(lbnrec,k) GBC5F404.649
endif GBC5F404.650
GBC5F404.651
ipts_write=um_sector_ipts GBC5F404.652
GBC5F404.653
C Position file pointer GBC5F404.654
call setpos(nftout,word_address,icode) GBC5F404.655
GBC5F404.656
if(mod(lookup(lbpack,k),10).eq.2) then GBC5F404.657
call pack21(lookup(lblrec,k),d1(j+1),buf,p21bits(fixhd(12))) GBC5F404.658
else GPB0F405.92
!Compiler error removal *DIR$ CACHE_BYPASS BUF,D1 GPB0F405.93
do i=1,lookup(lblrec,k) GPB0F405.94
buf(i)=d1(j+i) GPB0F405.95
enddo GPB0F405.96
endif GPB0F405.97
GPB0F405.98
call buffout(nftout,buf(1),um_sector_ipts,len_io,a_io) GPB0F405.99
WRITFL1A.106
C Check for I/O errors WRITFL1A.107
if(a_io.ne.-1.0.or.len_io.ne.ipts_write) then GBC5F404.663
WRITE(6,'('' *ERROR* Writing field no'',I5)')K WRITFL1A.109
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.10) THEN ! Not AC/Cx/Cov/ObSt VSB1F401.392
CALL PR_LOOK( GDG0F401.1556
*CALL ARGPPX GDG0F401.1557
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1558
ENDIF DR221193.237
CALL IOERROR('buffer out of real data',A_IO,LEN_IO, WRITFL1A.111
* IPTS) WRITFL1A.112
ICODE=NINT(A_IO)+1 WRITFL1A.113
CMESSAGE='WRITFLDS:I/O error' WRITFL1A.114
RETURN WRITFL1A.115
ENDIF WRITFL1A.116
WRITFL1A.117
*IF DEF,DIAG81 WRITFL1A.118
IF (FIXHD(5).LT.6 .OR. FIXHD(5).GT.10) THEN !Not AC/Var/Cx/Cov/ObS VSB1F401.393
C Print out PP header and summary of data field WRITFL1A.119
CALL PR_LOOK( GDG0F401.1559
*CALL ARGPPX GDG0F401.1560
& LOOKUP,LOOKUP,LEN1_LOOKUP,K) GDG0F401.1561
IF (FIXHD(5).NE.5) THEN ! Skip if boundary dataset DR221193.239
IF(LOOKUP(DATA_TYPE,K).EQ.1) THEN ! Real DR221193.240
CALL PR_RFLD(LOOKUP,LOOKUP,D1(J+1),K) WRITFL1A.122
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.2) THEN ! Integer DR221193.241
CALL PR_IFLD(LOOKUP,LOOKUP,D1(J+1),K) WRITFL1A.124
ELSE IF(LOOKUP(DATA_TYPE,K).EQ.3) THEN ! Logical DR221193.242
CALL PR_LFLD(LOOKUP,LOOKUP,64,D1(J+1),K) DR221193.243
ENDIF DR221193.244
ENDIF DR221193.245
ENDIF WRITFL1A.125
*ENDIF WRITFL1A.126
WRITFL1A.127
J=J+LOOKUP(LBLREC,K) WRITFL1A.128
WRITFL1A.129
200 CONTINUE WRITFL1A.130
WRITFL1A.131
RETURN WRITFL1A.132
END WRITFL1A.133
*ENDIF WRITFL1A.134
*ENDIF AJC0F405.279