*IF DEF,C84_1A,OR,DEF,FLDOP UIE3F404.40
C ******************************COPYRIGHT****************************** GTS2F400.7453
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.7454
C GTS2F400.7455
C Use, duplication or disclosure of this code is subject to the GTS2F400.7456
C restrictions as set forth in the contract. GTS2F400.7457
C GTS2F400.7458
C Meteorological Office GTS2F400.7459
C London Road GTS2F400.7460
C BRACKNELL GTS2F400.7461
C Berkshire UK GTS2F400.7462
C RG12 2SZ GTS2F400.7463
C GTS2F400.7464
C If no contract has been raised with this copy of the code, the use, GTS2F400.7465
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.7466
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.7467
C Modelling at the above address. GTS2F400.7468
C ******************************COPYRIGHT****************************** GTS2F400.7469
C GTS2F400.7470
CLL SUBROUTINE PP_FILE ----------------------------------------- PPFILE1A.3
CLL PPFILE1A.4
CLL Purpose:- To output a field to a PP_FILE PPFILE1A.5
CLL PPFILE1A.6
CLL Tested under compiler CFT77 PPFILE1A.7
CLL Tested under OS version 5.1 PPFILE1A.8
CLL PPFILE1A.9
CLL TJ, RR <- programmer of some or all of previous code or changes PPFILE1A.10
CLL PPFILE1A.11
CLL Model Modification history from model version 3.0: PPFILE1A.12
CLL version Date PPFILE1A.13
CLL 3.2 13/07/93 Changed CHARACTER*(*) to CHARACTER*(80) for TS150793.111
CLL portability. Author Tracey Smith. TS150793.112
CLL 3.2 19/04/93 Code for new real missing data indicator (TCJ). TJ050593.102
CLL 3.4 04/08/94 No packing indicator change from -26 to -99 PJS APS1F304.3
!LL 4.1 22/11/96 Modify I/O calls for MPP use P.Burton GPB1F402.657
!LL 4.3 30/04/97 Added code to use UM_SECTOR_SIZE to make transfers GBC0F403.52
!LL well-formed. GBC0F403.53
!LL B. Carruthers Cray Research. GBC0F403.54
!LL 4.4 16/06/97 Add processing after the write, so GBC3F404.8
!LL that all the processors know the answer GBC3F404.9
!LL Author: Bob Carruthers, Cray Rsearch. GBC3F404.10
!LL 4.5 28/05/98 Code for parallel processing in COEX Packing GBCQF405.1
!LL Author: Paul Burton & Bob Carruthers GBCQF405.2
CLL PPFILE1A.14
CLL Programming standard: U M DOC Paper NO. 4, PPFILE1A.15
CLL PPFILE1A.16
CLL Logical components covered C4 PPFILE1A.17
CLL PPFILE1A.18
CLL Project TASK: C4 PPFILE1A.19
CLL PPFILE1A.20
CLL External documentation C4 PPFILE1A.21
CLL PPFILE1A.22
CLLEND------------------------------------------------------------- PPFILE1A.23
PPFILE1A.24
C PPFILE1A.25
C*L ARGUMENTS:--------------------------------------------------- PPFILE1A.26
SUBROUTINE PP_FILE(PPFIELD,LENBUF,NUM_WORDS,RMDI,COMP_ACCRCY, 5,10TJ050593.103
1PPHORIZ_OUT,UNITPP,IWA,N_COLS_OUT,N_ROWS_OUT,PACKING, PPFILE1A.28
*IF DEF,MPP,AND,DEF,T3E GBCQF405.3
2PACKING_TYPE,current_io_pe,ICODE,CMESSAGE) GBCQF405.4
*ELSE GBCQF405.5
2PACKING_TYPE,ICODE,CMESSAGE) GO261093.57
*ENDIF GBCQF405.6
IMPLICIT NONE PPFILE1A.30
PPFILE1A.31
PPFILE1A.32
CHARACTER*(80) CMESSAGE !OUT OUT MESSAGE FROM ROUTINE TS150793.113
C PPFILE1A.34
LOGICAL PPFILE1A.35
* PACKING !IN OVERALL Packing switch (T if pckng reqd) PPFILE1A.36
PPFILE1A.37
INTEGER PPFILE1A.38
* ICODE !IN RETURN CODE FROM ROUTINE PPFILE1A.39
*, LENBUF !IN LENGTH OFF PP BUFFER PPFILE1A.40
*, UNITPP !IN OUTPUT PP UNIT NUMBER PPFILE1A.41
*, LEN_IO !NOT USED, BUT NEEDED FOR BUFFOUT CALL PPFILE1A.42
*IF DEF,MPP,AND,DEF,T3E GBCQF405.7
*, current_io_pe !IN PE which will do the I/O GBCQF405.8
*ENDIF GBCQF405.9
C PPFILE1A.43
INTEGER PPFILE1A.44
* N_ROWS_OUT !IN PPHORIZ_OUT=N_ROWS_OUT*N_COLS_OUT PPFILE1A.45
*, N_COLS_OUT !IN PPHORIZ_OUT=N_COLS_OUT*N_ROWS_OUT PPFILE1A.46
*, NUM_OUT !IN NUMBER OF COMPRESSED (32 BIT) WORDS PPFILE1A.47
*, COMP_ACCRCY !IN PACKING ACCURACY IN POWER OF 2 PPFILE1A.48
*, U_ROWS !IN NO OF U,V, ROWS PPFILE1A.49
*, P_ROWS !IN PRESS/TEMP ROWS PPFILE1A.50
*, PPHORIZ_OUT !IN SIZE OF OUTPUT FIELD PPFILE1A.51
*, NUM_WORDS !IN NUMBER OF 64 BIT WORDS WORTH OF DATA PPFILE1A.52
*, PACKING_TYPE ! OUT set to 1 if WGDOS packing else set to zero. GO261093.58
C PPFILE1A.53
REAL PPFILE1A.54
* PPFIELD(PPHORIZ_OUT) !INOUT ARRAY TO STORE PPDATA PPFILE1A.55
*, BUFOUT(LENBUF) !OUTPUT PP BUFFER (ROUNDED UP) PPFILE1A.56
*, RMDI !IN Missing data indicator TJ050593.104
C PPFILE1A.58
C PPFILE1A.59
*IF DEF,MPP,AND,DEF,T3E GBCQF405.10
*CALL PARVARS 
GBCQF405.11
*ENDIF GBCQF405.12
PPFILE1A.60
C GBC0F403.55
cdir$ cache_align bufout GBC0F403.56
*CALL CNTL_IO GBC0F403.57
C*--------------------------------------------------------------------- PPFILE1A.61
PPFILE1A.62
C*L WORKSPACE USAGE:------------------------------------------------- PPFILE1A.63
C DEFINE LOCAL WORKSPACE ARRAYS: 1 REAL ARRAY PPFILE1A.64
C AT FULL FIELD LENGTH PPFILE1A.65
C PPFILE1A.66
C*--------------------------------------------------------------------- PPFILE1A.67
C PPFILE1A.68
C*L EXTERNAL SUBROUTINES CALLED--------------------------------------- PPFILE1A.69
EXTERNAL SETPOS,COEX,BUFFOUT PPFILE1A.70
C*------------------------------------------------------------------ PPFILE1A.71
CL MAXIMUM VECTOR LENGTH ASSUMED IS (ROWS-1) * ROWLENGTH PPFILE1A.72
CL--------------------------------------------------------------------- PPFILE1A.73
C---------------------------------------------------------------------- PPFILE1A.74
C DEFINE LOCAL VARIABLES PPFILE1A.75
INTEGER PPFILE1A.76
* ML ! LONGITUDE COUNTER PPFILE1A.77
*, JL ! LATITUDE COUNTER PPFILE1A.78
*, IWA ! RECORD NUMBER PPFILE1A.79
*, II ! COUNTER PPFILE1A.80
*, LENGTH_FULLWRD! LENGTH IN BITS OF FULLWORD VAR PPFILE1A.81
*, LEN_BUF_WORDS ! NUM_WORDS ROUNDED BY 512 AND ACTUALLY PPFILE1A.82
PPFILE1A.83
INTEGER PPFILE1A.84
* JJ ! Local counter PPFILE1A.85
PPFILE1A.86
REAL PPFILE1A.87
* IX ! RETURN VALUE FROM UNIT COMMAND PPFILE1A.88
PPFILE1A.89
LOGICAL PPFILE1A.90
* UV ! PPFILE1A.92
C PPFILE1A.93
C PPFILE1A.94
C REMEMBER THAT BUFFER OUT STARTS AT ADDRESS 0 THUS IPPLOOK GOES PPFILE1A.95
C FROM 0 to 262143 ie THE NEXT ADDRESS SHOULD BE IWA=262144 to PPFILE1A.96
C IWA=325119 then IWA=325120 to 388095 then 388096 etc PPFILE1A.97
C PPFILE1A.98
C====================================================================== PPFILE1A.99
LENGTH_FULLWRD=64 ! LENGTH IN BITS OF FULLWORD VAR PPFILE1A.100
CL At this point packing,if required,will be done using the WGDOS PPFILE1A.101
CL method of packing. PPFILE1A.102
PACKING_TYPE=0 GO261093.59
C Note the value of -26 corresponds to -15 (F) in ppxref. PPFILE1A.104
C The packing acuracy is scaled to allow greater accuracy. PPFILE1A.105
C Packing will only be attempted if there are at least 2 points per row PPFILE1A.106
C in the PPfield. PPFILE1A.107
C PPFILE1A.108
IF(PACKING.AND.COMP_ACCRCY.GT.-99.AND.N_COLS_OUT.GE.2) APS1F304.4
& PACKING_TYPE=1 GO261093.60
C PPFILE1A.111
IF(PACKING_TYPE.EQ.1)THEN GO261093.61
*IF DEF,PRINT84 PPFILE1A.113
WRITE(6,*)'********* PPOUT PACKING REQD*********** ' GIE0F403.500
*ENDIF PPFILE1A.115
*IF DEF,T3E,AND,DEF,MPP GBCQF405.13
CALL MPP_COEX(PPFIELD,PPHORIZ_OUT,BUFOUT,LENBUF,N_COLS_OUT, GBCQF405.14
& N_ROWS_OUT,NUM_OUT,COMP_ACCRCY,.TRUE.,RMDI, GBCQF405.15
& 1,1,current_io_pe,1) GBCQF405.16
*ELSE GBCQF405.17
CALL COEX(PPFIELD,PPHORIZ_OUT,BUFOUT,LENBUF,N_COLS_OUT, PPFILE1A.116
& N_ROWS_OUT,NUM_OUT,COMP_ACCRCY,.TRUE.,RMDI,LENGTH_FULLWRD) TJ050593.105
*ENDIF GBCQF405.18
PPFILE1A.118
NUM_WORDS=(NUM_OUT+1)/2 ! Round up to the nearest 64 Bit CRAY Wd PPFILE1A.119
C COEX returns the number of IBM words needed to hold the packed data PPFILE1A.120
C ~~~ PPFILE1A.121
LEN_BUF_WORDS=((NUM_WORDS+um_sector_size-1)/um_sector_size)* GBC0F403.58
2 um_sector_size GBC0F403.59
*IF DEF,PRINT84 PPFILE1A.123
WRITE(6,*)'NUM_OUT',NUM_OUT GIE0F403.501
*ENDIF PPFILE1A.125
ELSE ! No packing required. PPFILE1A.126
*IF DEF,PRINT84 PPFILE1A.127
WRITE(6,*)'FROM PPOUT N_ROWS_OUT N_COLS_OUT' GIE0F403.502
WRITE(6,*)N_ROWS_OUT,N_COLS_OUT GIE0F403.503
*ENDIF PPFILE1A.130
DO 1 JJ=1,PPHORIZ_OUT PPFILE1A.131
BUFOUT(JJ) = PPFIELD(JJ) PPFILE1A.132
1 CONTINUE PPFILE1A.133
NUM_WORDS=PPHORIZ_OUT PPFILE1A.134
LEN_BUF_WORDS=LENBUF PPFILE1A.135
ENDIF PPFILE1A.136
*IF DEF,MPP,AND,DEF,T3E GBCQF405.19
if (mype .eq. current_io_pe) then GBCQF405.20
*ENDIF GBCQF405.21
DO JJ=NUM_WORDS+1,LEN_BUF_WORDS PPFILE1A.137
BUFOUT(JJ)= 0.0 PPFILE1A.138
ENDDO PPFILE1A.139
*IF -DEF,MPP GPB1F402.658
CALL SETPOS(UNITPP,IWA,ICODE) GTD0F400.114
CALL BUFFOUT(UNITPP,BUFOUT(1),LEN_BUF_WORDS,LEN_IO,IX) PPFILE1A.141
*ELSE GPB1F402.659
CALL SETPOS_single(UNITPP,IWA,ICODE) GPB1F402.660
CALL BUFFOUT_single(UNITPP,BUFOUT(1),LEN_BUF_WORDS,LEN_IO,IX) GPB1F402.661
*ENDIF GPB1F402.662
C WRITE(6,102) IWA,LEN_BUF_WORDS PPFILE1A.142
100 FORMAT(//,32X,' ARRAY BUFOUT AT END OF PPOUT ',//,32(10F8.0/)) PPFILE1A.143
102 FORMAT(' FROM PP_FILE IWA LEN_BUF_WORDS ',2I12) PPFILE1A.144
C GBC3F404.11
IF (IX.NE.-1.0.OR.LEN_IO.NE.LEN_BUF_WORDS) THEN GBC3F404.12
CALL IOERROR('Buffer out Data Field',IX,LEN_IO, GBC3F404.13
& LEN_BUF_WORDS) GBC3F404.14
CMESSAGE='PPFILE : I/O error - PP Data Field Output' GBC3F404.15
ICODE=7 GBC3F404.16
RETURN GBC3F404.17
ENDIF GBC3F404.18
*IF DEF,MPP,AND,DEF,T3E GBCQF405.22
endif ! (mype .eq. current_io_pe) GBCQF405.23
*ENDIF GBCQF405.24
999 CONTINUE PPFILE1A.145
RETURN PPFILE1A.146
END PPFILE1A.147
*ENDIF PPFILE1A.148