C **************************** LICENSE START ***********************************
C
C Copyright 2012 ECMWF and INPE. This software is distributed under the terms
C of the Apache License version 2.0. In applying this license, ECMWF does not
C waive the privileges and immunities granted to it by virtue of its status as
C an Intergovernmental Organization or submit itself to any jurisdiction.
C
C ***************************** LICENSE END ************************************

      SUBROUTINE EQPOTT
C
C          COMPUTE EQUIVALENT POTENTIAL TEMPERATURE
C
C        Input:
C          Fieldset of temperature ( and LNSP if model levels)
C          Fieldset of specific or relative humidity
C              (lat/long grid)
C          Indicator for pressure levels or model levels
C
C        Output:
C          Fieldset of equivalent potential temperature (lat/long grid)
C
C        Author:
C          B. Norris,  March 1995
C
      use grib_api
C
      integer cputenv

#ifdef __alpha
      INTEGER*8 IGRIBT,ICNTT,IGRIBQ,ICNTQ,IGRIBP
      INTEGER*8 IGRIBL,ICNTL,IWORD
#endif

      real*8, allocatable :: TEMP(:)
      real*8, allocatable :: QR(:)
      real*8, allocatable :: RLNSP(:)
      real*8, allocatable :: vertCoef(:)

      LOGICAL NLMODLV,LOK,LTQ,LEVEL
      CHARACTER*4 YMODLV
      integer  igrib_id_t, igrib_id_q, igrib_id_p
      LOK=.FALSE.
c
c -------------------------------------------------------------------
c
C     GET FIELDSET OF TEMPERATURE

      CALL mfi_get_fieldset(IGRIBT,ICNTT)

C     TELLS WHETHER PRESSURE OR MODEL LEVELS

      CALL mfi_get_string (YMODLV)
      IF(YMODLV(1:2).EQ.'ml'.OR.YMODLV(1:2).EQ.'ML') THEN
           NLMODLV=.TRUE.
      ELSEIF(YMODLV(1:2).EQ.'pl'.OR.YMODLV(1:2).EQ.'PL') THEN
           NLMODLV=.FALSE.
      !-- elseif?
      ENDIF

C     GET FIELDSET OF HUMIDITY

      CALL mfi_get_fieldset(IGRIBQ,ICNTQ)

C     GET FIELDSET OF LNSP

      IF(NLMODLV) CALL mfi_get_fieldset(IGRIBL,ICNTL)

C     CREATE A NEW FIELDSET

      CALL mfi_new_fieldset(IGRIBP)

      ITCNT=0
      ILCNT=0
      IQCNT=0
c
c -------------------------------------------------------------------
c
C     LOOP ON FIELDS

  100 CONTINUE

C       GET NEXT TEMPERATURE FROM FIELDSET

      ITCNT=ITCNT+1
      IF(ITCNT.GT.ICNTT) GO TO 400

      CALL mfi_load_one_grib(IGRIBT,igrib_id_t)

!     -------------------------------------
!     --  decode temperature field TEMP  --
!     -------------------------------------

      CALL grib_get_int( igrib_id_t, 'gridType', iGridType )
      IF(iGridType.EQ.50) THEN
 	JJ=cputenv
     +	('POTTF_ENV=T DATA REPRESENTATION CAN NOT BE SPECTRAL')
	RETURN
      ENDIF

      CALL grib_get_int( igrib_id_t, 'level', NLVELR )

      CALL grib_get_size( igrib_id_t, 'values', NLATLON )
      allocate( TEMP( NLATLON ) )
      CALL grib_get_real8_array( igrib_id_t, 'values', TEMP )

C       GET NEXT HUMIDITY

      IQCNT=IQCNT+1
      IF(IQCNT.GT.ICNTQ) GO TO 400

      CALL mfi_load_one_grib(IGRIBQ,igrib_id_q)

!     --------------------------------
!     --  decode humidity field QR  --
!     --------------------------------

      CALL grib_get_int( igrib_id_q, 'gridType', iGridType )
      IF(iGridType.EQ.50) THEN
 	JJ=cputenv
     +	('POTTF_ENV=Q DATA REPRESENTATION CAN NOT BE SPECTRAL')
	RETURN
      ENDIF

      CALL grib_get_int( igrib_id_q, 'paramId', ICODE )
      LEVEL=.TRUE.

      CALL TLVALID ( igrib_id_t, igrib_id_q,
     X               LEVEL, LTQ)
      IF (.NOT.LTQ) THEN
	RETURN
      ENDIF

      CALL grib_get_size( igrib_id_q, 'values', NLATLON )
      allocate( QR( NLATLON ) )
      CALL grib_get_real8_array( igrib_id_q, 'values', QR )

C       GET NEXT LNSP FROM FIELDSET

  200 CONTINUE
      IF(NLMODLV.AND..NOT.LOK) THEN
         ILCNT=ILCNT+1
         IF(ILCNT.GT.ICNTL) GO TO 400

         CALL mfi_load_one_grib(IGRIBL,igrib_id_p)

!        -------------------------------
!        --  decode lnsp field RLNSP  --
!        -------------------------------

         CALL grib_get_int( igrib_id_p,
     x               'numberOfVerticalCoordinateValues', ILENV1 )
         allocate( vertCoef( ILENV1 ) )
         CALL grib_get_real8_array( igrib_id_p, 'pv', vertCoef )

         CALL grib_get_size( igrib_id_p, 'values', NLATLON )
         allocate( RLNSP( NLATLON ) )
         CALL grib_get_real8_array( igrib_id_p, 'values', RLNSP )
      ENDIF

C           CHECK LNSP CONSISTENT IF MODEL LEVELS

      IF(NLMODLV) THEN
         LEVEL=.FALSE.

         CALL TLVALID (igrib_id_p,igrib_id_t,
     X                 LEVEL,LOK)
         IF(LOK) THEN
              GO TO 300
         ELSE
              GO TO 200
         ENDIF
      ENDIF
  300 CONTINUE

c --------------------------------------------------------------------

C           COMPUTE EQUIVALENT POTENTIAL TEMPERATURE

      CALL grib_get_int( igrib_id_t, 'dataDate', IDATE )
C
      CALL EQUIVT (TEMP,QR,RLNSP,ICODE,NLMODLV,NLVELR,IDATE,NLATLON,
     X             vertCoef,ILENV1,IERROR)
      IF(IERROR.NE.0) RETURN

      CALL grib_set_int( igrib_id_t, 'paramId', 4 )

      TMIN=1.0E10
      TMAX=-1.0E10
      DO 302 KD=1,NLATLON
      IF(TEMP(KD).LT.TMIN) TMIN=TEMP(KD)
      IF(TEMP(KD).GT.TMAX) TMAX=TEMP(KD)
  302 CONTINUE
      WRITE (*,*) ' TMIN ',TMIN,' TMAX ',TMAX

!     -- encode the computed field TEMP --

      CALL grib_set_real8_array( igrib_id_t, 'values', TEMP )

C          ADD TO FIELDSET

      CALL mfi_save_grib(IGRIBP,igrib_id_t)

      deallocate( TEMP )
      deallocate( QR )

      GO TO 100

c --------------------------------------------------------------------

  400 CONTINUE


      IF(NLMODLV) deallocate( RLNSP )

C     SET RESULT
      CALL mfi_return_fieldset(IGRIBP)

C      WRITE (*,'(A)') '  END OF EQPOTT '

      RETURN
      END

c CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE EQUIVT(T,QR,PS,IFQR,NLMODLV,NLVELR,IDATE,NLATLON,
     +                   FVERTB,NVERT,IERROR)
C
C     THIS SUBROUTINE CALCULATES THE EQUIVALENT POTENTIAL TEMPERATURE
C     FROM THE TEMPERATURE AND RELATIVE HUMIDITY OR SPECIFIC HUMIDITY
C     ON PRESSURE LEVELS.
C     THE VALUE FOR CI IS FROM MARTIN MILLER & ALAN BETTS
C
C     T         : TEMPERATURE
C     QR    	: RELATIVE/SPECIFIC HUMIDITY
C     PS    	: LOG SURFACE PRESSURE
C     IFQR  	: 133 - SPECIFIC HUMIDITY, 157 -  RELATIVE HUMIDITY
C     NLMODLV   : T - MODEL LEVELS, F - PRESSURE LEVELS
C     NLVELR    : LEVEL
C     DATE  	: DATE (YYYYMMDDHH)
C     NLATLON   : GRID POINTS (LAT X LON)
C     FVERTB    : VERTICAL COORDINATE ARRAY
C     NVERT     : LENGTH OF THE DATA IN THE ARRAY FVERTB
C     IERROR    : 0 - SUCCESSFUL, 1 - ERROR
C
      DIMENSION T(*),QR(*),PS(*),FVERTB(*)
      LOGICAL NLMODLV,ILOLDM
      REAL SSHM,PML

      integer cputenv

      CI=2710.
      RD=287.05
      CP=1005.46

      IERROR = 0
      ILOLDM = .FALSE.
      IF(IDATE.LT.19830421) ILOLDM = .TRUE.

      DO 1 J=1,NLATLON
         IF (NLMODLV) THEN
            PMB = PML(PS(J),NLVELR,FVERTB,NVERT)*.01
         ELSE
            PMB = FLOAT(NLVELR)
         ENDIF

C        CALCULATE THE SATURATION SPECIFIC HUMIDITY
         SATHUM = SSHM(T(J),PMB,ILOLDM)

         IF(IFQR.EQ.133) THEN
            SPCHM = QR(J)
         ELSEIF(IFQR.EQ.157) THEN
C           CALCULATE THE SPECIFIC HUMIDITY
            SPCHM = SATHUM*QR(J)*.01
         ELSE
	    JJ=cputenv('POTTF_ENV=FIELDS Q OR R NOT FOUND')
	    IERROR=1
	    RETURN
         ENDIF

C        CALCULATE THE SATURATION POINT VALUES OF T,PMB : TS,PMBS
         CALL SATPNT(PMB,T(J),SPCHM,PMBS,TS,DP,ILOLDM,IERROR)
	 IF(IERROR.NE.0) RETURN

C        CALCULATE THE SATURATION SPECIFIC HUMIDITY AT TS,PMBS
         SATHUM = SSHM(TS,PMBS,ILOLDM)

C        CALCULATE THE EQUIVALENT POTENTIAL TEMPERATURE
         T(J) = TS*((1000./PMBS)**(RD/CP))*EXP(SATHUM*CI/TS)

 1    CONTINUE

      RETURN
      END

c CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE SATPNT(ZPK,ZTK,ZQK,ZPSL,ZTSL,ZDP,ILOLDM,IERROR)
C
C     **** COMPUTES SATURATION LEVEL PARAMETERS FROM T,P,Q
C     **** PARAMETERS ARE P AND T AT SAT.LEVEL AND ZDP=ZPK-ZPSL
C     **** UNITS ARE KELVIN,GM/GM,MBS.
C
      LOGICAL ILOLDM

      integer cputenv

C
      IERROR=0
      RAIR=287.05
      CPAIR=1005.46
      KOUNT=0
      IF(ZQK.LT.0.000002.AND.ZPK.GT.100.) ZQK=0.000002
      ZPTEST=ZPK*0.2
      ZPSL=ZPK*0.98

  300 CONTINUE
      ZTSL=ZTK*(ZPSL/ZPK)**(RAIR/CPAIR)
      ZQL = SSHM(ZTSL,ZPSL,ILOLDM)
      ZTSM=ZTK*((ZPSL-1.)/ZPK)**(RAIR/CPAIR)
      ZQM = SSHM(ZTSM,ZPSL-1.,ILOLDM)
      ZDELPL=(ZQL-ZQK)/(ZQL-ZQM)
      ZDP=ZPK-ZPSL
      IF(ABS(ZDELPL).LT.1.0) GOTO 400
      ZPSL=ZPSL-ZDELPL
      IF(ZPSL.LT.ZPTEST) GO TO 305
      KOUNT=KOUNT+1
      IF(KOUNT.GT.20)GO TO 304
      GO TO 300

  304 CONTINUE
      JJ=cputenv('POTTF_ENV=ITERATION FAILED IN SATPNT')
      IERROR=1
      RETURN
  305 CONTINUE
      ZPSL=ZPSL+ZDELPL

  400 CONTINUE

      RETURN
      END
