	SUBROUTINE AF_ATBX  ( istart, maxsc, dgotin, dgot, fqot, tpot,
     +			      iret )
C************************************************************************
C* AF_ATBX								*
C*									*
C* This subroutine checks the syntax and then optionally decodes an     *
C* expanded turbulence definition from an AIREP report. 	 	*
C*									*
C* AF_ATBX ( ISTART, MAXSC, DGOTIN, DGOT, FQOT, TPOT, IRET )            *
C*									*
C* Input parameters:							*
C*	ISTART		INTEGER	     Index of starting "like-type" group*
C*	MAXSC 		INTEGER	     No. of "like-type" groups to check *
C*	DGOTIN		REAL	     Degree of turbulence already found *
C*									*
C* Output parameters:							*
C*	DGOT		REAL	     Degree of turbulence 		*
C*	FQOT		REAL	     Frequency of turbulence		*
C*	TPOT		REAL	     Type of turbulence 		*
C*	IRET		INTEGER	     Return code 			*
C*				       0 = normal return 		*
C*				      -1 = no turbulence data found     *
C*									*
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 2/00	                                        *
C* J. Wu/GSC             7/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	LOGICAL		chkfrq, done
C*
	PARAMETER	( NTPIDS = 4 )
	CHARACTER	tpids ( NTPIDS )*4
C*
	PARAMETER	( NFQIDS = 12 )
	CHARACTER	fqids ( NFQIDS )*3
	INCLUDE		'ERMISS.FNC'
	INCLUDE		'affnc.fnc'
C*
	DATA		tpids
     +			/ 'CAT ', 'CHOP', 'LLWS', 'CHP ' /
C*
	DATA		fqids
     +			/ 'CON', 'STE', 'CNT', 'STD', 'CNS', 'INT',
     +			  'OCN', 'OCA', 'OCC', 'OCS', 'ONC', 'ISO' /
C*
C-----------------------------------------------------------------------
	iret  = 0
	isdx  = istart
	dgot  = RMISSD
	fqot  = RMISSD
	tpot  = RMISSD
	dgot2 = RMISSD
C
	IF ( .not. ERMISS ( dgotin ) ) isdx = isdx + 1
C
	maxii  = IEDX ( isdx, maxsc, nflds )
	dgot1  = dgotin
	chkfrq = .false.
	done   = .false.
	ii     = isdx
	IF ( ii .gt. maxii )  done = .true.
C
C*	Parse the syntax of the turbulence definition.
C
	DO WHILE ( .not. done )
C
C*	    Check for a frequency indicator.
C
	    CALL ST_FIND ( fields ( ii ) (:3), fqids, NFQIDS, jfq, ier )
	    IF ( ( jfq .gt. 0 ) .and. ( ERMISS ( fqot ) ) ) THEN
C
C*		Get the frequency of turbulence.
C
		IF ( jfq .le. 5 ) THEN
		    fqot = 3.
		  ELSE IF ( jfq .le. 6 ) THEN
		    fqot = 2.
		  ELSE
		    fqot = 1.
		END IF
		IF ( ( .not. ERMISS ( dgot1 ) ) .and.
     +		     ( ERMISS ( dgot2 ) ) )  chkfrq = .true.
	      ELSE
C
C*		Check for an intensity indicator.
C
		CALL AF_TBID ( fields (ii) (:lensf (ii)), dgotqq, ier )
		IF ( .not. ERMISS ( dgotqq ) ) THEN
		    IF ( ERMISS ( dgot1 ) ) THEN
			dgot1 = dgotqq
		      ELSE
			IF ( ERMISS ( dgot2 ) ) dgot2 = dgotqq
		    END IF
		  ELSE
C
C*		    Check for a type indicator.
C
		    CALL ST_FIND ( fields ( ii ) (:4), tpids, NTPIDS,
     +				   jtp, ier )
		    IF ( ( jtp .gt. 0 ) .and. ( ERMISS ( tpot ) ) ) THEN
C
C*			Get the type of turbulence.
C
			IF ( jtp .eq. 4 )  jtp = 2
			tpot = FLOAT ( jtp )
		    END IF
		END IF
	    END IF
C
	    IF ( ( ii .eq. maxii ) .or.
     +		 ( fields ( ii ) (:2) .eq. 'IC' ) .or.
     +		 ( fields ( ii ) (:2) .eq. 'WX' ) .or.
     +		 ( fields ( ii ) (:3) .eq. 'MID' ) )  THEN
		done = .true.
	      ELSE
		ii = ii + 1
	    END IF
	END DO
C
C*	Check to see if there is a range of intensities.
C
	IF ( ( .not. ERMISS ( dgot1 ) ) .and.
     +	     ( .not. ERMISS ( dgot2 ) ) ) THEN
	    dgot = NINT ( dgot1 + dgot2 ) / 2
	    IF ( NINT ( dgot ) .eq. 7 ) THEN
	        dgot = 8.
	      ELSE IF ( NINT ( dgot ) .eq. 1 ) THEN
		dgot = 2.
	    END IF
C
C*	    If frequency indicator only applies to second intensity,
C*	    drop it.
C
            IF ( chkfrq )  fqot = RMISSD
	  ELSE
	    dgot = dgot1
	END IF
C
	IF ( ERMISS ( dgot ) .and. ERMISS ( fqot ) .and.
     +	     ERMISS ( tpot ) ) iret = -1
C*
	RETURN
	END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine getdesiinfo(set,istartset,iendset,ialset,nset,
     &  mi,nactdof,ndesi,nodedesi,ntie,tieset,itmp,nmpc,nodempc,
     &  ipompc)
!
!     reading the input deck: *DESIGNVARIABLES
!
      implicit none
!
      character*81 setname
      character*81 set(*)
      character*81 tieset(3,*)
!
      integer mi(*),istartset(*),iendset(*),ialset(*),ndesi,
     &  node,nodedesi(*),nset,ntie,i,j,k,l,nmpc,nodempc(3,*),
     &  nactdof(0:mi(2),*),itmp(*),ntmp,index,id,ipompc(*)
!
      setname(1:1)=' '
      ndesi=0
!
!     Search for the set name
!
      do i=1,ntie
         if(tieset(1,i)(81:81).eq.'D') then
            setname=tieset(2,i)
         endif
      enddo
!
!     Check for the existence of the name
!
      if(setname(1:1).eq.' ') then
        write(*,*) '*ERROR in getdesiinfo: name of node set '
        write(*,*) '  has not yet been defined. '
        call exit(201)
      endif
!
!     catalogue all nodes (dependent and independent) which
!     belong to MPC's
!
      ntmp=0
      do i=1,nmpc
         index=ipompc(i)
         do
            if(index.eq.0) exit
            node=nodempc(1,index)
            call nident(itmp,node,ntmp,id)
            if(id.gt.0) then
               if(itmp(id).eq.node) then
                  index=nodempc(3,index)
                  cycle
               endif
            endif
            ntmp=ntmp+1
            do j=ntmp,id+2,-1
               itmp(j)=itmp(j-1)
            enddo
            itmp(id+1)=node
            index=nodempc(3,index)
         enddo
      enddo
!
!     Search the name of the node set in "set(i)" and
!     assign the nodes of the set to the appropriate variables
!
      do i=1,nset
         if(setname.eq.set(i)) then
            loop1: do j=istartset(i),iendset(i)
               if(ialset(j).gt.0) then
                  node=ialset(j)
!
!                 check for SPC-constraints: if a node is constrained in all dofs
!                 it is removed from the design node set
!
                  do l=1,3
c                     if(nactdof(l,node).le.0) cycle loop1
                     if(nactdof(l,node).gt.0) exit
                     if(l.eq.3) then
                        write(*,*) '*WARNING in getdesiinfo:'
                        write(*,*) '         node ',node,' has no'
                        write(*,*) '         active dofs and'
                        write(*,*) '         is removed from the set'
                        write(*,*) '         of design variables'
                        cycle loop1
                     endif
                  enddo
!
!                 check for MPC-constraints
!
                  call nident(itmp,node,ntmp,id)
                  if(id.gt.0) then
                     if(itmp(id).eq.node) then
                        write(*,*) '*WARNING in getdesiinfo:'
                        write(*,*) '         node ',node,' is subject'
                        write(*,*) '         to MPC-constraints and'
                        write(*,*) '         is removed from the set'
                        write(*,*) '         of design variables'
                        cycle loop1
                     endif
                  endif
!
                  ndesi=ndesi+1
                  nodedesi(ndesi)=node
               else
                  k=ialset(j-2)
                  loop2: do
                     k=k-ialset(j)
                     if(k.ge.ialset(j-1)) exit
!
!                 check for SPC-constraints: if a node is constrained in all dofs
!                 it is removed from the design node set
!
                     do l=1,3
                        if(nactdof(l,k).gt.0) exit
                        if(l.eq.3) then
                           write(*,*) '*WARNING in getdesiinfo:'
                           write(*,*) '         node ',k,' has no'
                           write(*,*) '         active dofs and'
                           write(*,*) '         is removed from the set'
                           write(*,*) '         of design variables'
                           cycle loop2
                        endif
                     enddo
!
!                 check for MPC-constraints
!
                     call nident(itmp,k,ntmp,id)
                     if(id.gt.0) then
                        if(itmp(id).eq.k) then
                           write(*,*) '*WARNING in getdesiinfo:'
                           write(*,*) '         node ',k,' is subject'
                           write(*,*) '         to MPC-constraints and'
                           write(*,*) '         is removed from the set'
                           write(*,*) '         of design variables'
                           cycle loop2
                        endif
                     endif
!
                     ndesi=ndesi+1
                     nodedesi(ndesi)=k
                  enddo loop2
               endif
            enddo loop1
         endif
      enddo
!
      return
      end


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!      NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3   !
!-----------------------------------------------------------------------
!BOP
!
! !MODULE:  m_errtbl --- routines to read and assign NCEP obs errors
!
! !INTERFACE:
!

      module  m_errtbl

! !USES:

      use m_ioutil, only : luavail
      use m_die

      implicit none

! !DESCRIPTION:
!
!    collection of routines to read the NCEP obs error table and
!    return obs error values for various obs types
!
! !REVISION HISTORY:
!
!  27Apr2004   Meta    Initial code
!
!EOP
!-------------------------------------------------------------------------

      private
      public :: init_etable, getoe

      real(8) :: missing = 10.e10

      real       ERRS(300,33,6)

      CONTAINS

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!      NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3   !
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_etable ---  open error table file and read in data
!
! !INTERFACE:

      subroutine init_etable(tablefile)    !  optional

! !USES:

      implicit none

! !INPUT PARAMETERS

      character(len=*), optional :: tablefile ! BUFR table file

! !DESCRIPTION:
!
!    Open user specified file, and read data into error array
!
! !REVISION HISTORY:
!
!  27Apr2004   Meta    Initial code (from GBLEVN01)
!
!EOP
!-------------------------------------------------------------------------

      character(len=200) errtable
      integer             iunite
      integer             irec
      integer             kx
      integer k, m

      if (present(tablefile)) then
         errtable = tablefile
      else
         errtable="prepobs_errtable.global"
      endif

! find unit numbers for files
      iunite = luavail()
      open(unit=iunite,file=errtable,action='read')

      REWIND IUNITE

      IREC = 0

   10 CONTINUE
      READ(IUNITE,'(1X,I3)',END=100) KX
      IREC = IREC + 1
      DO K=1,33
         READ(IUNITE,'(1X,6E12.5)') (ERRS(KX,K,M),M=1,6)
      ENDDO
      GO TO 10

  100 CONTINUE
      IF(IREC.EQ.0) THEN
         call die('etable', 'OBS. ERROR TABLE EMPTY OR DOES NOT EXIST', 60)
      END IF

      close(iunite)

      RETURN

      end subroutine init_etable

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!      NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3   !
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: getoe ---  get obs error for a report
!
! !INTERFACE:

      subroutine getoe(pob,cat,typ,poe,
     &          qoe, toe, woe, pwe)

! !USES:

      implicit none

! !INPUT PARAMETERS

      real                pob               ! observation pressure
      real                cat               ! data category
      real                typ               ! obs report type

! !OUTPUT PARAMETERS
      real                poe               ! pressure obs error
      real, optional ::   qoe               ! spec. hum. obs error
      real, optional ::   toe               ! temperature obs error
      real, optional ::   woe               ! wind obs error
      real, optional ::   pwe               ! precip. water obs error

! !DESCRIPTION:
!
!   Get obs errors for different data types at the specified pressure level
!
! !REVISION HISTORY:
!
!  27Apr2004   Meta    Initial code adapted from gblevents
!
!EOP
!-------------------------------------------------------------------------

      poe = missing
      if (cat .eq. 0)  poe = OEFG01(POB,TYP,5)

      if (present(qoe)) qoe = OEFG01(POB,TYP,3)     ! specific humidity
      if (present(toe)) toe = OEFG01(POB,TYP,2)     ! temperature
      if (present(woe)) woe = OEFG01(POB,TYP,4)     ! wind
      if (present(pwe)) pwe = OEFG01(POB,TYP,6)     ! precipitable water

      return

      end subroutine getoe

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!      NASA/GSFC, Global Modeling and Assimilation Office, Code 900.3   !
!-----------------------------------------------------------------------
!BOP
!
! !IROUTINE: oefg01 ---  look up errors for ob types
!
! !INTERFACE:

      real FUNCTION OEFG01(P,TYP,IE) ! FORMERLY FUNCTION OEF

! !USES
      implicit none

! !INPUT PARAMETERS
      real           p        ! pressure level
      real           typ      ! report type
      integer        ie       ! ob type

! !DESCRIPTION:
!
!   Look up errors for particular obs types using NCEP code.
!
! !REVISION HISTORY:
!
!  27Apr2004   Meta    Initial code adapted from gblevents
!
!EOP
!-------------------------------------------------------------------------
      integer     kx           ! integer obs type
      integer     la           ! loop value (level above)
      integer     lb           ! level below
      real        del          ! weight

      OEFG01 = missing
      KX  = TYP

C  LOOK UP ERRORS FOR PARTICULAR OB TYPES
C  --------------------------------------

      IF(IE.GE.2 .AND. IE.LE.4) THEN
         DO LA=1,33
            IF(P.GE.ERRS(KX,LA,1)) GOTO 10
         ENDDO
   10    CONTINUE
         LB = LA-1
         IF(LB.EQ.33) LA = 6
         IF(LB.EQ.33) LB = 5
         IF(LB.EQ. 0) THEN
            OEFG01 = ERRS(KX,1,IE)
         ELSE
            DEL = (P-ERRS(KX,LB,1))/(ERRS(KX,LA,1)-ERRS(KX,LB,1))
            OEFG01 = (1.-DEL)*ERRS(KX,LB,IE) + DEL*ERRS(KX,LA,IE)
         ENDIF
      ELSEIF(IE.EQ.5) THEN
         OEFG01 = ERRS(KX,1,5)
      ELSEIF(IE.EQ.6) THEN
         OEFG01 = ERRS(KX,1,6)
      ENDIF

C  SET MISSING ERROR VALUE TO 10E10
C  --------------------------------

      IF(OEFG01.GE.5E5) OEFG01 = missing

      RETURN
      END function oefg01

      end module m_errtbl


!------------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in           !
!  continuous development by various groups and is based on information        !
!  from these groups: Federal Government employees, contractors working        !
!  within a United States Government contract, and non-Federal sources         !
!  including research institutions.  These groups give the Government          !
!  permission to use, prepare derivative works of, and distribute copies       !
!  of their work in the CMAQ system to the public and to permit others         !
!  to do so.  The United States Environmental Protection Agency                !
!  therefore grants similar permission to use the CMAQ system software,        !
!  but users are requested to provide copies of derivative works or            !
!  products designed to operate in the CMAQ system to the United States        !
!  Government without restrictions as to use by others.  Software              !
!  that is used with the CMAQ system but distributed under the GNU             !
!  General Public License or the GNU Lesser General Public License is          !
!  subject to their copyright restrictions.                                    !
!------------------------------------------------------------------------------!

SUBROUTINE setgriddefs

!-------------------------------------------------------------------------------
! Name:     Set Grid Definitions
! Purpose:  Gets information from user input and input meteorology, and
!           sets up grid definitions.
! Notes:    Some algorithms taken from MCIP v1 getmet_mm5.F.
! Revised:  20 Sep 2001  Original version.  (T. Otte)
!           16 Oct 2001  Added variable COORDNAM.  Corrected definition
!                        of P_GAM_GD.  Added provisions for windowing a
!                        subset of the meteorology domain.  (T. Otte)
!           20 Nov 2001  Corrected setting of XORIG_GD and YORIG_GD.  (T. Otte)
!           10 Jan 2002  Changed calls to "abort" to calls to "m3exit" for
!                        graceful shut-down of I/O API files.  (T. Otte)
!           27 Feb 2002  Removed minimum grid size on windows.  (T. Otte)
!           06 Mar 2003  Modified definitions of XORIG_GD and Y0RIG_GD to
!                        minimize real number round-off issues which can
!                        cause header mismatches in CMAQ.  Added double
!                        precision attributes to variables assigned to
!                        I/O API header.  (T. Otte)
!           10 Aug 2004  Added new grid projections.  Moved definition of
!                        PX to setupv2 and setupv3.  Added T2OUT.  Removed
!                        checks from obsolete land-use input sources. (T. Otte)
!           24 Feb 2005  Removed NDX and option to interpolate to finer scale
!                        meteorology.  Changed I and J naming conventions to
!                        Y and X to make code more general.  Added vertical
!                        coordinate definition for WRF.  Modified prints of
!                        user options to reflect new LDDEP = 3 or 4 for dry
!                        deposition velocity calculations of chlorine and
!                        mercury species with M3DRY.  Added calculation of
!                        XORIG and YORIG for WRF grid definitions.  Added logic
!                        to make center latitude more precise for WRF. (T. Otte)
!           15 Jul 2005  Added debugging for variable retrievals from WRF
!                        files.  Added error-exit for problems defining YORIG
!                        for WRF.  Added provisions for defining WRF XORIG and
!                        YORIG when dot-point lower-left corner coordinate is
!                        not available in WRF output.  (T. Otte)
!           11 Aug 2005  Removed unused variable X_RESOL.  (T. Otte)
!           27 Feb 2006  Changed tolerances on XORIG_M and YORIG_M for WRF to
!                        allow center of projection be at a face point or scalar
!                        point, rather than only on dot points.  Updated
!                        vertical coordinate definitions to correspond with
!                        updates to I/O API PARMS3.EXT for WRF.  Corrected
!                        I/O API grid definition for Mercator projection.
!                        (T. Otte)
!           07 Apr 2006  Corrected settings of P_ALP_GD, P_BET_GD, and
!                        P_GAM_GD for Mercator projection...again.  (T. Otte)
!           12 May 2006  Corrected setting of GDTYP_GD for polar stereographic
!                        projection.  Revised definitions of I/O API header
!                        variables for WRF-based domains.  Corrected
!                        calculation of print column and row for center of
!                        grid.  (T. Otte)
!           20 Jun 2006  Corrected operations involving double-precision
!                        variables XCELL_GD and YCELL_GD.  (T. Otte)
!           31 Jul 2007  Added IMPLICIT NONE.  Eliminated prints for former
!                        user-definable run options to recalculate PBL, cloud,
!                        and radiation.  Removed I/O API header settings for
!                        MM5v2-based vertical coordinate.  Removed T2OUT.
!                        Added prints to show whether or not some variables
!                        were part of input meteorology.  Added print statements
!                        to show whether or not some meteorological fields were
!                        found in the input file; those that are not found may
!                        be calculated.  Updated computation of LPRT_COL and
!                        LPRT_ROW for a one-cell domain.  Changed code so that
!                        M3Dry with chlorine and mercury is the only option to
!                        compute dry deposition velocities in MCIP.  Removed
!                        dependencies on modules FILE and WRF_NETCDF.  (T. Otte)
!           06 May 2008  Changed settings for XCENT_GD, YCENT_GD, XORIG_GD, and
!                        YORIG_GD for WRF for Lambert conformal projection so
!                        that headers will be compatible with M3IO utility
!                        routines LL2LAM and LAM2LL.  (Still need to test
!                        settings for polar stereographic and Mercator for
!                        WRF.)  Removed NTHIKD and NBNDYD.  Added error-checking
!                        to prevent NTHIK=0.  Added print statements to log file
!                        to indicate whether or not each of Q2 and TKE were
!                        found in the MM5 or WRF file.  Added print statements
!                        to log file to indicate whether or not UAH cloud field
!                        adjustment for photolysis has been invoked, and to
!                        indicate whether or not the urban canopy model has
!                        been invoked.  (T. Otte)
!           26 Nov 2008  Changed setting for YCENT_GD (and, thus, XORIG_GD and
!                        YORIG_GD) for WRF for Lambert conformal projection so
!                        that the headers will not fail in the Spatial
!                        Allocator.  Reference latitude now is set to the
!                        average of the true latitudes for the secant Lambert
!                        conformal case.  (Still need to test settings for polar
!                        stereographic and Mercator for WRF.)  (T. Otte)
!           23 Dec 2008  Added user-definable reference latitude for WRF
!                        Lambert conformal data sets.  Best used for
!                        consistency with existing MM5 data sets.  (T. Otte)
!           28 Apr 2009  Changed setting of XCENT and YCENT for polar
!                        stereographic WRF domains.  (T. Otte)
!           28 Oct 2009  Changed MET_UCMCALL to MET_URBAN_PHYS, and allowed
!                        for variable to be set to be greater than 1.  Removed
!                        setting of reference latitude for Lambert conformal
!                        because it is now done in SETUP_MM5V3 and SETUP_WRFEM.
!                        Remove subroutine GRIDGEOMETRY, and use dot-point
!                        latitude array directly to fill Mercator reference
!                        point information for I/O API headers.  Changed
!                        XORIG and YORIG truncation logic to allow for grid
!                        cells to be increments of half of a grid cell removed
!                        (rather than limiting to a whole grid cell).  Changed
!                        logic (again) to define I/O API projection parameters.
!                        Added user option to output vertical velocity predicted
!                        by the meteorological model rather than output it by
!                        default.  Changed format on print statements in MCIP
!                        log file so that larger numbers in XORIG3D and YORIG3D
!                        can be accommodated and more precision is given after
!                        the decimal point.  (T. Otte)
!           12 Feb 2010  Removed unused variables CNTRX, CNTRY, YLAT, and YLON,
!                        and removed unused format 9800.  (T. Otte)
!           09 Sep 2010  Removed option to compute dry deposition velocities
!                        in MCIP.  (T. Otte)
!           11 Aug 2011  Replaced module PARMS3 with I/O API module M3UTILIO.
!                        (T. Otte)
!           31 Aug 2011  Removed dependency on netcdf.inc, and improved error
!                        handling.  Changed F77 character definitions to F90
!                        standard.  (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!           10 Apr 2015  Updated log file to indicate if 3D resolved cloud
!                        fraction will be part of output.  (T. Spero)
!           21 Aug 2015  Updated log file to indicate if WRF/ACM2 was used and
!                        Monin-Obukhov length will be recalculated by MCIP to
!                        be consistent with other ACM2 physics in WRF.
!                        (T. Spero)
!           17 Sep 2015  Changed IFMOLACM to IFMOLPX.  (T. Spero)
!           23 Jun 2017  Added MET_HYBRID setting to log output.  (T. Spero)
!           22 Feb 2018  Refined calculation of interval between WRF output
!                        times to account for small drifts when advection time
!                        steps do not fall exactly on the hour.
!                        Corrected error in text of print statement 6155.
!                        Removed superfluous variables METROW and METCOL.
!                        Defined METSOI.  Prevent MCIP from using meteorology
!                        initialization time.  (T. Spero)
!           14 Sep 2018  Removed support for MM5v3 input.  (T. Spero)
!           18 Jun 2019  Added a flag for new surface variables with PX LSM
!                        that can improve dust simulation in CCTM.  Changed
!                        spacing in format statements improve readability in
!                        log file.  Changed variable LUVCOUT to LUVBOUT to
!                        reflect that the default 3D wind components are on the
!                        Arakawa-C staggered grid, and the optional additional
!                        3D winds are on the Arakawa-B staggered grid.  Added
!                        write for IOFORM to log.  Added flag for optional
!                        variable with KF convective scheme with radiative
!                        feedbacks.  (T. Spero)
!-------------------------------------------------------------------------------

  USE mcipparm
  USE xvars
  USE metinfo
  USE coord
  USE m3utilio

  IMPLICIT NONE

  CHARACTER(LEN=60)                 :: option
  CHARACTER(LEN=16),  PARAMETER     :: pname     = 'SETGRIDDEFS'
  REAL,               PARAMETER     :: pole      = 90.0  ! degrees
  REAL                              :: rnthik
  INTEGER                           :: ttol_min  ! minutes
  REAL                              :: xorig_ctm
  REAL                              :: xorig_m
  REAL                              :: xorig_x
  REAL                              :: xtemp
  CHARACTER(LEN=3)                  :: yesno
  REAL                              :: yorig_ctm
  REAL                              :: yorig_m
  REAL                              :: yorig_x
  REAL                              :: ytemp

!-------------------------------------------------------------------------------
! Error, warning, and informational messages.
!-------------------------------------------------------------------------------

  CHARACTER(LEN=1024), PARAMETER :: f6000 = "(/, 1x, 'Output start date = ', a, &
    & /, 1x, 'Output end date   = ', a, /, 1x, 'Output interval   = ', i3, &
    & ' minutes', // )"

  CHARACTER(LEN=1024), PARAMETER :: f6100 = "(1x, a, ' = ', i3, ':  ', a)"

  CHARACTER(LEN=1024), PARAMETER :: f6150 = &
      "(/, 1x, a, ' was ', a, ' found in the meteorology input file')"

  CHARACTER(LEN=1024), PARAMETER :: f6155 = &
      "(/, 1x, a, ' will ', a, ' be recomputed by MCIP (Only for WRF P-X LSM)')"

  CHARACTER(LEN=1024), PARAMETER :: f6160 = &
      "(1x, a, ' will be read from the ', a, ' file')"

  CHARACTER(LEN=1024), PARAMETER :: f6175 = &
      "(/, 1x, a, ' will ', a, ' be in the output file')"

  CHARACTER(LEN=1024), PARAMETER :: f6180 = &
      "(/, 1x, a, ' was ', a, ' used in the meteorology model')"

  CHARACTER(LEN=1024), PARAMETER :: f6200 = &
      "(1x, a, ' domain dimensions (col, row, lay):', 3(2x, i3))"

  CHARACTER(LEN=1024), PARAMETER :: f6300 = "(4x, a, 1x, a, 3x, i4, 2x, i4)"
  CHARACTER(LEN=1024), PARAMETER :: f6400 = "(4x, a, 2x, i14)"
  CHARACTER(LEN=1024), PARAMETER :: f6500 = "(4x, a, 2x, a)"
  CHARACTER(LEN=1024), PARAMETER :: f6600 = "(4x, a, 2x, f14.3)"

  CHARACTER(LEN=1024), PARAMETER :: f9000 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   NTHIK cannot be set to zero', &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9025 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   MCIP lower-left corner is not in met domain', &
    & /, 1x, '***   X0, Y0 = ', 2(2x, i4), &
    & /, 1x, '***   NX, NY = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9050 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   MCIP domain must have 1 or more cells per side', &
    & /, 1x, '***   NCOLS, NROWS = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9100 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   Requested MCIP X domain exceeds met domain', &
    & /, 1x, '***   METCOL, METROW = ', i4, 2x, i4, &
    & /, 1x, '***   MCIP domain (col, row) = ', i4, 2x, i4, &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9200 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   Requested MCIP dim.: ', i4, ' x ', i4, &
    & /, 1x, '***   Met. dim.: ', i4, ' x ', i4, &
    & /, 1x, '***   Max. allowable dim.: ', i4, ' x ', i4, &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9250 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   Requested MCIP dim. exceed the actual Met. dim.', &
    & /, 1x, '***   Input meteorology dimensions: ', 2(2x, i4), &
    & /, 1x, '***   MCIP output domain in terms of met: ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9275 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   INVALID INPUT METEOROLOGY MAP PROJECTION ', i4, &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9300 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '      MCIP output interval cannot be shorter than input', &
    & /, 1x, '      User-defined MCIP output interval = ', i3, &
    & /, 1x, '      Meteorology output interval       = ', f5.1, &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9400 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   MCIP output must start after meteorology start time', &
    & /, 1x, '***   User-defined MCIP start date = ', a, &
    & /, 1x, '***   Input meteorology start date = ', a, &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=1024), PARAMETER :: f9600 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   Diagnostic print cell is outside domain', &
    & /, 1x, '***   Input LPRT_COL and LPRT_ROW are ', i4, 2x, i4, &
    & /, 1x, '***   Output domain NCOLS and NROWS are ', i4, 2x, i4, &
    & /, 1x, 70('*'))"

!-------------------------------------------------------------------------------
! Define MCIP grid coordinate information from meteorology grid input.
!-------------------------------------------------------------------------------

  ttol_min = NINT( REAL(ttol_sec) / 60.0 )  ! convert time tolerance to minutes

  metlay = met_nz
  metsoi = met_ns

  IF ( nthik == 0 ) THEN
    WRITE (*,f9000) TRIM(pname)
    CALL graceful_stop (pname)
  ENDIF

  IF ( nbdrytrim >= 0 ) THEN  ! not windowing...need to define NCOLS, NROWS
    ncols = met_nx - (2 * nbdrytrim) - (2 * nthik) - 1
    nrows = met_ny - (2 * nbdrytrim) - (2 * nthik) - 1
  ENDIF

  nrows_x = nrows + 2 * nthik
  ncols_x = ncols + 2 * nthik

  nbndy   = 2 * nthik * (ncols + nrows + 2*nthik)

!-------------------------------------------------------------------------------
! Check dimensions of domain.
!-------------------------------------------------------------------------------

  IF ( ( x0 < 1          ) .OR. ( y0 < 1          ) .OR.  &
       ( x0 > met_nx - 1 ) .OR. ( y0 > met_ny - 1 ) ) THEN
    WRITE (*,f9025) TRIM(pname), x0, y0, met_nx, met_ny
    CALL graceful_stop (pname)
  ENDIF

  IF ( ( ncols < 1 ) .OR. ( nrows < 1 ) ) THEN
    WRITE (*,f9050) TRIM(pname), ncols, nrows
    CALL graceful_stop (pname)
  ENDIF

  IF ( ( met_nx < (ncols_x + 1) ) .OR.  &
       ( met_ny < (nrows_x + 1) ) ) THEN
    WRITE (*,f9100) TRIM(pname), met_nx, met_ny, ncols_x + 1, nrows_x + 1
    CALL graceful_stop (pname)
  ENDIF

  IF ( ( ncols > met_nx-2*nthik-1 ) .OR.  &
       ( nrows > met_ny-2*nthik-1 ) ) THEN
    WRITE (*,f9200) TRIM(pname), ncols, nrows, met_nx, met_ny,  &
                   met_nx-2*nthik-1, met_ny-2*nthik-1
    CALL graceful_stop (pname)
  ENDIF

  IF ( ( x0+2*nthik+ncols-1 > met_nx-1 ) .OR.  &
       ( y0+2*nthik+nrows-1 > met_ny-1 ) ) THEN
    WRITE (*,f9250) TRIM(pname), met_nx, met_ny,  &
                   x0+2*nthik+ncols-1, y0+2*nthik+nrows-1
    CALL graceful_stop (pname)
  ENDIF

!-------------------------------------------------------------------------------
! Calculate window domain size in terms of MET grid.
!-------------------------------------------------------------------------------

  ncg_x = 1 + INT( ncols + 2 * nthik - 1 )
  ncg_y = 1 + INT( nrows + 2 * nthik - 1 )

!-------------------------------------------------------------------------------
! GDTYP_GD:
! The map projection types in I/O API are:
!   1: LATGRD for lat-lon coordinates
!   2: LAMGRD for Lambert coordinates
!   3: MERGRD for Mercator coordinates
!   4: STEGRD for Stereographic coordinates
!   5: UTMGRD for UTM coordinates
!   6: POLGRD for polar stereographic coordinates
!   7: EQMGRD for equatorial Mercator coordinates
!   8: TRMGRD for transverse Mercator coordinates
!   9: ALBGRD for Albers equal-area conic
!  10: LEQGRD for Lambert azimuthal equal-area
!-------------------------------------------------------------------------------

  IF ( met_mapproj == 1 ) THEN       ! Lambert conformal
    gdtyp_gd = lamgrd3
  ELSE IF ( met_mapproj == 2 ) THEN  ! polar stereographic
    gdtyp_gd = polgrd3
  ELSE IF ( met_mapproj == 3 ) THEN  ! equatorial Mercator
    gdtyp_gd = eqmgrd3
  ELSE
    WRITE (*,f9275) TRIM(pname), met_mapproj
    CALL graceful_stop (pname)
  ENDIF

!-------------------------------------------------------------------------------
! The definitions of the map projection specification parameters,
! P_ALP_GD (alpha),  P_BET_GD (beta), and P_GAM_GD (gamma), depend upon the
! projection type.  (Note: if P_ALP_GD < AMISS, then the grid description is
! missing or invalid.)
!
! The following descriptions were liberally borrowed from the I/O API
! grid definition page:  http://www.baronams.com/products/ioapi/GRIDS.html
!
! Lambert:       P_ALP_GD <= P_BET_GD are the two latitudes that
!                determine the projection cone; P_GAM_GD is the
!                central meridian.
!
! Polar:         P_ALP_GD is 1.0 for North Polar and -1.0 for South Polar.
!                P_BET_GD is the secant latitude (latitude of true scale).
!                P_GAM_GD is the central meridian.

! Eq. Mercator:  P_ALP_GD is the latitude of the true scale, P_BET_GD is unused,
!                and P_GAM_GD is the longitude of the central meridian.
!-------------------------------------------------------------------------------

  p_alp_gd = DBLE(met_p_alp_d)
  p_bet_gd = DBLE(met_p_bet_d)
  p_gam_gd = DBLE(met_p_gam_d)

!-------------------------------------------------------------------------------
! (XCENT_GD, YCENT_GD):
! For most projections, these are the longitude, -180 < X <= 180, and the
!   latitude, -90 <= Y <= 90, for the center of the grid's respective Cartesian
!   coordinate system.  Units are meters.
!-------------------------------------------------------------------------------

  IF ( ( met_model == 2 ) .AND. ( gdtyp_gd == lamgrd3 ) ) THEN
    xcent_gd = DBLE(met_proj_clon)  ! [degrees longitude]
    ycent_gd = DBLE(met_ref_lat)    ! [degrees latitude]
  ELSE IF ( gdtyp_gd == eqmgrd3 ) THEN
    xcent_gd = DBLE(met_proj_clon)  ! [degrees longitude]
    ycent_gd = 0.0d0                ! [degrees latitude]
  ELSE
    xcent_gd = DBLE(met_proj_clon)  ! [degrees longitude]
    ycent_gd = DBLE(met_proj_clat)  ! [degrees latitude]
  ENDIF

!-------------------------------------------------------------------------------
! (XCELL_GD, YCELL_GD):
! The X-direction and Y-direction cell dimensions (m) for a regular grid
! If zero, the grid is assumed irregular and described by other means (e.g.
! a grid-geometry file).
!-------------------------------------------------------------------------------

  xcell_gd   =  DBLE(met_resoln)  ! [m]
  ycell_gd   =  DBLE(met_resoln)  ! [m]

!-------------------------------------------------------------------------------
! VGTYP_GD:
! The vertical grid type:
!   1: VGSGPH3 for hydrostatic sigma-P coordinates
!   2: VGSGPN3 for non-hydrostatic sigma-P0 coordinates
!   3: VGSIGZ3 for sigma-Z coordinates
!   4: VGPRES3 for pressure (mb) coordinates
!   5: VGZVAL3 for Z (meters above mean sea level)
!   6: VHZVAL3 for H (meters above ground)
!   7: VGWRFEM for WRF mass-core sigma
!   8: VGWRFNM for WRF NMM
!   -: IMISS   for vertical coordinates not stored in VGLVSD
!              (e.g., temporally or spatially changing vertical coordinates)
!-------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN     ! WRF-ARW
    IF ( met_hybrid <= 0 ) THEN  ! sigma-type vertical coordinate
      vgtyp_gd = vgwrfem         ! terrain-following dry hydrostatic pressure
    ELSE                         ! hybrid sigma-pressure vertical coordinate
      vgtyp_gd = imiss3
    ENDIF
  ENDIF

!-------------------------------------------------------------------------------
! VGTPUN_GD:
! The units of the vertical coordinate top.
!-------------------------------------------------------------------------------

  vgtpun_gd  = 'Pa'

!-------------------------------------------------------------------------------
! VGTOP_GD:
! The value for the model top used in the definition of the sigma
! coordinate systems in the VGTPUN_GD units
! For sigma-P, the relationship between pressure levels P and sigma-P is
! given by the following formula:
!    sigma-P = ( P - VGTOP_GD ) / (P_srf - VGTOP_GD ),
! where P_srf is the surface pressure.
!-------------------------------------------------------------------------------

  vgtop_gd   = met_ptop
  x3top      = met_ptop

!-------------------------------------------------------------------------------
! VGLVUN_GD:
! The units of the vertical coordinate surface values
!-------------------------------------------------------------------------------

  vglvun_gd  = 'none'

!-------------------------------------------------------------------------------
! COORDNAM_GD:
! The coordinate system name used for I/O-API description and GRIDDESC.
!-------------------------------------------------------------------------------

  coordnam_gd  = coordnam

!-------------------------------------------------------------------------------
! GDNAME_GD:
! The grid name used for I/O-API description and GRIDDESC.
!-------------------------------------------------------------------------------

  gdname_gd  = grdnam

!-------------------------------------------------------------------------------
! Check origins of output MCIP domain and met from offsets.  Take into account
! resolution of MET, MCIP, and NTHIK.
!   (X0, Y0) = (COL_OFFSET, ROW_OFFSET)
! *** Note:  The XORIG and YORIG values for WRF Lambert conformal are forced
!            to increments of half-delta-X if a user-defined reference
!            latitude was specified.
!-------------------------------------------------------------------------------

  IF ( ( met_model == 2 ) .OR. ( gdtyp_gd == eqmgrd3 ) ) THEN  ! WRF or Mercator

    xorig_ctm = met_xxctr - ( met_rictr_dot - FLOAT(x0+nthik) ) * met_resoln
    yorig_ctm = met_yyctr - ( met_rjctr_dot - FLOAT(y0+nthik) ) * met_resoln

    IF ( ( gdtyp_gd == lamgrd3 ) .AND. ( wrf_lc_ref_lat > -900.0 ) ) THEN
      ! Force XORIG and YORIG to be even increments of 0.5*delta-X.
      xtemp = xorig_ctm / 500.0
      ytemp = yorig_ctm / 500.0
      xtemp = FLOAT(NINT(xtemp))
      ytemp = FLOAT(NINT(ytemp))
      xorig_ctm = xtemp * 500.0
      yorig_ctm = ytemp * 500.0
    ENDIF

  ENDIF

!-------------------------------------------------------------------------------
! (XORIG_GD, YORIG_GD):
! For Lambert, Mercator, Stereographic, and UTM these are the
!     location in map units (Km) of the origin cell (1,1) (lower left corner)
!     of the of the horizontal grid measured from (XCENT_GD, YCENT_GD).
! For Lat-Lon: units are degrees - unused
!-------------------------------------------------------------------------------

  IF ( met_model == 2 ) THEN  ! WRF -- Allow trailing digits.
    xorig_gd   = DBLE(xorig_ctm)        ! X-origin [m]
    yorig_gd   = DBLE(yorig_ctm)        ! Y-origin [m]
  ENDIF

!-------------------------------------------------------------------------------
! Check user-defined MCIP output time info against input meteorology.
!-------------------------------------------------------------------------------

  IF ( ABS( intvl - NINT(met_tapfrq) ) > ttol_min ) THEN
    WRITE (*,f9300) TRIM(pname), intvl, met_tapfrq
    CALL graceful_stop (pname)
  ENDIF

  IF ( mcip_start <= met_startdate ) THEN
    WRITE (*,f9400) TRIM(pname), mcip_start, met_startdate
    CALL graceful_stop (pname)
  ENDIF

!-------------------------------------------------------------------------------
! Set up coordinates for diagnostic print on all domains.
!-------------------------------------------------------------------------------

  IF ( ( lprt_col > ncols ) .OR. ( lprt_row > nrows ) .OR.  &
       ( lprt_col < 0     ) .OR. ( lprt_row < 0     ) ) THEN
    WRITE (*,f9600) TRIM(pname), lprt_col, lprt_row, ncols, nrows
    CALL graceful_stop (pname)
  ENDIF

  IF ( lprt_col == 0 ) THEN
    IF ( ncols > 1 ) THEN
      lprt_col = (ncols + 1) / 2
    ELSE
      lprt_col = 1
    ENDIF
  ENDIF

  IF ( lprt_row == 0 ) THEN
    IF ( nrows > 1 ) THEN
      lprt_row = (nrows + 1) / 2
    ELSE
      lprt_row = 1
    ENDIF
  ENDIF

  lprt_xcol = lprt_col + nthik
  lprt_xrow = lprt_row + nthik

  lprt_metx = lprt_col + x0
  lprt_mety = lprt_row + y0

!-------------------------------------------------------------------------------
! Echo user options and grid definitions to log file.
!-------------------------------------------------------------------------------

  WRITE (*, "(/, 1x, 78('-'), /)")
  WRITE (*, "(24x, a, /)") 'USER OPTIONS AND GRID DEFINITIONS'

  WRITE (*,f6000) mcip_start, mcip_end, intvl

  SELECT CASE ( lpv )
    CASE ( 0 )
      option = 'Will not calculate and output 3D potential vorticity'
    CASE ( 1 )
      option = 'Will calculate and output 3D potential vorticity'
    CASE DEFAULT
      option = '*** invalid ***'
  END SELECT
  WRITE (*,f6100) 'LPV    ', lpv, TRIM(option)

  SELECT CASE ( lwout )
    CASE ( 0 )
      option = 'Will not output vertical velocity from the met model'
    CASE ( 1 )
      option = 'Will output vertical velocity from the met model'
    CASE DEFAULT
      option = '*** invalid ***'
  END SELECT
  WRITE (*,f6100) 'LWOUT  ', lwout, TRIM(option)

  SELECT CASE ( luvbout )
    CASE ( 0 )
      option = 'Will not output u- and v-component winds on B grid'
    CASE ( 1 )
      option = 'Will output u- and v-component winds on B grid'
    CASE DEFAULT
      option = '*** invalid ***'
  END SELECT
  WRITE (*,f6100) 'LUVBOUT', luvbout, TRIM(option)

  SELECT CASE ( ioform )
    CASE ( 1 )
      option = 'Will write output in Models-3 I/O API'
    CASE ( 2 )
      option = 'Will write output in netCDF'
    CASE DEFAULT
      option = '*** invalid ***'
  END SELECT
  WRITE (*,f6100) 'IOFORM ', ioform, TRIM(option)

  IF ( iflai ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'LAI', TRIM(yesno)

  IF ( iflufrc ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT '
  ENDIF
  WRITE (*,f6150) 'FRACTIONAL LAND USE', TRIM(yesno)

  IF ( ( iflufrc ) .AND. ( met_model == 2 ) ) THEN
    IF ( ifluwrfout ) THEN
      yesno = 'WRF'
    ELSE
      yesno = 'GEO'
    ENDIF
    WRITE (*,f6160) 'FRACTIONAL LAND USE', TRIM(yesno)
  ENDIF

  IF ( ifmol ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'MONIN-OBUKHOV LENGTH', TRIM(yesno)

  IF ( ifmolpx ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6155) 'MONIN-OBUKHOV LENGTH', TRIM(yesno)

  IF ( ifresist ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'AERODYNAMIC AND STOMATAL RESISTANCE', TRIM(yesno)

  IF ( ift2m ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) '2-m TEMPERATURE', TRIM(yesno)

  IF ( ifq2m ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) '2-m MIXING RATIO', TRIM(yesno)

  IF ( ifveg ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'VEGETATION FRACTION', TRIM(yesno)

  IF ( ifw10m ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) '10-m WIND', TRIM(yesno)

  IF ( ifwr ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'CANOPY WETNESS', TRIM(yesno)

  IF ( ifznt ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'ROUGHNESS LENGTH', TRIM(yesno)

  IF ( ifsoil ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'SOIL MOISTURE, TEMPERATURE, AND TYPE', TRIM(yesno)
  WRITE (*,f6175) 'SOIL MOISTURE, TEMPERATURE, AND TYPE', TRIM(yesno)

  IF ( iftke ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) 'TURBULENT KINETIC ENERGY', TRIM(yesno)
  IF ( ( iftke ) .AND. ( .NOT. iftkef ) ) THEN
    WRITE (*,*) '  TKE is on half-layers'
  ELSE IF ( ( iftke ) .AND. ( iftkef ) ) THEN
    WRITE (*,*) '  TKE is on full-levels'
  ENDIF

  IF ( met_urban_phys >= 1 ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  IF ( met_model == 2 ) THEN
    WRITE (*,f6180) 'URBAN CANOPY MODEL (WRF ONLY)', TRIM(yesno)
  ENDIF

  IF ( ifcld3d ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6150) '3D RESOLVED CLOUD FRACTION', TRIM(yesno)

  IF ( ifpxwrf41 ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6175) 'ADDITIONAL PX SURFACE VARIABLES', TRIM(yesno)

  IF ( ifkfradextras ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6175) 'ADDITIONAL KF-RAD 3D VARIABLES', TRIM(yesno)

  IF ( met_hybrid > 0 ) THEN
    yesno = ''
  ELSE
    yesno = 'NOT'
  ENDIF
  WRITE (*,f6180) 'HYBRID VERTICAL COORDINATE', TRIM(yesno)

  WRITE (*,'(/)')
  WRITE (*,f6200) 'Met   ', met_nx,  met_ny,  metlay
  WRITE (*,f6200) 'MCIP X', ncols_x, nrows_x, metlay
  WRITE (*,f6200) 'Output', ncols,   nrows,   nlays
  WRITE (*,'(/)')

  WRITE (*,*) 'Output grid resolution: ', xcell_gd / 1000.0,  ' km'
  WRITE (*,*) 'Window domain origin on met domain (col,row):     ',  &
              x0, ', ', y0
  WRITE (*,*) 'Window domain far corner on met domain (col,row): ',  &
              x0 + ncg_x, ', ', y0 + ncg_y

  WRITE (*,'(/)')
  WRITE (*,"(' Cells and points for diagnostic prints')")
  WRITE (*,f6300) 'LPRT_COL ', 'LPRT_ROW ', lprt_col,  lprt_row
  WRITE (*,f6300) 'LPRT_XCOL', 'LPRT_XROW', lprt_xcol, lprt_xrow
  WRITE (*,f6300) 'LPRT_METX', 'LPRT_METY', lprt_metx, lprt_mety

  WRITE (*,'(/)')
  WRITE (*,"(' IOAPI header variables:')")

  WRITE (*,f6400) 'GDTYP3D', gdtyp_gd
  WRITE (*,f6500) 'GDNAM3D', gdname_gd
  WRITE (*,f6600) 'P_ALP3D', p_alp_gd
  WRITE (*,f6600) 'P_BET3D', p_bet_gd
  WRITE (*,f6600) 'P_GAM3D', p_gam_gd
  WRITE (*,f6600) 'XCENT3D', xcent_gd
  WRITE (*,f6600) 'YCENT3D', ycent_gd
  WRITE (*,f6600) 'XORIG3D', xorig_gd
  WRITE (*,f6600) 'YORIG3D', yorig_gd
  WRITE (*,f6600) 'XCELL3D', xcell_gd
  WRITE (*,f6600) 'YCELL3D', ycell_gd
  WRITE (*,f6400) 'VGTYP3D', vgtyp_gd
  WRITE (*,f6600) 'VGTOP3D', vgtop_gd

END SUBROUTINE setgriddefs


version https://git-lfs.github.com/spec/v1
oid sha256:687f4d7319fc74b372243c1f98b9ac4ef3cd44a391b352849c4fc02a3c81791b
size 2957


!Crown Copyright 2012 AWE.
!
! This file is part of CloverLeaf.
!
! CloverLeaf is free software: you can redistribute it and/or modify it under
! the terms of the GNU General Public License as published by the
! Free Software Foundation, either version 3 of the License, or (at your option)
! any later version.
!
! CloverLeaf is distributed in the hope that it will be useful, but
! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
! FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
! details.
!
! You should have received a copy of the GNU General Public License along with
! CloverLeaf. If not, see http://www.gnu.org/licenses/.

!>  @brief CloverLeaf top level program: Invokes the main cycle
!>  @author Wayne Gaudin
!>  @details CloverLeaf in a proxy-app that solves the compressible Euler
!>  Equations using an explicit finite volume method on a Cartesian grid.
!>  The grid is staggered with internal energy, density and pressure at cell
!>  centres and velocities on cell vertices.
!>
!>  A second order predictor-corrector method is used to advance the solution
!>  in time during the Lagrangian phase. A second order advective remap is then
!>  carried out to return the mesh to an orthogonal state.
!>
!>  It can be run in distributed mode using MPI or Co-array Fortran.
!>
!>  It can use OpenMP, OpenACC on a compute device.
!>
!>  NOTE: that the proxy-app uses uniformly spaced mesh. The actual method will
!>  work on a mesh with varying spacing to keep it relevant to it's parent code.
!>  For this reason, optimisations should only be carried out on the software
!>  that do not change the underlying numerical method. For example, the
!>  volume, though constant for all cells, should remain array and not be
!>  converted to a scalar.
subroutine clover_leaf() bind(C,name="clover_leaf")
  USE clover_module

  IMPLICIT NONE

!$ INTEGER :: OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM

  CALL clover_init_comms()

!$OMP PARALLEL
  IF(parallel%boss)THEN
!$  IF(OMP_GET_THREAD_NUM().EQ.0) THEN
      WRITE(*,*)
      WRITE(*,'(a15,f8.3)') 'Clover Version ',g_version
      WRITE(*,'(a18)') 'MPI Version'
!$    WRITE(*,'(a18)') 'OpenMP Version'
      WRITE(*,'(a14,i6)') 'Task Count ',parallel%max_task !MPI
!$    WRITE(*,'(a15,i5)') 'Thread Count: ',OMP_GET_NUM_THREADS()
      WRITE(*,*)
      WRITE(0,*)
      WRITE(0,'(a15,f8.3)') 'Clover Version ',g_version
      WRITE(0,'(a18)') 'MPI Version'
!$    WRITE(0,'(a18)') 'OpenMP Version'
      WRITE(0,'(a14,i6)') 'Task Count ',parallel%max_task !MPI
!$    WRITE(0,'(a15,i5)') 'Thread Count: ',OMP_GET_NUM_THREADS()
      WRITE(0,*)
!$  ENDIF
  ENDIF
!$OMP END PARALLEL

  CALL initialise

  CALL hydro

  ! Deallocate everything

end subroutine clover_leaf