C comp5d.F
C
C VIS-5D version 2  compressed grid file maker.
C
C This program will make a compressed grid file.  It will contain
C no trajectory or polygons save/restore information.
C
C
C
      SUBROUTINE MAIN0
C-----FOREGROUND KEYIN COMP5D
C ? NAME
C ?    comp5d - create a compressed grid file
C ?
C ? SYNOPSIS
C ?    comp5d igr3df ngr3df gridfile [options]
C ?
C ? DESCRIPTION
C ?    Create a compressed grid file named 'gridfile' from the 'ngr3df'
C ?    grid file(s) starting with grid number 'igr3df'.
C ?
C ? OPTIONS
C ?    -wind (u, v, w, spd, ver, none)  specifies which combination of
C ?                                     of wind variables to include
C ?
C ? EXAMPLE
C ?    comp5d 2 1 COMPLAMP -wind spd ver
C ?       Create the compressed grid file named COMPLAMP from grid
C ?       GR3D0002 using the U, V, and W variables to produce variables
C ?       SPD and VER in COMPLAMP.
C LOOKING FOR 'U   ', 'V   ', ETC
C
C REARRANGE GRIDS
      include "vis5d.h"
      CHARACTER*12 CFILE,CPP
C
      INTEGER KPARM(NPARM),LPARM(NPARM)
      COMMON/JTIME/NTIMES,NPARMS,MR,MC,ML,
     *XLATN,XLONW,XHGTT,XLATIN,XLONIN,XHGTIN,
     *JDAY(NTIME),JTIME(NTIME),JPARM(NPARM)
      COMMON/NGRID/IGRIDF,NGRIDF,NGRID(NFILE)
C
      IGRIDF=IPP(1,IGCF3D(0))
      NGRIDF=IPP(2,1)
C
      CALL GET5D
      MRMCML=MR*MC*ML
      CALL LDEST('MRMCML ',MRMCML)
      CALL COMPAL(MRMCML)
      RETURN
      END
C
C
C
C
      SUBROUTINE COMPRS(GRIDK,GRIDL,IGRID)
      include "vis5d.h"
      CHARACTER*12 CFILE,CPP,CKWP
      REAL*4 GRIDK(*),GRIDL(*)
      INTEGER*1 IGRID(*)
      COMMON/GRID/GA,GB
C
      INTEGER KPARM(NPARM),LPARM(NPARM)
      COMMON/JTIME/NTIMES,NPARMS,MR,MC,ML,
     *  XLATN,XLONW,XHGTT,XLATIN,XLONIN,XHGTIN,
     *  JDAY(NTIME),JTIME(NTIME),JPARM(NPARM)
      COMMON/NGRID/IGRIDF,NGRIDF,NGRID(NFILE)
C
      CFILE=CPP(3,'COMPGRID')
C
      MRMCML=MR*MC*ML
      CALL NEWIND(NPARMI,KPARM,LPARM)
C
      IWORD=1
      NHEAD=11+2*NTIME+NPARM
      NWORD=2+(MRMCML+3)/4
C WRITE HEADER TO COMPRESSED GRID FILE
      CALL LWO(CFILE,IWORD,NHEAD,NTIMES)
      IWORD=IWORD+NHEAD
c     write 0x80808081 ID indicating 400 times, 30 parms
      id = '80808081'X
      call lwo(cfile, 0, 1, id )

C LOOP FOR TIMES
      DO 60 IT=1,NTIMES
C LOOP FOR PARAMS
      DO 50 IP=1,NPARMS
      IPK=KPARM(IP)
      CALL GETGRD(IT,IPK,NPARMI,GRIDK,MRMCML)
      IPL=LPARM(IP)
      IF(IPL .EQ. 0) GO TO 20
C READ V AND CALCULATE HORIZONTAL SPEED
      CALL GETGRD(IT,IPL,NPARMI,GRIDL,MRMCML)
      CALL LDEST('SPD ',MRMCML)
      DO 10 I=1,MRMCML
      GU=GRIDK(I)
      GV=GRIDL(I)
      IF(GU .GT. 1.E30 .OR. GV .GT. 1.E30) THEN
        GRIDK(I)=1.E35
      ELSE
        GRIDK(I)=SQRT(GU*GU+GV*GV)
      ENDIF
10    CONTINUE
C FIND MIN AND MAX OF GRID
20    GMAX=-1000000000.0
      GMIN=1000000000.0
      DO 30 I=1,MRMCML
      IF(GRIDK(I) .LE. 1.E30) THEN
        IF(GRIDK(I) .GT. GMAX) GMAX=GRIDK(I)
        IF(GRIDK(I) .LT. GMIN) GMIN=GRIDK(I)
      ENDIF
30    CONTINUE
C USE MIN AND MAX TO GET SCALING PARAMETERS
      GG=GMAX-GMIN
      IF(GG .LT. 0.000000001) GG=0.000000001
      GA=250.0/GG
      GB=-GA*(GMAX+GMIN)/2.0
C SCALE REAL GRID TO ONE BYTE INTEGERS
      DO 40 I=1,MRMCML
      IF(GRIDK(I) .GT. 1.E30) THEN
        IGRID(I)=127
      ELSE
        IGRID(I)=GA*GRIDK(I)+GB
      ENDIF
40    CONTINUE
      GNUM=GNUM+1.0
      CALL ROUT('GMIN',GMIN,GMAX,GA,GB,0.0,0.0)
C WRITE GRID
      CALL LWO(CFILE,IWORD,2,GA)
      CALL LWO(CFILE,IWORD+2,NWORD-2,IGRID)
      IWORD=IWORD+NWORD
50    CONTINUE
60    CONTINUE
C
      RETURN
      END
C
C
C
C
      SUBROUTINE NEWIND(NPARMI,KPARM,LPARM)
      include "vis5d.h"
      INTEGER KPARM(NPARM),LPARM(NPARM)
      CHARACTER*4 CLIT,CWIND(5)
      CHARACTER*12 CKWP
      INTEGER JU(5),KU(5)
      COMMON/JTIME/NTIMES,NPARMS,MR,MC,ML,
     *  XLATN,XLONW,XHGTT,XLATIN,XLONIN,XHGTIN,
     *  JDAY(NTIME),JTIME(NTIME),JPARM(NPARM)
      COMMON/NGRID/IGRIDF,NGRIDF,NGRID(NFILE)
      DATA CWIND/'U   ','V   ','W   ','VER ','SPD '/
C
      NWIND=NKWP('WIND')
      CALL LDEST('NWIND = ',NWIND)
      IF(NWIND .GT. 0) GO TO 10
      NPARMI=NPARMS
      DO 5 I=1,NPARMS
      KPARM(I)=I
5     LPARM(I)=0
      RETURN
10    DO 15 I=1,5
      JU(I)=0
15    KU(I)=0
C MARK REQUESTED WIND PARAMS
      DO 20 I=1,NWIND
      DO 20 J=1,5
      IF(CKWP('WIND',I,' ') .EQ. CWIND(J)) JU(J)=1
20    CONTINUE
C CANNOT HAVE BOTH VER AND W
      IF(JU(4) .EQ. 1) JU(3)=0
C DELETE AND RECORD WIND PARAMS FROM INPUT LIST
      II=1
      DO 40 I=1,NPARMS
      DO 30 J=1,5
      IF(CLIT(JPARM(I)) .NE. CWIND(J)) GO TO 30
      KU(J)=I
      GO TO 40
30    CONTINUE
      JPARM(II)=JPARM(I)
      KPARM(II)=I
      LPARM(II)=0
      II=II+1
40    CONTINUE
C APPEND REQUESTED WIND PARAMS TO LIST
C  AND RECORD SOURCE FROM INPUT
      DO 50 J=1,5
      IF(JU(J) .EQ. 0) GO TO 50
      JPARM(II)=LIT(CWIND(J))
      IF(J .LE. 2) THEN
        IF(KU(J) .EQ. 0) GO TO 99
        KPARM(II)=KU(J)
        LPARM(II)=0
      ELSE IF(J .LE. 4) THEN
        IF(KU(3) .NE. 0) THEN
          KPARM(II)=KU(3)
        ELSE IF(KU(4) .NE. 0) THEN
          KPARM(II)=KU(4)
        ELSE
          GO TO 99
        END IF
        LPARM(II)=0
      ELSE
        IF(KU(1) .EQ. 0 .OR. KU(2) .EQ. 0) GO TO 99
        KPARM(II)=KU(1)
        LPARM(II)=KU(2)
      END IF
      II=II+1
50    CONTINUE
      NPARMI=NPARMS
      NPARMS=II-1
      CALL LDEST('NEWPARM = ',NPARMS)
      DO 80 I=1,NPARMS
80    CALL LDEST(CLIT(JPARM(I)),I)
      RETURN
99    CALL SDEST('REQUESTED WIND DATA NOT PRESENT ',0)
      CALL EXIT(0)
      END
