*IF DEF,C84_1A,OR,DEF,FLDOP UIE3F404.18
C ******************************COPYRIGHT****************************** GTS2F400.3421
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.3422
C GTS2F400.3423
C Use, duplication or disclosure of this code is subject to the GTS2F400.3424
C restrictions as set forth in the contract. GTS2F400.3425
C GTS2F400.3426
C Meteorological Office GTS2F400.3427
C London Road GTS2F400.3428
C BRACKNELL GTS2F400.3429
C Berkshire UK GTS2F400.3430
C RG12 2SZ GTS2F400.3431
C GTS2F400.3432
C If no contract has been raised with this copy of the code, the use, GTS2F400.3433
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.3434
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.3435
C Modelling at the above address. GTS2F400.3436
C ******************************COPYRIGHT****************************** GTS2F400.3437
C GTS2F400.3438
CLL Routine: GRBWRT------------------------------------------------ GRBWRT1A.3
CLL GRBWRT1A.4
CLL Purpose: This routine acts as an interface between the model and GRBWRT1A.5
CLL GRIB format output routines. GRBWRT1A.6
CLL GRBWRT1A.7
CLL Author: D.M.Goddard Date: 23 December 1993 GRBWRT1A.8
CLL Reviewer: Date of review: GRBWRT1A.9
CLL GRBWRT1A.10
CLL Tested under compiler: cft77 GRBWRT1A.11
CLL Tested under OS version: UNICOS 5.1 GRBWRT1A.12
CLL GRBWRT1A.13
CLL Code version no: 1 Date: 15 October 1993 GRBWRT1A.14
CLL GRBWRT1A.15
CLL Modification History: GRBWRT1A.16
CLL 3.4 11/10/94 : Correct setting of reals in lookup table GRS3F304.335
CLL and add return code and message to PP2GRIB call GRS3F304.336
CLL R A Stratton. GRS3F304.337
! 4.0 10/03/95 : Allow alternative grib packing to be used and GRS3F400.282
! improve error traping. R A Stratton. GRS3F400.283
!LL 4.3 06/02/97 Modify I/O calls for MPP use P.Burton GPB0F403.3013
CLL GRBWRT1A.17
CLL Programming standard: UM Doc Paper 3, version 1 (15/1/90) GRBWRT1A.18
CLL GRBWRT1A.19
CLL Logical components covered: ... GRBWRT1A.20
CLL GRBWRT1A.21
CLL Project task: ... GRBWRT1A.22
CLL GRBWRT1A.23
CLL External documentation: On-line UM document ??? - ?????????? GRBWRT1A.24
CLL GRBWRT1A.25
CLL ------------------------------------------------------------------- GRBWRT1A.26
C*L Interface and arguments: ------------------------------------------ GRBWRT1A.27
SUBROUTINE GRIB_FILE(LEN1_LOOKUP,LEN2_LOOKUP,LOOKUP,RLOOKUP,IENT, 5,5GRBWRT1A.28
& FIELD,PPHORIZ_OUT,LENBUF,NUM_CRAY_WORDS, GRBWRT1A.29
& UNITPP,IWA,GRIB_PACKING,ICODE,CMESSAGE) GRS3F400.284
GRBWRT1A.31
INTEGER GRBWRT1A.32
& LEN1_LOOKUP ! IN first dimension of LOOKUP GRBWRT1A.33
& ,LEN2_LOOKUP ! IN second dimension of LOOKUP GRBWRT1A.34
& ,LENBUF ! IN No of points in output field GRBWRT1A.35
& ,IENT ! IN level indicator for processing LOOKUP. GRBWRT1A.36
& ,IWA ! IN Record number GRBWRT1A.37
& ,PPHORIZ_OUT ! IN GRBWRT1A.38
& ,UNITPP ! IN Output PP unit number GRBWRT1A.39
& ,GRIB_PACKING ! IN Packing profile for grib GRS3F400.285
& ,LEN_FIELD GRBWRT1A.40
& ,ICODE ! OUT Return code GRBWRT1A.41
& ,NUM_CRAY_WORDS ! OUT Number of cray words output in grib GRBWRT1A.42
& ,LOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! Integer lookup headers GRBWRT1A.43
REAL GRBWRT1A.44
& FIELD(PPHORIZ_OUT) ! IN Unpacked output array GRBWRT1A.45
& ,RLOOKUP(LEN1_LOOKUP,LEN2_LOOKUP) ! REAL lookup headers GRBWRT1A.46
CHARACTER GRBWRT1A.47
& CMESSAGE*(*) ! OUT Will contain any error messages GRBWRT1A.48
C GRBWRT1A.49
C LOCAL VARIABLES GRBWRT1A.50
C GRBWRT1A.51
INTEGER GRBWRT1A.52
& ILABEL(45) ! Integer part of LOOKUP for level IENT GRBWRT1A.53
& ,LEN_IO GRBWRT1A.54
& ,IX GRBWRT1A.55
REAL GRBWRT1A.56
& RLABEL(19) ! Real part of LOOKUP for level IENT GRBWRT1A.57
& ,WORK_ARRAY(LENBUF) ! GRIB packed output array GRBWRT1A.58
& ,BUFOUT(LENBUF) ! Output PP BUFFER GRBWRT1A.59
*CALL CLOOKADD 
GRBWRT1A.60
*CALL C_MDI GRBWRT1A.61
GRBWRT1A.62
CL GRBWRT1A.63
CL 1. Fill arrays ILABEL and RLABEL GRBWRT1A.64
CL GRBWRT1A.65
DO J=1,45 GRBWRT1A.66
ILABEL(J)=LOOKUP(J,IENT) GRBWRT1A.67
ENDDO GRBWRT1A.68
DO J=1,19 GRBWRT1A.69
RLABEL(J)=RLOOKUP(J+45,IENT) GRBWRT1A.70
ENDDO GRBWRT1A.71
CL GRBWRT1A.72
CL 2. Convert data to GRIB code GRBWRT1A.73
CL GRBWRT1A.74
CALL PP2GRIB(FIELD,WORK_ARRAY,LENBUF,NUM_CRAY_WORDS,GRIB_PACKING, GRS3F400.286
& ILABEL,RLABEL,ICODE,CMESSAGE) GRS3F304.338
IF (ICODE.NE.0) THEN GRS3F400.287
RETURN GRS3F400.288
ENDIF GRS3F400.289
C WRITE(6,*) NUM_CRAY_WORDS,LENBUF GRS3F304.339
C write(6,*) (ilabel(j),j=1,45) GRS3F304.340
C write(6,*) (rlabel(j),j=1,19) GRS3F304.341
CL GRBWRT1A.80
CL 3. Put coded data into BUFOUT for output GRBWRT1A.81
CL GRBWRT1A.82
DO I=1,NUM_CRAY_WORDS GRBWRT1A.83
BUFOUT(I)=WORK_ARRAY(I) GRBWRT1A.84
ENDDO GRBWRT1A.85
DO I=NUM_CRAY_WORDS+1,LENBUF GRBWRT1A.86
BUFOUT(I)=0.0 GRBWRT1A.87
ENDDO GRBWRT1A.88
CL GRBWRT1A.89
CL 4. Update lookup for this field GRBWRT1A.90
CL GRBWRT1A.91
DO J=1,45 GRBWRT1A.92
LOOKUP(J,IENT)=ILABEL(J) GRBWRT1A.93
ENDDO GRBWRT1A.94
DO J=1,19 GRBWRT1A.95
RLOOKUP(J+45,IENT)=RLABEL(J) GRS3F304.342
ENDDO GRBWRT1A.97
LOOKUP(LBLREC,IENT)=NUM_CRAY_WORDS GRBWRT1A.98
LOOKUP(LBEGIN,IENT)=IWA GRBWRT1A.99
LOOKUP(LBNREC,IENT)=NUM_CRAY_WORDS GRBWRT1A.100
LOOKUP(DATA_TYPE,IENT)=1 GRBWRT1A.101
LOOKUP(NADDR,IENT)=IWA GRBWRT1A.102
CL GRBWRT1A.103
CL 5. Output BUFOUT GRBWRT1A.104
CL GRBWRT1A.105
*IF -DEF,MPP GPB0F403.3014
CALL SETPOS(UNITPP,IWA,ICODE) GTD0F400.82
CALL BUFFOUT(UNITPP,BUFOUT(1),NUM_CRAY_WORDS,LEN_IO,IX) GRBWRT1A.107
*ELSE GPB0F403.3015
CALL SETPOS_single(UNITPP,IWA,ICODE) GPB0F403.3016
CALL BUFFOUT_single(UNITPP,BUFOUT(1),NUM_CRAY_WORDS,LEN_IO,IX) GPB0F403.3017
*ENDIF GPB0F403.3018
RETURN GRBWRT1A.108
END GRBWRT1A.109
*ENDIF GRBWRT1A.110