text:
      module e3if_func_m
c
        use e3if_defs_m
c
        implicit none
c
      contains
c
      subroutine e3if_mtrx
c
        real*8, dimension(:), pointer :: rmu0, rlm0, rlm2mu0, con0
        real*8, dimension(:), pointer :: rmu1, rlm1, rlm2mu1, con1
c
c... set Ai and Kij matrices for elements 0 and 1
c
        call set_Ai (Ai0,u0(:,1),u0(:,2),u0(:,3),um0(:,1),um0(:,2),um0(:,3),rho0,T0,h0,cp0,alfaP0,betaT0)
        call set_Ai (Ai1,u1(:,1),u1(:,2),u1(:,3),um1(:,1),um1(:,2),um1(:,3),rho1,T1,h1,cp1,alfaP1,betaT1)
c
        allocate(rmu0(npro),rlm0(npro),rlm2mu0(npro),con0(npro))
        allocate(rmu1(npro),rlm1(npro),rlm2mu1(npro),con1(npro))
c
        call getdiff(rmu0, rlm0, rlm2mu0, con0, npro, mater0)
        call getdiff(rmu1, rlm1, rlm2mu1, con1, npro, mater1)
c
        call set_Kij(Kij0,rmu0,rlm0,rlm2mu0,con0,u0(:,1),u0(:,2),u0(:,3))
        call set_Kij(Kij1,rmu1,rlm1,rlm2mu1,con1,u1(:,1),u1(:,2),u1(:,3))
c
        deallocate(rmu0,rlm0,rlm2mu0,con0)
        deallocate(rmu1,rlm1,rlm2mu1,con1)
c
      end subroutine e3if_mtrx
c
      subroutine set_Ai (Ai,u1,u2,u3,um1,um2,um3,
     &                  rho,T,h,cp,alfaP,betaT)
c
        real*8, dimension(:,:,:,:), intent(out) :: Ai
        real*8, dimension(:), intent(in) :: u1,u2,u3,um1,um2,um3
        real*8, dimension(:), intent(in) :: rho,T,h,cp,alfaP,betaT
c
        real*8, dimension(npro) :: drdp,drdT,e2p,e3p,e4p,rk
c
        drdp = rho * betaT
        drdT = -rho * alfap
        rk   = pt50 * (u1*u1 + u2*u2 + u3*u3)
        e2p  = drdp * (h + rk)  - alfap * T + one
        e3p  = rho * ( h + rk)
        e4p  = drdT * (h + rk) + rho * cp
c
        Ai(:,1,1,1) = drdp * (u1 - um1)
        Ai(:,1,1,2) = rho
c       Ai(:,1,1,3) = zero
c       Ai(:,1,1,4) = zero
        Ai(:,1,1,5) = drdT * (u1 - um1)
c
        Ai(:,1,2,1) = drdp * (u1 - um1) * u1 + 1
        Ai(:,1,2,2) = rho  * (u1 - um1) + rho * u1
c       Ai(:,1,2,3) = zero
c       Ai(:,1,2,4) = zero
        Ai(:,1,2,5) = drdT * (u1 - um1) * u1
c
        Ai(:,1,3,1) = drdp * (u1 - um1) * u2
        Ai(:,1,3,2) = rho  * u2
        Ai(:,1,3,3) = rho  * (u1 - um1)
c       Ai(:,1,3,4) = zero
        Ai(:,1,3,5) = drdT * (u1 - um1) * u2
c
        Ai(:,1,4,1) = drdp * (u1 - um1) * u3
        Ai(:,1,4,2) = rho  * u3
c       Ai(:,1,4,3) = zero
        Ai(:,1,4,4) = rho  * (u1 - um1)
        Ai(:,1,4,5) = drdT * (u1 - um1) * u3
c
        Ai(:,1,5,1) = (u1 - um1) * e2p
        Ai(:,1,5,2) = e3p + rho * (u1 - um1) * u1
        Ai(:,1,5,3) = rho * (u1 - um1) * u2
        Ai(:,1,5,4) = rho * (u1 - um1) * u3
        Ai(:,1,5,5) = (u1 - um1) * e4p
c
        Ai(:,2,1,1) = drdp * (u2 - um2)
c       Ai(:,2,1,2) = zero
        Ai(:,2,1,3) = rho
c       Ai(:,2,1,4) = zero
        Ai(:,2,1,5) = drdT * (u2 - um2)
c
        Ai(:,2,2,1) = drdp * u1 * (u2 - um2)
        Ai(:,2,2,2) = rho  * (u2 - um2)
        Ai(:,2,2,3) = rho  * u1
c       Ai(:,2,2,4) = zero
        Ai(:,2,2,5) = drdT * u1 * (u2 - um2)
c
        Ai(:,2,3,1) = drdp * (u2 - um2) * u2 + 1
c       Ai(:,2,3,2) = zero
        Ai(:,2,3,3) = rho  * (u2 - um2) + rho * u2
c       Ai(:,2,3,4) = zero
        Ai(:,2,3,5) = drdT * (u2 - um2) * u2
c
        Ai(:,2,4,1) = drdp * (u2 - um2) * u3
c       Ai(:,2,4,2) = zero
        Ai(:,2,4,3) = rho  * u3
        Ai(:,2,4,4) = rho  * (u2 - um2)
        Ai(:,2,4,5) = drdT * (u2 - um2) * u3
c
        Ai(:,2,5,1) = (u2 - um2) * e2p
        Ai(:,2,5,2) = rho * u1 * (u2 - um2)
        Ai(:,2,5,3) = e3p + rho * (u2 - um2) * u2
        Ai(:,2,5,4) = rho * (u2 - um2) * u3
        Ai(:,2,5,5) = (u2 - um2) * e4p
c
        Ai(:,3,1,1) = drdp * (u3 - um3)
c       Ai(:,3,1,2) = zero
c       Ai(:,3,1,3) = zero
        Ai(:,3,1,4) = rho
        Ai(:,3,1,5) = drdT * (u3 - um3)
c
        Ai(:,3,2,1) = drdp * u1 * (u3 - um3)
        Ai(:,3,2,2) = rho  * (u3 - um3)
c       Ai(:,3,2,3) = zero
        Ai(:,3,2,4) = rho  * u1
        Ai(:,3,2,5) = drdT * u1 * (u3 - um3)
c
        Ai(:,3,3,1) = drdp * (u3 - um3) * u2
c       Ai(:,3,3,2) = zero
        Ai(:,3,3,3) = rho  * (u3 - um3)
        Ai(:,3,3,4) = rho  * u2
        Ai(:,3,3,5) = drdT * (u3 - um3) * u2
c
        Ai(:,3,4,1) = drdp * (u3 - um3) * u3 + 1
c       Ai(:,3,4,2) = zero
c       Ai(:,3,4,3) = zero
        Ai(:,3,4,4) = rho  * u3 + rho * (u3 - um3)
        Ai(:,3,4,5) = drdT * (u3 - um3) * u3
c
        Ai(:,3,5,1) = (u3 - um3) * e2p
        Ai(:,3,5,2) = rho * u1 * (u3 - um3)
        Ai(:,3,5,3) = rho * u2 * (u3 - um3)
        Ai(:,3,5,4) = e3p + rho * (u3 - um3) * u3
        Ai(:,3,5,5) = (u3 - um3) * e4p
c
      end subroutine set_Ai
c
      subroutine set_Kij(Kij,rmu,rlm,rlm2mu,con,u1,u2,u3)
c
        real*8, dimension(:,:,:,:,:), pointer, intent(out) :: Kij
        real*8, dimension(:), pointer, intent(in) :: rmu,rlm,rlm2mu,con,u1,u2,u3
c
        Kij = zero
c
c.... K11
c
        Kij(:,1,1,2,2) = rlm2mu
        Kij(:,1,1,3,3) = rmu
        Kij(:,1,1,4,4) = rmu
        Kij(:,1,1,5,2) = rlm2mu * u1
        Kij(:,1,1,5,3) = rmu    * u2
        Kij(:,1,1,5,4) = rmu    * u3
        Kij(:,1,1,5,5) = con
c
c.... K12
c
        Kij(:,1,2,2,3) = rlm
        Kij(:,1,2,3,2) = rmu
        Kij(:,1,2,5,2) = rmu    * u2
        Kij(:,1,2,5,3) = rlm    * u1
c
c.... K13
c
        Kij(:,1,3,2,4) = rlm
        Kij(:,1,3,4,2) = rmu
        Kij(:,1,3,5,2) = rmu    * u3
        Kij(:,1,3,5,4) = rlm    * u1
c
c.... K21
c
        Kij(:,2,1,2,3) = rmu
        Kij(:,2,1,3,2) = rlm
        Kij(:,2,1,5,2) = rlm    * u2
        Kij(:,2,1,5,3) = rmu    * u1
c
c.... K22
c
        Kij(:,2,2,2,2) = rmu
        Kij(:,2,2,3,3) = rlm2mu
        Kij(:,2,2,4,4) = rmu
        Kij(:,2,2,5,2) = rmu    * u1
        Kij(:,2,2,5,3) = rlm2mu * u2
        Kij(:,2,2,5,4) = rmu    * u3
        Kij(:,2,2,5,5) = con
c
c.... K23
c
        Kij(:,2,3,3,4) = rlm
        Kij(:,2,3,4,3) = rmu
        Kij(:,2,3,5,3) = rmu    * u3
        Kij(:,2,3,5,4) = rlm    * u2
c
c.... K31
c
        Kij(:,3,1,2,4) = rmu
        Kij(:,3,1,4,2) = rlm
        Kij(:,3,1,5,2) = rlm    * u3
        Kij(:,3,1,5,4) = rmu    * u1
c
c.... K32
c
        Kij(:,3,2,3,4) = rmu
        Kij(:,3,2,4,3) = rlm
        Kij(:,3,2,5,3) = rlm    * u3
        Kij(:,3,2,5,4) = rmu    * u2
c
c.... K33
c
        kij(:,3,3,2,2) = rmu
        kij(:,3,3,3,3) = rmu
        kij(:,3,3,4,4) = rlm2mu
        kij(:,3,3,5,2) = rmu    * u1
        kij(:,3,3,5,3) = rmu    * u2
        kij(:,3,3,5,4) = rlm2mu * u3
        kij(:,3,3,5,5) = con
c
      end subroutine set_Kij
c
      end module e3if_func_m


text:
For years people have moved the Address(painted rocks, 38.562892, 121.638409) at the south side of Interstate 80 where the levee for the Yolo Bypass provides a sloping message surface. When the weeds are growing high along the freeway it is harder to see the messages or initials that are left there.  Fraternities and Sororities are the usual rockarrangers, though Banduh other groups frequently interject their own formations.

 Notable Message

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program s19

  integer :: a(10, 10)

  a = 0

  where (a < 0)
     a = 0
  end where

end program s19

max_stars_repo_name: xevolver/xevxml

max_issues_repo_name: xevolver/xevxml

max_forks_repo_name: xevolver/xevxml


text:
!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis
!dis

  SUBROUTINE reflectivity(nx,ny,nz,rho,hgt,rainmr,icemr,snowmr,graupelmr, &
                          refl,max_refl,echo_tops)

    ! Subroutine to compute estimated radar reflectivity from
    ! the precipitation mixing ratios.  Will also return
    ! column max reflectivity and echo tops.  The estimation
    ! is done using formulae from Kessler (1969) and
    ! Rogers and Yau (1989).
    !
    ! Adapted from USAF Weather Agency routine.
    !
    !  Brent Shaw, NOAA Forecast System Lab, Dec 2000
    !

    IMPLICIT NONE

    INTEGER, INTENT(IN)             :: nx
    INTEGER, INTENT(IN)             :: ny
    INTEGER, INTENT(IN)             :: nz
    REAL, INTENT(IN)                :: rho(nx,ny,nz)
    REAL, INTENT(IN)                :: hgt(nx,ny,nz)
    REAL, INTENT(IN)                :: rainmr(nx,ny,nz)
    REAL, INTENT(IN)                :: icemr(nx,ny,nz)
    REAL, INTENT(IN)                :: snowmr(nx,ny,nz)
    REAL, INTENT(IN)                :: graupelmr(nx,ny,nz)
    REAL, INTENT(OUT)               :: refl(nx,ny,nz)
    REAL, INTENT(OUT)               :: max_refl(nx,ny)
    REAL, INTENT(OUT)               :: echo_tops(nx,ny)

    ! Locals
    REAL, PARAMETER                 :: svnfrth = 7.0/4.0
    REAL, PARAMETER                 :: max_top_thresh =  5.0
    INTEGER                         :: i,j,k
    REAL                            :: w
    max_refl = 0.0
    echo_tops = 1.0e37
    refl = 0.0

    DO j = 1,ny
      DO i = 1, nx
        DO k=1,nz

          ! Compute the basic reflectivity
          !refl(i,j,k) =17300.0 * &
          !            (rho(i,j,k) * 1000.0 * &
          !             MAX(0.0,rainmr(i,j,k)))**svnfrth

          ! Add the ice component
          !refl(i,j,k)=refl(i,j,k) + &
          !       38000.0*(rho(i,j,k) * 1000.0 * &
          !       MAX(0.0,icemr(i,j,k)+snowmr(i,j,k)+graupelmr(i,j,k)))**2.2

          ! Convert to dBZ
          !refl(i,j,k) = 10.*ALOG10(MAX(refl(i,j,k),1.0))

          ! Test RAMS reflectivity algorithm
          w = 264083.11 * (rainmr(i,j,k) + &
              0.2*(icemr(i,j,k) + snowmr(i,j,k)) + &
              2.0 * graupelmr(i,j,k))
          w = MAX(1.,w)
          refl(i,j,k) = 17.8 * alog10(w)
          ! Since we are going from the ground up, we can
          ! check threshold and set echo top.

          IF (refl(i,j,k) .GE. max_top_thresh) echo_tops(i,j)=hgt(i,j,k)

        ENDDO
        ! Compute the max value in the column
        max_refl(i,j) = MAXVAL(refl(i,j,:))
      ENDDO
    ENDDO
    RETURN
  END SUBROUTINE reflectivity

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
#:include 'fycollections.fypp'

module type_int1list
  use fycollections
  implicit none
  private

  $:define_list_type(&
      & TYPE_NAME='Int1List',&
      & ITEM_TYPE_IN='integer',&
      & ITEM_ATTRIBS_IN='dimension(:)',&
      & ITEM_TYPE_OUT='integer',&
      & ITEM_ATTRIBS_OUT='dimension(:), allocatable')

end module type_int1list

ext: fpp

max_stars_repo_name: aradi/fycollections

max_issues_repo_name: aradi/fycollections

max_forks_repo_name: aradi/fycollections


text:
C
C $Id: hststr.f,v 1.6 2008-07-27 00:17:15 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C *****************************************************
C
        SUBROUTINE HSTSTR(LABEL,FIRST,LAST)
C
C *****************************************************
C
C  THIS CALCULATES THE POSITION OF THE FIRST NON-BLANK CHARACTER
C  AND THE POSITION OF THE LAST NON-BLANK CHARACTER IN LABEL
C
      INTEGER   FIRST, LAST
        CHARACTER*(*) LABEL
C
        LAST = LEN(LABEL)
        DO 860 I = 1,LAST
            IF (LABEL(I:I) .NE. ' ') GOTO 870
 860  CONTINUE
 870  FIRST = I
        IF (FIRST .NE. LAST) THEN
            DO 880 J = LAST,FIRST,-1
                  IF (LABEL(J:J) .NE. ' ') THEN
                  LAST = J
                  GOTO 890
                  ENDIF
 880      CONTINUE
 890  CONTINUE
        ENDIF
      RETURN
        END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
      SUBROUTINE PETPNO(TMAX, TMIN)

      IMPLICIT NONE

      REAL TMAX, TMIN, ESAT, EAIR

      REAL VPSLOP, VPSAT

C      ESAT = VPSAT(VPSLOP(VPSAT(TMIN))) + VPSLOP(VPSLOP(VPSAT(TMAX)))
C      ESAT = VPSAT(VPSLOP(VPSAT(TMIN)))
C      ESAT = VPSAT(VPSLOP(TMIN))

C      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0
C      EAIR = VPSAT(TDEW)

C      EAIR = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0

      RETURN
      END SUBROUTINE PETPNO

C=======================================================================

      REAL FUNCTION VPSAT(T)

      IMPLICIT NONE
      REAL T

      VPSAT = 610.78
C      VPSAT = 610.78 * EXP(17.269*T/(T+237.30))

      RETURN
      END FUNCTION VPSAT

C=======================================================================

      REAL FUNCTION VPSLOP(T)

      IMPLICIT NONE

      REAL T,VPSAT

      VPSLOP = 18.0
C      VPSLOP = 18.0 * (2501.0-2.373*T) * VPSAT(T) / (8.314*(T+273.0)**2)

      RETURN
      END FUNCTION VPSLOP

C=======================================================================

ext: for


text:
C
C
*+ redt_setfile

       subroutine redt_setfile(file,status)
C      ------------------------------------
C
C Set the current value of the file name
C
C Given:
C    file name
       character*(*)   file
C Returned:
C    status word
       integer         status
C
C The current value of the map filename is reset
C-
       include 'mapcat_stack.inc'

       if (status.ne.0) return
       current_filename = file
       call mapcat_err(status,'redt_setfile',' ')
       end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
subroutine rdmeteo(gdp, ecwind)
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  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 3.
!
!  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, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: rdmeteo.f90 6018 2016-04-15 11:41:55Z ye $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/io/src/input/rdmeteo.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: - Read meteo related items
!              - Initialize meteo module
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
   use meteo
   !use ec_module
   use precision
   use properties
   !
   use dfparall
   use globaldata
   !
   implicit none
   !
   ! Global variables
   !
   type(globdat),target :: gdp
   logical              :: ecwind  ! Temporary flag to switch between meteo and ec module
   !
   ! The following list of pointer parameters is used to point inside the gdp structure
   !
   integer                  , pointer :: nmax
   integer                  , pointer :: mmax
   integer                  , pointer :: mlb
   integer                  , pointer :: mub
   integer                  , pointer :: nmlb
   integer                  , pointer :: nmub
   integer                  , pointer :: nmaxus
   integer                  , pointer :: itdate
   integer                  , pointer :: nmaxgl
   integer                  , pointer :: mmaxgl
   real(fp)                 , pointer :: tstop
   real(fp)                 , pointer :: tzone
   real(fp)                 , pointer :: rhum
   real(fp)                 , pointer :: tair
   real(fp), dimension(:)   , pointer :: rhumarr
   real(fp), dimension(:)   , pointer :: tairarr
   real(fp), dimension(:)   , pointer :: clouarr
   real(fp), dimension(:)   , pointer :: swrfarr
   real(fp), dimension(:)   , pointer :: secchi
   logical                  , pointer :: rhum_file
   logical                  , pointer :: tair_file
   logical                  , pointer :: clou_file
   logical                  , pointer :: prcp_file
   logical                  , pointer :: swrf_file
   logical                  , pointer :: scc_file
   logical                  , pointer :: solrad_read
   type (gd_heat)           , pointer :: gdheat
   integer                  , pointer :: lundia
   real(fp)                 , pointer :: paver
   logical                  , pointer :: lfsdu
   logical                  , pointer :: lfsdus1
   logical                  , pointer :: pcorr
   logical                  , pointer :: wind
   logical                  , pointer :: temp
   integer                  , pointer :: ktemp
   logical                  , pointer :: sferic
   integer                  , pointer :: patmECItemId
   integer                  , pointer :: uwindECItemId
   integer                  , pointer :: vwindECItemId
   integer                  , pointer :: gridECItemId
!
! Local variables
!
   integer                              :: istat
   integer                              :: qId
   integer                              :: provid
   logical                              :: ex
   logical                              :: error       !!  Flag=TRUE if an error is encountered
   logical                              :: success
   logical                              :: interpolate
   logical                              :: p_file
   logical                              :: u_file
   logical                              :: v_file
   real(fp)                             :: rdef        ! Help var. containing default value(s) for real variable
   real(fp)                             :: extinc      ! Coefficient determining the penetration of the solar ray in the water column; also known as extinction coefficient
   real(fp)  , dimension(:,:) , pointer :: ectmp1
   real(fp)  , dimension(:,:) , pointer :: ectmp2
   real(fp)  , dimension(:,:) , pointer :: ectmp3
   character(10)                        :: value
   character(11)                        :: fmttmp      ! Help var. for the attribute file formats
   character(256)                       :: filename
   character(500)                       :: message
   type(tmeteoitem)           , pointer :: meteoitem
   !type(tECHandle)            , pointer :: ECHandle
!
!! executable statements -------------------------------------------------------
!
   nmaxgl        => gdp%gdparall%nmaxgl
   mmaxgl        => gdp%gdparall%mmaxgl
   nmax          => gdp%d%nmax
   mmax          => gdp%d%mmax
   mlb           => gdp%d%mlb
   mub           => gdp%d%mub
   nmlb          => gdp%d%nmlb
   nmub          => gdp%d%nmub
   nmaxus        => gdp%d%nmaxus
   itdate        => gdp%gdexttim%itdate
   tstop         => gdp%gdexttim%tstop
   tzone         => gdp%gdexttim%tzone
   rhum          => gdp%gdheat%rhum
   tair          => gdp%gdheat%tair
   rhumarr       => gdp%gdheat%rhumarr
   tairarr       => gdp%gdheat%tairarr
   clouarr       => gdp%gdheat%clouarr
   swrfarr       => gdp%gdheat%swrfarr
   rhum_file     => gdp%gdheat%rhum_file
   tair_file     => gdp%gdheat%tair_file
   clou_file     => gdp%gdheat%clou_file
   prcp_file     => gdp%gdheat%prcp_file
   swrf_file     => gdp%gdheat%swrf_file
   scc_file      => gdp%gdheat%scc_file
   solrad_read   => gdp%gdheat%solrad_read
   gdheat        => gdp%gdheat
   lfsdu         => gdp%gdprocs%lfsdu
   lfsdus1       => gdp%gdprocs%lfsdus1
   lundia        => gdp%gdinout%lundia
   paver         => gdp%gdnumeco%paver
   pcorr         => gdp%gdnumeco%pcorr
   wind          => gdp%gdprocs%wind
   temp          => gdp%gdprocs%temp
   ktemp         => gdp%gdtricom%ktemp
   sferic        => gdp%gdtricom%sferic
   !ECHandle      => gdp%gd_ECHandle
   !gridECItemId  => gdp%gridECItemId
   !patmECItemId  => gdp%patmECItemId
   !uwindECItemId => gdp%uwindECItemId
   !vwindECItemId => gdp%vwindECItemId
   !
   error     = .false.
   success   = initmeteo(gdp%runid)
   call checkmeteoresult(success, gdp)
   !
   ! All different wind options, only if wind == true
   !
   if (wind) then
      p_file    = .false.
      u_file    = .false.
      v_file    = .false.
      !
      if (ecwind) then
         !qId      = addQuantity(ECHandle, 'air_pressure')
         !patmECItemId = addECItem(ECHandle, qId, gridECItemId)
         !allocate(ectmp1(nmax,mmax))
         !success   = addECItemField(ECHandle, patmECItemId, ectmp1)
         !!
         !qId       = addQuantity(ECHandle, 'x_wind')
         !uwindECItemId = addECItem(ECHandle, qId, gridECItemId)
         !allocate(ectmp2(nmax,mmax))
         !success   = addECItemField(ECHandle, uwindECItemId, ectmp2)
         !!
         !qId       = addQuantity(ECHandle, 'y_wind')
         !vwindECItemId = addECItem(ECHandle, qId, gridECItemId)
         !allocate(ectmp3(nmax,mmax))
         !success   = addECItemField(ECHandle, vwindECItemId, ectmp3)
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filwnd',filename)
      if (filename /= ' ') then
         value = ' '
         call prop_get_string(gdp%mdfile_ptr,'*','Wnsvwp',value)
         if (index(value,'y')>=1 .or. index(value,'Y')>=1) then
            value = ' '
            call prop_get_string(gdp%mdfile_ptr,'*','Wndgrd',value)
            if ( index(value,'a')==0 .and. index(value,'A')==0 ) then
               !
               ! flow dimensions needed here
               !
               !if (patmECItemId == -1) then
                  success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
                  call checkmeteoresult(success, gdp)
                  call prterr(lundia, 'G051', 'Wind and pressure specified on the hydrodynamic grid')
                  p_file = .true.
                  u_file = .true.
                  v_file = .true.
               !else
                  ! the same but using ec-module
                  !
               !   provId   = addProvider(ECHandle, provType_file, filename, provFile_svwp)
               !   if (provId == 0) call checkResult(ECHandle)
               !   success  = initProvider(ECHandle, provId)
               !   call checkResult(ECHandle, success)
               !endif
            else
               !
               ! Wind on a separate equidistant grid specified in Filwu, Filwv, Filwp
               ! or wind on a separate curvilinear grid specified in Fwndgp, Fwndgu, Fwndgv
               !
               ! do not use the file specified in Filwnd
               !
               write(message,'(3a)') 'File ',trim(filename),' is not used'
               call prterr(lundia, 'Z013', trim(message))
            endif
         elseif (index(value,'n')>=1 .or. index(value,'N')>=1) then
            success = addmeteoitem(gdp%runid, filename)
            call checkmeteoresult(success, gdp)
            call prterr(lundia, 'G051', 'Uniform wind and pressure specified')
            p_file = .true.
            u_file = .true.
            v_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filspv',filename)
      if (filename /= ' ') then
         !
         ! flow dimensions needed here
         !
         success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
         call checkmeteoresult(success, gdp)
         if (p_file .and. u_file .and. v_file) then
            call prterr(lundia, 'G051', 'Multiple input for wind and pressure, using input specified on the hydrodynamic grid')
         else
            call prterr(lundia, 'G051', 'Wind and pressure specified on the hydrodynamic grid')
            p_file = .true.
            u_file = .true.
            v_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filwu',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call checkmeteoresult(success, gdp)
         if (u_file) then
            call prterr(lundia, 'G051', 'Multiple input for wind (U component), using input specified on a separate equidistant grid')
         else
            call prterr(lundia, 'G051', 'Wind (U component) specified on a separate equidistant grid')
            u_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filwv',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call checkmeteoresult(success, gdp)
         if (v_file) then
            call prterr(lundia, 'G051', 'Multiple input for wind (V component), using input specified on a separate equidistant grid')
         else
            call prterr(lundia, 'G051', 'Wind (V component) specified on a separate equidistant grid')
            v_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filwp',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call checkmeteoresult(success, gdp)
         if (p_file) then
            call prterr(lundia, 'G051', 'Multiple input for air pressure, using input specified on a separate equidistant grid')
         else
            call prterr(lundia, 'G051', 'Air pressure specified on a separate equidistant grid')
            p_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Fwndgu',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
         call checkmeteoresult(success, gdp)
         if (u_file) then
            call prterr(lundia, 'G051', 'Multiple input for wind (U component), using input specified on a separate curvilinear grid')
         else
            call prterr(lundia, 'G051', 'Wind (U component) specified on a separate curvilinear grid')
            u_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Fwndgv',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
         call checkmeteoresult(success, gdp)
         if (v_file) then
            call prterr(lundia, 'G051', 'Multiple input for wind (V component), using input specified on a separate curvilinear grid')
         else
            call prterr(lundia, 'G051', 'Wind (V component) specified on a separate curvilinear grid')
            v_file = .true.
         endif
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Fwndgp',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
         call checkmeteoresult(success, gdp)
         if (p_file) then
            call prterr(lundia, 'G051', 'Multiple input for air pressure, using input specified on a separate curvilinear grid')
         else
            call prterr(lundia, 'G051', 'Air pressure specified on a separate curvilinear grid')
            p_file = .true.
         endif
         message = getmeteomessage()
      endif
      !
      filename = ' '
      call prop_get_string(gdp%mdfile_ptr,'*','Filweb',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call checkmeteoresult(success, gdp)
         if (p_file .and. u_file .and. v_file) then
            call prterr(lundia, 'G051', 'Wind and pressure specified on a Spiderweb grid added to meteo input')
         else
            call prterr(lundia, 'G051', 'Wind and pressure specified on a Spiderweb grid')
            p_file = .true.
            u_file = .true.
            v_file = .true.
         endif
      endif
      !
      ! If p, u or v specified on file, then all three must be specified on file
      !
      if (p_file .or. u_file .or. v_file) then
         if (.not. p_file) then
            write(message,'(a)') 'Wind specification is incomplete; air pressure is missing'
            call prterr(lundia, 'U021', trim(message))
            call d3stop(1, gdp)
         endif
         if (.not. u_file) then
            write(message,'(a)') 'Wind specification is incomplete; U component is missing'
            call prterr(lundia, 'U021', trim(message))
            call d3stop(1, gdp)
         endif
         if (.not. v_file) then
            write(message,'(a)') 'Wind specification is incomplete; V component is missing'
            call prterr(lundia, 'U021', trim(message))
            call d3stop(1, gdp)
         endif
      endif
   endif
   !
   ! Cloudiness, relative air humidity and temperature
   !
   clou_file = .false.
   rhum_file = .false.
   tair_file = .false.
   scc_file  = .false.
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Fwndgr',filename)
   if (filename /= ' ') then
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call prterr(lundia, 'G051', 'Relative air humidity specified on a separate curvilinear grid')
   else
      call prop_get_string(gdp%mdfile_ptr,'*','Filwr',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call prterr(lundia, 'G051', 'Relative air humidity specified on a separate equidistant grid')
      endif
   endif
   if (filename /= ' ') then
      rhum_file = .true.
      call checkmeteoresult(success, gdp)
      allocate (gdp%gdheat%rhumarr(gdp%d%nmlb:gdp%d%nmub), stat = istat)
      if (istat/=0) then
         call prterr(lundia, 'U021', 'Rdmeteo: memory alloc error')
         call d3stop(1, gdp)
      endif
   else
      rhum_file = .false.
   endif
   !
   ! Air Temperature
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Fwndgt',filename)
   if (filename /= ' ') then
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call prterr(lundia, 'G051', 'Air temperature specified on a separate curvilinear grid')
   else
      call prop_get_string(gdp%mdfile_ptr,'*','Filwt',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call prterr(lundia, 'G051', 'Air temperature specified on a separate equidistant grid')
      endif
   endif
   if (filename /= ' ') then
      tair_file = .true.
      call checkmeteoresult(success, gdp)
      allocate (gdp%gdheat%tairarr(gdp%d%nmlb:gdp%d%nmub), stat = istat)
      if (istat/=0) then
         call prterr(lundia, 'U021', 'Rdmeteo: memory alloc error')
         call d3stop(1, gdp)
      endif
   else
      tair_file = .false.
   endif
   !
   ! Cloudiness
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Fwndgc',filename)
   if (filename /= ' ') then
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call prterr(lundia, 'G051', 'Air cloudiness specified on a separate curvilinear grid')
   else
      call prop_get_string(gdp%mdfile_ptr,'*','Filwc',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call prterr(lundia, 'G051', 'Air cloudiness specified on a separate equidistant grid')
      endif
   endif
   if (filename /= ' ') then
      clou_file = .true.
      call checkmeteoresult(success, gdp)
      allocate (gdp%gdheat%clouarr(gdp%d%nmlb:gdp%d%nmub), stat = istat)
      if (istat/=0) then
         call prterr(lundia, 'U021', 'Rdmeteo: memory alloc error')
         call d3stop(1, gdp)
      endif
   else
      clou_file = .false.
   endif
   !
   ! Precipitation
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Fwndgpr',filename)
   if (filename /= ' ') then
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call prterr(lundia, 'G051', 'Precipitation specified on a separate curvilinear grid')
   else
      call prop_get_string(gdp%mdfile_ptr,'*','Filwpr',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call prterr(lundia, 'G051', 'Precipitation specified on a separate equidistant grid')
      endif
   endif
   if (filename /= ' ') then
      prcp_file = .true.
      call checkmeteoresult(success, gdp)
   else
      prcp_file = .false.
   endif
   !
   ! Short-wave radiation flux
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Fwndgs',filename)
   if (filename /= ' ') then
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call prterr(lundia, 'G051', 'Short-wave solar radiation specified on a separate curvilinear grid')
   else
      call prop_get_string(gdp%mdfile_ptr,'*','Filws',filename)
      if (filename /= ' ') then
         success = addmeteoitem(gdp%runid, filename, sferic)
         call prterr(lundia, 'G051', 'Short-wave solar radiation specified on a separate equidistant grid')
      endif
   endif
   if (filename /= ' ') then
      swrf_file = .true.
      call checkmeteoresult(success, gdp)
      allocate (gdp%gdheat%swrfarr(gdp%d%nmlb:gdp%d%nmub), stat = istat)
      if (istat/=0) then
         call prterr(lundia, 'U021', 'Rdmeteo: memory alloc error')
         call d3stop(1, gdp)
      endif
   else
      swrf_file = .false.
   endif
   !
   !   Time and space varying Secchi depth
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Filscc',filename)
   if (filename /= ' ') then
      scc_file  = .true.
      if (.not.associated(gdp%gdheat%secchi)) then
          allocate (gdp%gdheat%secchi(gdp%d%nmlb:gdp%d%nmub), stat = istat)
          if (istat /= 0) then
             call prterr(lundia, 'P004', 'memory alloc error for Secchi depth')
             call d3stop(1, gdp)
          endif
      endif
      call prterr(lundia, 'G051', 'Secchi depth specified on a separate equidistant grid')
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call checkmeteoresult(success, gdp)
   else
      scc_file = .false.
   endif
   !
   !  Subsidence/Uplift
   !
   filename = ' '
   call prop_get_string(gdp%mdfile_ptr,'*','Filsdu',filename)
   if (filename /= ' ') then
      if (.not.associated(gdp%gdsdu%sdu_t0)) then
          allocate (gdp%gdsdu%sdu_t0(gdp%d%nmlb:gdp%d%nmub), stat = istat)
          if (istat == 0) allocate(gdp%gdsdu%sdu_tp(gdp%d%nmlb:gdp%d%nmub), stat=istat)
          if (istat == 0) allocate(gdp%gdsdu%sdu_tn(gdp%d%nmlb:gdp%d%nmub), stat=istat)
          if (istat /= 0) then
             call prterr(lundia, 'P004', 'memory alloc error for subsidence/uplift')
             call d3stop(1, gdp)
          endif
      endif
      call prterr(lundia, 'G051', 'Reading subsidence/uplift input on computational grid')
      success = addmeteoitem(gdp%runid, filename, sferic, mmaxgl, nmaxgl)
      call checkmeteoresult(success, gdp)
      if (lfsdus1) then
         call prterr(lundia, 'G051', '   Subsidence/uplift effect on water level included.')
      endif
   endif
   !
   ! If block 'interpolation', notify meteo module
   !
   interpolate = .true.
   call prop_get_logical(gdp%mdfile_ptr,'*','Wndint',interpolate)
   if (.not. interpolate) then
      call meteoblockint()
      call prterr(lundia, 'G051', 'No interpolation on meteo data')
   endif
   !
   ! Check whether meteo data is available for the complete time interval
   !
   success = checkmeteo(gdp%runid, itdate, tzone, tstop)
   call checkmeteoresult(success,gdp)
   !
   ! Relative humidity is only used for ktemp is 4 or 5
   !
   if (rhum_file) then
      if (ktemp/=4 .and. ktemp/=5) then
         write(message,'(a,i2)') 'Relative humidity is not used in heat model (ktemp) = ',ktemp
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! Air temperature is only used for ktemp is 4 or 5
   !
   if (tair_file) then
      if (ktemp/=4 .and. ktemp/=5) then
         write(message,'(a,i2)') 'Air temperature is not used in heat model (ktemp) = ',ktemp
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! Cloudiness is only used for ktemp is 5
   !
   if (clou_file) then
      if (ktemp /= 5) then
         write(message,'(a,i2)') 'Cloudiness is not used in heat model (ktemp) = ',ktemp
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! Short-wave radiation flux is only used for ktemp is 5
   !
   if (swrf_file) then
      if (ktemp /= 5) then
         write(message,'(a,i2)') 'Short-wave radiation is not used in heat model (ktemp) = ',ktemp
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! Time and space varying Secchi depth is only used for ktemp is 4 or 5
   !
   if (scc_file) then
      if (ktemp /= 5) then
         write(message,'(a,i2)') 'Time and space varying Secchi depth is not used in heat model (ktemp) = ',ktemp
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! If rhum, clou or tair specified on file, then all two (ktemp=4)/three(ktemp=5)
   ! must be specified on file
   !
   if (rhum_file .or. clou_file .or. tair_file) then
      if (solrad_read) then
         write(message,'(2a)') 'Meteo input on a separate grid ', &
                             & 'is not allowed in combination with input of solar radiation in .tem file.'
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
      if (.not. rhum_file) then
         write(message,'(a)') 'Air specification is incomplete; relative humidity is missing'
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
      if (.not. tair_file) then
         write(message,'(a)') 'Air specification is incomplete; temperature is missing'
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
      if (ktemp==5 .and. .not. clou_file) then
         write(message,'(a)') 'Air specification is incomplete; cloudiness is missing'
         call prterr(lundia, 'U021', trim(message))
         call d3stop(1, gdp)
      endif
   endif
   !
   ! For "Murakami" and "Ocean" model
   !
   if (ktemp==4 .or. ktemp==5) then
      if (.not. scc_file) then
         allocate (gdp%gdheat%secchi(gdp%d%nmlb:gdp%d%nmub), stat = istat)
         if (istat/=0) then
            call prterr(lundia, 'U021', 'Rdproc: memory alloc error')
            call d3stop(1, gdp)
         endif
         !
         secchi      => gdp%gdheat%secchi
         !
         secchi      = -1.0
         extinc      = -1.0
         !
         ! NEW INPUT:
         ! Locate and read 'Secchi' Secchidepth; default value allowed
         !
         filename = ' '
         call prop_get_string(gdp%mdfile_ptr, '*', 'Secchi', filename)
         if (filename == ' ') filename = 'dummyname'
         inquire (file = trim(filename), exist = ex)
         if (ex) then
            fmttmp = 'formatted'
         call depfil(lundia    ,error     ,filename  ,fmttmp    , &
                   & secchi    ,1         ,1         ,gdp%griddim)
         if (error) call d3stop(1, gdp)
         else
            filename = ' '
            rdef = secchi(1)
            call prop_get(gdp%mdfile_ptr, '*', 'Secchi', rdef)
            secchi = rdef
         endif
         !
         ! ORIGINAL INPUT:
         ! Locate and read 'Extinc' extiction coefficient for the solar
         ! insolation; default value allowed
         !
         call prop_get(gdp%mdfile_ptr, '*', 'Extinc', extinc)
         !
         if (secchi(1) == - 1.0_fp) then
            if (extinc == - 1.0_fp) then
               !
               ! both secchi and extinc not defined by user;
               ! secchi = default
               !
               ! old parametrisation: secchi = 1.7/0.127
               secchi = 2.0_fp
               write(message, '(a,f12.7,a)') 'Heat model: Default value used for Secchi depth: ', secchi(1), ' m'
               call prterr(lundia, 'G051', trim(message))
            else
               !
               ! secchi not defined by user;
               ! secchi = f(extinc)
               !
               secchi = 1.7_fp/extinc
               write(message, '(a,f12.7)') 'Heat model: Extinc specified to be ', extinc
               call prterr(lundia, 'G051', trim(message))
            endif
         !
         ! secchi is defined by user;
         ! warning when extinc is defined too
         !
         elseif (extinc /= - 1.0_fp) then
            if (filename == ' ') then
               write(message, '(a,f12.7,a)') 'Heat model: Secchi depth used instead of Extinc, with value ', secchi(1), ' m'
            else
               write(message, '(a,a)') 'Heat model: Extinc value skipped; Secchi depth read from ', trim(filename)
            endif
            call prterr(lundia, 'G051', trim(message))
            extinc = -1.0_fp
         else
            if (filename == ' ') then
               write(message, '(a,f12.7,a)') 'Heat model: Secchi depth specified to be ', secchi(1), ' m'
            else
               write(message, '(a,a)') 'Heat model: Secchi depth read from ', trim(filename)
            endif
            call prterr(lundia, 'G051', trim(message))
         endif
      endif
   endif
end subroutine rdmeteo

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
	FUNCTION PR_TMKF  ( tmpk )
C************************************************************************
C* PR_TMKF								*
C*									*
C* This function computes TMPF from TMPK.  The following equation is	*
C* used:								*
C*									*
C*             TMPF  =  ( ( TMPK - TMCK ) * 9 / 5 ) + 32		*
C*									*
C* REAL PR_TMKF  ( TMPK )						*
C*									*
C* Input parameters:							*
C*	TMPK		REAL		Temperature in Kelvin		*
C*									*
C* Output parameters:							*
C*	PR_TMKF		REAL		Temperature in Fahrenheit	*
C**									*
C* Log:									*
C* I. Graffman/CSC	 8/83	Original source code			*
C* I. Graffman/RDS	12/84	Modified equation			*
C* M. desJardins/GSFC	 4/86	Added PARAMETER statement		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with PR_TMKC	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	PARAMETER	( RPRM = 9.0 / 5.0 )
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpk ) )  THEN
	    PR_TMKF = RMISSD
	  ELSE
	    PR_TMKF = ( ( PR_TMKC (tmpk) ) * RPRM ) + 32.
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
*DECK FDUMP
      SUBROUTINE FDUMP
C***BEGIN PROLOGUE  FDUMP
C***PURPOSE  Symbolic dump (should be locally written).
C***LIBRARY   SLATEC (XERROR)
C***CATEGORY  R3
C***TYPE      ALL (FDUMP-A)
C***KEYWORDS  ERROR, XERMSG
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C        ***Note*** Machine Dependent Routine
C        FDUMP is intended to be replaced by a locally written
C        version which produces a symbolic dump.  Failing this,
C        it should be replaced by a version which prints the
C        subprogram nesting list.  Note that this dump must be
C        printed on each of up to five files, as indicated by the
C        XGETUA routine.  See XSETUA and XGETUA for details.
C
C     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  FDUMP
C***FIRST EXECUTABLE STATEMENT  FDUMP
      RETURN
      END


text:
include '../User_Mod/Impinging_Jet_Nu.f90'
include '../User_Mod/Impinging_Jet_Profiles.f90'

!==============================================================================!
  subroutine User_Mod_Save_Results(flow, turb, mult, swarm, ts)
!------------------------------------------------------------------------------!
!   Calls User_Impinging_Jet_Nu and User_Impinging_Jet_Profile functions.      !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type)      :: flow
  type(Turb_Type)       :: turb
  type(Multiphase_Type) :: mult
  type(Swarm_Type)      :: swarm
  integer               :: ts     ! time step
!==============================================================================!

  call User_Mod_Impinging_Jet_Nu      (turb)
  call User_Mod_Impinging_Jet_Profiles(turb)

  end subroutine

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


text:
c###f2dis.for
      SUBROUTINE F2DIS (FMUF, SSN, CLAT, FREQ, ABB, SIG)
C--------------------------------
c          re-written 3/20/2009 by Greg Hand to modern Fortran
C--------------------------------
C
C     THIS ROUTINE OBTAINS THE UPPER AND LOWER DECILE FOR THE F2 MUF
C
C     USES TABLES OF F2 MUF(3000)  (IE MUF FOR A DISTANCE OF 3000 KM)
C
C FMUF IS F2 MUF,MHZ.
C SSN  IS SUNSPOT NUMBER.
C CLAT IS GEOGRAPHIC LATITUDE, RADIANS.
C FREQ IS OPERATING FREQUENCY,MHZ.
C ABB  IS LOCAL MEAN TIME (HOURS)   SEE CLCK(K)
C SIG  IS STANDARD DEVIATION OF F2 MUF (NORMAL)
C
      COMMON / TWO / F2D(16,6,6), P(29,16,8), ABP(2,9), DUD(5,12,5),
     A FAM(14,12), SYS(9,16,6), PERR(9,4,6)

      IF(F2D(1,1,1).le.0) then   !  No ionospheric data - use classical values
         SIG=0.15*FMUF/1.28155
         SIG=AMAX1(SIG,0.001)
         RETURN
      end if

      CL = CLAT * 57.29577    !  convert to degrees
      ICC = ABB / 4.0 + 1.55  !  4 hour time blocks
      IF(ICC.gt.6) ICC=1      !  make sure index is within limits

      IF(FREQ.le.FMUF) then
         I = 8                !  lower decile
      else
         I = 0                !  upper decile
      end if

      ICL = 9.5 - ABS (CL) / 10.
      if(ICL.lt.1) ICL=1    !  limit index
      if(ICL.gt.8) ICL=8    !  limit index
      IZ = ICL + I

      J=2                     !  50 < SSN <= 100
      if(SSN.le.50.) J=1      !  SSN <=  50
      if(SSN.gt.100.) J=3     !  SSN >  100

      if(cl.le.0.) J=J+3      !  Southern Hemisphere
      SIG = ABS(FMUF - F2D(IZ,J,ICC) * FMUF) / 1.28
      IF (SIG .LE. 0.001) SIG = 0.001
      RETURN
      END
C--------------------------------

max_stars_repo_name: jawatson/voacapl

max_issues_repo_name: jawatson/voacapl

max_forks_repo_name: jawatson/voacapl


subroutine unlink(filename)
!! deletes file in Fortran standard manner.
!! Silently continues if file doesn't exist or cannot be deleted.
!! the GNU extension unlink() is non-standard and crashes ifort runtimes.
character(*), intent(in) :: filename
integer :: i, u

open(newunit=u, file=filename, iostat=i)
close(u, status='delete', iostat=i)

end subroutine unlink


text:
module host_memory_plugin
    use :: host_storage_module, only : host_storage
    use :: host_data_manager_module, only : host_data_manager
    use :: host_builder_module, only : host_builder

    implicit none
end module host_memory_plugin

max_stars_repo_name: cheshyre/ntcl-data

max_issues_repo_name: cheshyre/ntcl-data

max_forks_repo_name: cheshyre/ntcl-data


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Copyright (c) 1997 Neil N. Carlson
!!
!! This file is part of MFE1 which is released under the MIT license.  See the
!! file LICENSE or visit http://opensource.org/licenses/MIT for details.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module kind_parameters     ! Temporary hack.

  ! This should give 8-byte reals (double precision)
  integer, parameter, public :: r8 = selected_real_kind (10, 50)

end module kind_parameters


text:
	SUBROUTINE G2T_A2RBEB ( ktype, lunb, nt, end, iret )
C************************************************************************
C* G2T_A2RBEB								*
C*									*
C* This subroutine creates G2T trending text, period A becoming B.	*
C*									*
C* G2T_A2RBEB ( KTYPE, LUNB, NT, END, IRET )				*
C*									*
C* Input parameters:							*
C*	KTYPE		INTEGER		Data type			*
C*					 1 = Wave			*
C*					 2 = Wind			*
C*	LUNB		INTEGER		LUN for G2T_TXT.TBL		*
C*	NT		INTEGER		Nth time step			*
C*	END		INTEGER		Appending text, 'EARLY'/'LATE'	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* T. Lee/SAIC		06/07	Created					*
C* T. Lee/SAIC		08/07	Added wind trending simplification	*
C* T. Lee/SAIC		11/07	Added NT for combining periods		*
C* T. Lee/SAIC		03/08	Reset "PORTION" flag			*
C************************************************************************
	CHARACTER*(*)	end
	INCLUDE		'goftxt.cmn'
C------------------------------------------------------------------------
	iret = 0
C
	nt1 = nt + 1
C
C*	Store RaEa in trending block 1, RbEb in 2.
C
	itrnd = 1
	CALL G2T_ABC ( ktype, nt, itrnd, ier )
C
	itrnd = 2
	CALL G2T_ABC ( ktype, nt1, itrnd, ier )
C
C*	Simplify and trim text.
C
	CALL G2T_TRIM2 ( ktype, iret )
C
C*	Create the text.
C
	CALL G2T_AWSTXT ( ktype, lunb, nt, end, ier )
C*
	RETURN
	END


text:
! { dg-do compile }

! PR fortran/36492
! Similar to the ICE-test, but now test it works for real constants.

implicit none

integer, parameter :: a = 42
type t
  character (a) :: arr (1) = [ "a" ]
end type t

end

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
*DECK REBAK
      SUBROUTINE REBAK (NM, N, B, DL, M, Z)
C***BEGIN PROLOGUE  REBAK
C***PURPOSE  Form the eigenvectors of a generalized symmetric
C            eigensystem from the eigenvectors of derived matrix output
C            from REDUC or REDUC2.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (REBAK-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REBAKA,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine forms the eigenvectors of a generalized
C     SYMMETRIC eigensystem by back transforming those of the
C     derived symmetric matrix determined by  REDUC  or  REDUC2.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, B and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix system.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        B contains information about the similarity transformation
C          (Cholesky decomposition) used in the reduction by  REDUC
C          or  REDUC2  in its strict lower triangle.  B is a two-
C          dimensional REAL array, dimensioned B(NM,N).
C
C        DL contains further information about the transformation.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed in its
C          first M columns.  Z is a two-dimensional REAL array
C          dimensioned Z(NM,M).
C
C     On Output
C
C        Z contains the transformed eigenvectors in its first
C          M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REBAK
C
      INTEGER I,J,K,M,N,I1,II,NM
      REAL B(NM,*),DL(*),Z(NM,*)
      REAL X
C
C***FIRST EXECUTABLE STATEMENT  REBAK
      IF (M .EQ. 0) GO TO 200
C
      DO 100 J = 1, M
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
         DO 100 II = 1, N
            I = N + 1 - II
            I1 = I + 1
            X = Z(I,J)
            IF (I .EQ. N) GO TO 80
C
            DO 60 K = I1, N
   60       X = X - B(K,I) * Z(K,J)
C
   80       Z(I,J) = X / DL(I)
  100 CONTINUE
C
  200 RETURN
      END


text:
Westlake Plaza Westlake Plaza Phones
  Food Fair (530) 7579712 (In front of Food Fair Supermarket).
  Food Fair (530) 7579719 (South of Food Fair Supermarket).
Circle K Phones
  (530) 2977619 (Just north of Circle K)

(From Payphone Project)


text:
!Implemented by Anant Dixit (Oct, 2014)
program mdr
implicit none
integer :: i, mdr, mp, n, j
character(len=*), parameter :: hfmt = '(A18)', nfmt = '(I6)'
character(len=*), parameter :: cfmt = '(A3)', rfmt = '(I3)', ffmt = '(I9)'

write(*,hfmt) 'Number   MDR   MP '
write(*,*) '------------------'

i = 123321
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 3939
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 8822
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

i = 39398
call root_pers(i,mdr,mp)
write(*,nfmt,advance='no') i
write(*,cfmt,advance='no') '   '
write(*,rfmt,advance='no') mdr
write(*,cfmt,advance='no') '   '
write(*,rfmt) mp

write(*,*)
write(*,*)
write(*,*) 'First five numbers with MDR in first column: '
write(*,*) '---------------------------------------------'

do i = 0,9
  n = 0
  j = 0
  write(*,rfmt,advance='no') i
  do
    call root_pers(j,mdr,mp)
    if(mdr.eq.i) then
      n = n+1
      if(n.eq.5) then
        write(*,ffmt) j
        exit
      else
        write(*,ffmt,advance='no') j
      end if
    end if
    j = j+1
  end do
end do

end program

subroutine root_pers(i,mdr,mp)
implicit none
integer :: N, s, a, i, mdr, mp
n = i
a = 0
if(n.lt.10) then
  mdr = n
  mp = 0
  return
end if
do while(n.ge.10)
  a = a + 1
  s = 1
  do while(n.gt.0)
    s = s * mod(n,10)
    n = int(real(n)/10.0D0)
  end do
  n = s
end do
mdr = s
mp = a
end subroutine

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
module staggered_real_linear_systems_solver

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip ! Integer precision

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use type_StaggeredCyclicReductionUtility, only: &
        StaggeredCyclicReductionUtility

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: poistg

    ! Parameters confined to the module
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: LOG_TWO = log(TWO)

contains

    ! SUBROUTINE poistg(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
    !
    !
    ! DIMENSION OF           a(m),  b(m),  c(m),  y(idimy, n)
    ! ARGUMENTS
    !
    ! PURPOSE                Solves the linear system of equations
    !                        for unknown x values, where i=1, 2, ..., m
    !                        and j=1, 2, ..., n
    !
    !                        a(i)*x(i-1, j) + b(i)*x(i, j) + c(i)*x(i+1, j)
    !                        + x(i, j-1) - TWO *x(i, j) + x(i, j+1)
    !                        = y(i, j)
    !
    !                        The indices i+1 and i-1 are evaluated modulo m,
    !                        i.e. x(0, j) = x(m, j) and x(m+1, j) = x(1, j), and
    !                        x(i, 0) may be equal to x(i, 1) or -x(i, 1), and
    !                        x(i, n+1) may be equal to x(i, n) or -x(i, n),
    !                        depending on an input parameter.
    !
    ! USAGE                  call poistg(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
    !
    ! ARGUMENTS
    ! ON INPUT
    !
    !                        nperod
    !                          Indicates values which x(i, 0) and x(i, n+1)
    !                          are assumed to have.
    !                          = 1 if x(i, 0) = -x(i, 1) and x(i, n+1) = -x(i, n
    !                          = 2 if x(i, 0) = -x(i, 1) and x(i, n+1) =  x(i, n
    !                          = 3 if x(i, 0) =  x(i, 1) and x(i, n+1) =  x(i, n
    !                          = 4 if x(i, 0) =  x(i, 1) and x(i, n+1) = -x(i, n
    !
    !                        n
    !                          the number of unknowns in the j-direction.
    !                          n must be greater than 2.
    !
    !                        mperod
    !                          = 0 if a(1) and c(m) are not zero
    !                          = 1 if a(1) = c(m) = 0
    !
    !                        m
    !                          the number of unknowns in the i-direction.
    !                          m must be greater than 2.
    !
    !                        a, b, c
    !                          One-dimensional arrays of length m that
    !                          specify the coefficients in the linear
    !                          equations given above. If mperod = 0 the
    !                          array elements must not depend on index i,
    !                          but must be constant. Specifically, the
    !                          subroutine checks the following condition
    !                            a(i) = c(1)
    !                            b(i) = b(1)
    !                            c(i) = c(1)
    !                          for i = 1, 2, ..., m.
    !
    !                        idimy
    !                          The row (or first) dimension of the two-
    !                          dimensional array y as it appears in the
    !                          program calling poistg. This parameter is
    !                          used to specify the variable dimension of y.
    !                          idimy must be at least m.
    !
    !                        y
    !                          A two-dimensional array that specifies the
    !                          values of the right side of the linear system
    !                          of equations given above.
    !                          y must be dimensioned at least m x n.
    !
    ! ON OUTPUT
    !
    !                        Y
    !                          Contains the solution x.
    !
    !                        ierror
    !                          An error flag that indicates invalid input
    !                          parameters.  except for number zero, a
    !                          solution is not attempted.
    !                          = 0  no error
    !                          = 1  if m <= 2
    !                          = 2  if n <= 2
    !                          = 3  idimy < m
    !                          = 4  if nperod < 1 or nperod > 4
    !                          = 5  if mperod < 0 or mperod > 1
    !                          = 6  if mperod = 0 and a(i) /= c(1)
    !                               or b(i) /= b(1) or c(i) /= c(1)
    !                               for some i = 1, 2, ..., m.
    !                          = 7  if mperod == 1 and (a(1)/= 0 or c(m)/= 0)
    !                          = 20 If the dynamic allocation of real and
    !                               complex workspace required for solution
    !                               fails (for example if n, m are too large
    !                               for your computer)
    !
    !                          Since this is the only means of indicating a
    !                          possibly incorrect call to pois3d, the user
    !                          should test ierror after the call.
    !
    !
    ! HISTORY                Written by Roland Sweet at NCAR in the late
    !                        1970's.  Released on NCAR'S public software
    !                        libraries in January, 1980.
    !                        Revised in June 2004 by John Adams using
    !                        Fortran 90 dynamically allocated workspace.
    !
    !
    ! ALGORITHM              This subroutine is an implementation of the
    !                        algorithm presented in the reference below.
    !
    ! TIMING                 For large m and n, the execution time is
    !                        roughly proportional to m*n*log2(n).
    !
    ! ACCURACY               To measure the accuracy of the algorithm a
    !                        uniform random number generator was used to
    !                        create a solution array x for the system given
    !                        in the 'purpose' section above, with
    !
    !                          a(i) = c(i) = -HALF * b(i) = 1,    i=1, 2, ..., m
    !                        and, when mperod = 1
    !                          a(1) = c(m) = 0
    !                          b(1) = b(m) =-1.
    !
    !                        The solution x was substituted into the given
    !                        system and, using double precision, a right sid
    !                        y was computed.  using this array y subroutine
    !                        poistg was called to produce an approximate
    !                        solution z.  then the relative error, defined a
    !
    !                         e = max(abs(z(i, j)-x(i, j)))/max(abs(x(i, j)))
    !
    !                        where the two maxima are taken over i=1, 2, ..., m
    !                        and j=1, 2, ..., n, was computed.  values of e are
    !                        given in the table below for some typical value
    !                        of m and n.
    !
    !                        m (=n)    mperod    nperod      e
    !                        ------    ------    ------    ------
    !
    !                          31        0-1       1-4     9.e-13
    !                          31        1         1       4.e-13
    !                          31        1         3       3.e-13
    !                          32        0-1       1-4     3.e-12
    !                          32        1         1       3.e-13
    !                          32        1         3       1.e-13
    !                          33        0-1       1-4     1.e-12
    !                          33        1         1       4.e-13
    !                          33        1         3       1.e-13
    !                          63        0-1       1-4     3.e-12
    !                          63        1         1       1.e-12
    !                          63        1         3       2.e-13
    !                          64        0-1       1-4     4.e-12
    !                          64        1         1       1.e-12
    !                          64        1         3       6.e-13
    !                          65        0-1       1-4     2.e-13
    !                          65        1         1       1.e-11
    !                          65        1         3       4.e-13
    !
    ! REFERENCES             Schumann, U. and R. Sweet, "A direct method
    !                        for the solution of Poisson's equation with
    !                        Neumann boundary conditions on a staggered
    !                        grid of arbitrary size, " J. Comp. Phys.
    !                        20 (1976), pp. 171-182.
    !
    subroutine poistg(nperod, n, mperod, m, a, b, c, idimy, y, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: nperod
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: mperod
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: idimy
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a(:)
        real(wp),    intent(in)     :: b(:)
        real(wp),    intent(in)     :: c(:)
        real(wp),    intent(inout)  :: y(:,:)

        ! Local variables
        integer(ip)                           :: irwk, icwk
        type(FishpackWorkspace)               :: workspace
        type(StaggeredCyclicReductionUtility) :: util

        ! Compute workspace dimensions
        irwk = m * (9 + int(log(real(n, kind=wp))/LOG_TWO,kind=ip)) + 4 * n
        icwk = 0

        ! Allocate memory
        call workspace%create(irwk, icwk)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call util%poistg_lower_routine(nperod, n, mperod, m, a, b, c, idimy, y, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine poistg

end module staggered_real_linear_systems_solver

max_stars_repo_name: jlokimlin/fishpack

max_issues_repo_name: jlokimlin/fishpack


text:
	SUBROUTINE RU_DECD  ( isnfln, dattim, istnm, stid, part, itopwn,
     +			      wnknot, ihhmm,  report, lenr, txtflg,
     +			      xlat, xlon, iwndht, irpnt, iret )
C************************************************************************
C* RU_DECD								*
C*									*
C* This subroutine decodes a single upper air report and writes the	*
C* data to a file.  The header information and DATTIM must be found	*
C* before this subroutine is called.  IRPNT must point to the first	*
C* field after the header.  This subroutine may be used for either	*
C* real-time or archived data.  Note that this subroutine		*
C* has no ADDSTN option.  Any reporting station which is not		*
C* already in the sounding file will be added to it if there is room.	*
C*									*
C* RU_DECD  ( ISNFLN, DATTIM, ISTNM, STID, PART, ITOPWN, WNKNOT, IHHMM,	*
C*            REPORT, LENR, TXTFLG, XLAT, XLON, IWNDHT, IRPNT, IRET )	*
C*									*
C* Input parameters:							*
C*	ISNFLN		INTEGER		Sounding file number		*
C*	DATTIM		CHAR*		Observation time		*
C*	ISTNM		INTEGER		Station number			*
C*	STID		CHAR*		Station identifier		*
C*	PART		CHAR*4		Part name			*
C*	ITOPWN		INTEGER		Top level reporting winds	*
C*	WNKNOT		LOGICAL		Flag for wind in knots		*
C*	IHHMM		INTEGER		Actual hour/minute of report	*
C*	REPORT		CHAR*		Report				*
C*	LENR		INTEGER		Length of report		*
C*	TXTFLG		LOGICAL		Flag to save undecoded text     *
C*	XLAT		REAL		Dropsonde latitude              *
C*	XLON		REAL		Dropsonde longitude             *
C*      IWNDHT          INTEGER         Dropsonde wind cutoff value     *
C*									*
C* Input and output parameters:						*
C*	IRPNT		INTEGER		Pointer to next field		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -2 = no data found		*
C*					 -4 = error in setting station	*
C*					 -5 = error in setting time	*
C*					xx - 900 = error xx in SN_WPRT	*
C*					xx - 800 see RU_TMST            *
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/87						*
C* M. desJardins/GSFC	 4/89	Correction to call to SN_WPRT		*
C* D. Kidwell/NCEP	10/98	Corrected prologue; added -5 return code*
C* D. Kidwell/NCEP	 2/01	Added text output option, trop & max wnd*
C* D. Kidwell/NCEP	 3/01	Added xlat, xlon to call sequences      *
C* S. Chiswell/Unidata	 5/01	Added stid, changed RU_TMST call seq.	*
C* m.gamazaychikov/SAIC 07/05   Added iwndht to CS, code for sfc wind	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	dattim, part, report, stid
	LOGICAL		wnknot, txtflg
C*
	CHARACTER	tpart*4, dpart*4
	LOGICAL		zwind, dzwind, drpwnd
	REAL		data  ( 3 * LLMXLV ), wdata ( 3 * LLMXLV ),
     +			tdata ( 3 * LLMXLV ), wxdata ( 3 * LLMXLV ),
     +			ddata ( 3 * LLMXLV )
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret  = 0
	nlev1 = 0
	nlev2 = 0
	nlevt = 0
	nlevw = 0
	nlevd = 0
	drpwnd = .false.
C
C*	Decode data for various parts.
C
	IF  ( part .eq. 'TTAA' )  THEN
	    CALL RU_TTAA  ( report, lenr,  itopwn, wnknot, iwndht,
     +			    irpnt, istnm, data, nlev1, tdata, nlevt,
     +			    wxdata, nlevw, drpwnd, iret)
C
C*          Compare the existing PPBB data to the current TTAA data
C*          to find the non-missing wind with the highest pressure
C
            IF ( drpwnd ) THEN
	       dpart = 'PPBB'
	       CALL RU_DUPE ( isnfln, dattim, istnm, stid, dpart,
     +		              ihhmm, nlevd, ddata, dzwind, ier )
	       IF ( ier .eq. 1 ) THEN
	          IF ( ( .not. dzwind ) .and.
     +                 ( ERMISS ( data ( 4 ) ) ) ) THEN
	             CALL RU_DRP2 ( nlev1, data, nlevd, ddata, sfcdir,
     +                              sfcspd, ier )
	             data ( 4 ) = sfcdir
	             data ( 5 ) = sfcspd
                  END IF
	       END IF
	       drpwnd = .false.
	    END IF
C
	  ELSE IF  ( part .eq. 'TTBB' )  THEN
	    CALL RU_TTBB  ( report, lenr,  wnknot, iwndht, irpnt,
     +                      istnm, data, nlev1, wdata,  nlev2, drpwnd,
     +			    iret )
C
C*          Compare the existing TTAA data to the current TTBB data
C*          to find the non-missing wind with the highest pressure
C
            IF ( drpwnd ) THEN
	       dpart = 'TTAA'
	       CALL RU_DUPE ( isnfln, dattim, istnm, stid, dpart,
     +		              ihhmm, nlevd, ddata, dzwind, ier )
	       drpwnd = .false.
	       IF ( ier .eq. 1 ) THEN
	          IF ( ERMISS ( ddata ( 4 ) ) )  THEN
	             CALL RU_DRP2 ( nlevd, ddata, nlev2, wdata,
     +                              sfcdir, sfcspd, ier )
	             ddata ( 4 ) = sfcdir
	             ddata ( 5 ) = sfcspd
	             drpwnd = .true.
	          END IF
	       END IF
	    END IF
C
	  ELSE IF  ( part .eq. 'TTCC' )  THEN
	    CALL RU_TTCC  ( report, lenr,  itopwn, wnknot, irpnt,
     +			    data,   nlev1, tdata, nlevt, wxdata, nlevw,
     +			    iret )
C
	  ELSE IF  ( part .eq. 'TTDD' )  THEN
	    CALL RU_TTDD  ( report, lenr,  wnknot, irpnt, data,  nlev1,
     +			    wdata,  nlev2, iret )
C
	  ELSE IF  ( part .eq. 'PPAA' )  THEN
	    CALL RU_PPAA  ( report, lenr, wnknot, irpnt, data,  nlev1,
     +			    iret )
C
	  ELSE IF  ( part .eq. 'PPBB' )  THEN
	    CALL RU_PPBB  ( report, lenr,  wnknot, irpnt, data, nlev1,
     +			    wdata,  nlev2, iret )
C
	  ELSE IF  ( part .eq. 'PPCC' )  THEN
	    CALL RU_PPCC  ( report, lenr, wnknot, irpnt, data, nlev1,
     +			    iret )
C
	  ELSE IF  ( part .eq. 'PPDD' )  THEN
	    CALL RU_PPDD  ( report, lenr,  wnknot, irpnt, data, nlev1,
     +			    wdata,  nlev2, iret )
	END IF
C
C*	Write the data to the file.
C
	IF  ( ( iret .eq. 0 ) .and.
     +	      ( ( nlev1 .gt. 0 ) .or. ( nlev2 .gt. 0 )  .or.
     +	      ( ( nlevd .gt. 0 ) .and.  drpwnd ) ) ) THEN
C
C*	    Set correct time and station in sounding file.
C
	    CALL RU_TMST  ( isnfln, dattim, istnm, stid, xlat, xlon,
     +			    iret )
	    IF  ( iret .ne. 0 )  THEN
		RETURN
	    END IF
C
C*	    Rewrite part of TTAA with updated surface wind information.
C
            IF  ( ( nlevd .gt. 0 ) .and.  drpwnd )  THEN
		zwind = .true.
		CALL SN_WPRT  ( isnfln, dpart, ihhmm, nlevd, ddata,
     +				zwind,  ier )
	    END IF
C
C*	    Write the first report to the file.
C
	    IF  ( nlev1 .gt. 0 )  THEN
		zwind = .true.
		CALL SN_WPRT  ( isnfln, part, ihhmm, nlev1, data,
     +				zwind,  ier )
C
C*	        Write the tropopause data.
C
		IF ( nlevt .gt. 0 ) THEN
		    IF ( part .eq. 'TTAA' ) THEN
			tpart = 'TRPA'
		      ELSE
			tpart = 'TRPC'
		    END IF
      		    CALL SN_WPRT ( isnfln, tpart, ihhmm, nlevt, tdata,
     +				   zwind, ier )
		END IF
C
C*	        Write the max wind data.
C
		IF ( nlevw .gt. 0 )  THEN
		    IF ( part .eq. 'TTAA' ) THEN
			tpart = 'MXWA'
		      ELSE
			tpart = 'MXWC'
		    END IF
      		    CALL SN_WPRT ( isnfln, tpart, ihhmm, nlevw, wxdata,
     +				   zwind, ier )
		END IF
C
C*	        Write the text.
C
		IF ( txtflg ) THEN
		    IF ( ( part .eq. 'TTAA' ) .or.
     +			 ( part .eq. 'TTBB' ) .or.
     +		         ( part .eq. 'TTCC' ) .or.
     +			 ( part .eq. 'PPBB' ) ) THEN
			tpart = 'TX' // part ( 2:3)
 			CALL SN_WSTR ( isnfln, tpart, ihhmm,
     +				       report ( :lenr ), ier )
		    END IF
		END IF
	    END IF
C
C*	    Write the second report to the file.
C
	    IF  ( nlev2 .gt. 0 )  THEN
		zwind = .false.
		IF  ( part .eq. 'TTBB' )  THEN
		    tpart = 'PPBB'
		  ELSE IF  ( part .eq. 'TTDD' )  THEN
		    tpart = 'PPDD'
		  ELSE
		    tpart = part
		END IF
		CALL SN_WPRT  ( isnfln, tpart, ihhmm, nlev2, wdata,
     +				zwind,  ier )
C
C*	        Write the text.
C
		IF ( txtflg ) THEN
		    IF ( ( part .eq. 'PPBB' ) .or.
     +		         ( part .eq. 'TTBB' .and. nlev1 .le. 0 ) ) THEN
			tpart = 'TXPB'
 			CALL SN_WSTR ( isnfln, tpart, ihhmm,
     +				       report ( :lenr ), ier )
		    END IF
		END IF
	    END IF
C
C*	    Set return code if there was a write error.
C
	    IF  ( ier .ne. 0 )  iret = ier - 900
C
	END IF
C*
	RETURN
	END


text:
!
! Copyright (c) 2015, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!

program p
 type dt
  character(len=3) n
  character(len=3) m
  character(len=3) p
  real r
 end type
 type(dt),parameter:: alpha = dt('cad','cab','tar',2.0)
 character(len=3) n
 integer result(7), expect(7)
 data expect/99,101,99,101,100,99,101/

 n = 'car'
 select case(n)
 case(alpha%n:)
  result(1) = 99
 case(alpha%m)
  result(1) = 100
 case default
  result(1) = 101
 end select

 n = 'tee'
 select case(n)
 case(alpha%n:alpha%p)
  result(2) = 99
 case(alpha%m)
  result(2) = 100
 case default
  result(2) = 101
 end select

 n = 'tab'
 select case(n)
 case(alpha%n:alpha%p)
  result(3) = 99
 case(alpha%m)
  result(3) = 100
 case default
  result(3) = 101
 end select

 n = 'car'
 select case(n)
 case(alpha%n)
  result(4) = 99
 case(alpha%m)
  result(4) = 100
 case default
  result(4) = 101
 end select

 n = 'cab'
 select case(n)
 case(alpha%n)
  result(5) = 99
 case(alpha%m)
  result(5) = 100
 case default
  result(5) = 101
 end select

 n = 'pop'
 select case(n)
 case(alpha%n:'zebra')
  result(6) = 99
 case(alpha%m)
  result(6) = 100
 case default
  result(6) = 101
 end select

 n = 'pop'
 select case(n)
 case(alpha%n:'fez')
  result(7) = 99
 case(alpha%m)
  result(7) = 100
 case default
  result(7) = 101
 end select

 call check(result,expect,7)
end program

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang