!############################# Change Log ##################################
! 2.0.0
!
!###########################################################################
!  Copyright (C)  1990, 1995, 1999, 2000, 2003 - All Rights Reserved
!  Regional Atmospheric Modeling System - RAMS
!###########################################################################

subroutine aminmax(n1,n2,n3,a)
  implicit none
  integer :: n1,n2,n3
  real :: a(n1,n2,n3)
  integer :: k,i,j
  real :: xmax,xmin

  do k=1,n1
     xmin=1e20
     xmax=-1e20
     do j=1,n3
        do i=1,n2
           xmin=min(xmin,a(k,i,j))
           xmax=max(xmax,a(k,i,j))
        enddo
     enddo
     print*,'Max,min:',k,xmin,xmax
  enddo
  return
end subroutine aminmax

!***************************************************************************

subroutine RAMS_mm(indata,ni1,omin,omax)
  implicit none
  integer :: ni1
  real :: indata(ni1),omin,omax
  integer :: i

  omax=indata(1)
  omin=indata(1)
  do i=2,ni1
     omax=max(indata(i),omax)
     omin=min(indata(i),omin)
  enddo

  return
end subroutine RAMS_mm

!***************************************************************************

subroutine RAMS2_mm(m1m,m2m,indata,ni1,vmin,vmax)
  implicit none
  integer :: m1m,m2m,ni1
  real :: indata(m1m,m2m),vmin,vmax
  integer :: ini

  vmax=-1.E30
  vmin=1.E31
  do ini=1,ni1
     if(indata(1,ini).lt.1.e20) then
        vmax=max(indata(1,ini),vmax)
        vmin=min(indata(1,ini),vmin)
     endif
  enddo

  return
end subroutine RAMS2_mm

!***************************************************************************

real function walltime(wstart)
  implicit none
  real :: wstart
  integer :: ii,ir

  call system_clock(count=ii,count_rate=ir)
  walltime=float(ii)/float(ir) - wstart
  return
end function walltime

real function cputime(w1)
  implicit none
  real :: w1
  real :: cc,fsecs
  real, external :: walltime

  call timing(2,cc)
  cputime=cc
  fsecs=72559200.
  w1=walltime(fsecs)
  return
end function cputime

!***************************************************************************

subroutine rearrange(nzp,nxp,nyp,a,b)
  implicit none
  integer :: nzp,nxp,nyp
  real :: a(nzp,nxp,nyp),b(nxp,nyp,nzp)
  integer :: k,i,j

  do i=1,nxp
     do j=1,nyp
        do k=1,nzp
           b(i,j,k)=a(k,i,j)
        enddo
     enddo
  enddo
  return
end subroutine rearrange

!***************************************************************************

subroutine unarrange(nzp,nxp,nyp,a,b)
  implicit none
  integer :: nzp,nxp,nyp
  real :: a(nxp,nyp,nzp),b(nzp,nxp,nyp)
  integer :: k,i,j

  do i=1,nxp
     do j=1,nyp
        do k=1,nzp
           b(k,i,j)=a(i,j,k)
        enddo
     enddo
  enddo
  return
end subroutine unarrange

!***************************************************************************

subroutine makefnam (fname,prefix,tinc,iyr,imn,idy,itm,type,post,fmt)

  ! creates standard timestamped filename

  implicit none

  integer :: iyr, imn, idy, itm
  character(len=*) ::  fname,prefix,post
  character(len=3) :: fmt
  character(len=1) :: type

  real :: tinc
  integer :: oyr, omn, ody, otm
  integer :: ib1,ib2
  character(len=40) :: dstring

  !   print*,iyr,imn,idy,itm,tinc
  if(tinc == 0.) then
     oyr=iyr ; omn=imn ; ody=idy ; otm=itm
  else
     call date_add_to(iyr,imn,idy,itm,tinc,'s',oyr,omn,ody,otm)
     !   print*,oyr,omn,ody,otm
  endif

  write(dstring,100) '-',type,'-',oyr,'-',omn,'-',ody,'-',otm
100 format(3a1,i4.4,a1,i2.2,a1,i2.2,a1,i6.6)

  ib1=len_trim(prefix)
  fname=prefix(1:ib1)//dstring(1:20)
  if (post(1:1) /= '$') then
     ib1=len_trim(fname)
     ib2=len_trim(post)
     fname=fname(1:ib1)//'-'//post(1:ib2)
  endif
  ib1=len_trim(fname)
  fname=fname(1:ib1)//'.'//fmt(1:3)

  return
end subroutine makefnam

!***************************************************************************

subroutine parsefnam (fname,prefix,iyr,imn,idy,itm,type,post,fmt)

  ! breaks standard timestamped filename into component parts

  ! MJW - 5/4/00 have to be careful since prefix may include '-'
  !    So lets assume that the filename will always have the form
  !    prfx_incl_dashs-typ-yyyy-mm-dd-hhmmss[-*].fmt, & look backwards
  !    We might have at most 5 dashes within and following datestring
  !    if there is a 'post' character string

  implicit none
  integer :: iyr, imn, idy, itm
  character(len=*) :: fname,prefix
  character :: post*10,fmt*3,type*1

  integer, parameter :: ndash=5
  integer :: idash(ndash)
  character(len=40) :: dstring
  integer :: ib1,ib2,n,lch  !,ndash  !Declare two times

  ib1=index(fname,'.',.true.)
  fmt=fname(ib1+1:ib1+3)

  lch=len_trim(fname)
  do n=1,ndash
     idash(n)=index(fname(1:lch),'-',.true.)
     lch=idash(n)-1
  enddo

  ! Check to see if a post exists by checking the position of -'s.
  post=''
  if(idash(4)==idash(5)+5 .and. idash(3)==idash(4)+3 .and.  &
       idash(2)==idash(3)+3 .and. idash(1)==idash(2)+7 )  &
       post=fname(idash(1)+1:ib1-1)

  if(len_trim(post)>0)idash(1:4)=idash(2:5)

  prefix=fname(1:idash(4)-3)
  read(fname(idash(4)-1:idash(1)+6),100) type,iyr,imn,idy,itm
100 format(a1,1x,i4,1x,i2,1x,i2,1x,i6)

  return
end subroutine parsefnam

!***************************************************************************

subroutine rams_f_open(iunit, filenm, formt, stat, act, iclob)

  ! replaces old jclopen and jclget
  ! files are overwritten unless iclob (ICLOBBER) set to 1

  implicit none

  integer :: iunit, iclob
  character(len=*) :: filenm, formt, stat, act
  logical :: exans,opnd

  inquire(FILE=filenm,EXIST=exans)

  if(exans.and.iclob.eq.0.and.  &
       (act(1:4).eq.'WRIT'.or.act(1:4).eq.'writ')) then
     print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     print*,'!!!   trying to open file name :'
     print*,'!!!       ',filenm
     print*,'!!!   but it already exists. run is ended.'
     print*,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
     stop 'rams_f_open - exists'
  endif

  open(iunit,STATUS=stat,FILE=filenm(1:len_trim(filenm)),FORM=formt)
!!$  print*,'F_open - ',filenm(1:len_trim(filenm))

  return
end subroutine rams_f_open

!***************************************************************************

real function RAMRAN(idum)
  implicit none

  ! random number generator with [0,1] uniform distribution 
  ! by Knuth subtractive method

  integer idum
  integer MBIG,MSEED,MZ
  !REAL MBIG,MSEED,MZ
  real ran3,FAC
  parameter (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG)
  !PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG)
  integer i,iff,ii,inext,inextp,k
  integer mj,mk,ma(55)
  !REAL mj,mk,ma(55)
  save iff,inext,inextp,ma
  data iff /0/
  if(idum.lt.0.or.iff.eq.0)then
     iff=1
     mj=MSEED-iabs(idum)
     mj=mod(mj,MBIG)
     ma(55)=mj
     mk=1
     do i=1,54 !11 i=1,54
        ii=mod(21*i,55)
        ma(ii)=mk
        mk=mj-mk
        if(mk.lt.MZ)mk=mk+MBIG
        mj=ma(ii)
!11   CONTINUE
     enddo
     do k=1,4 !13 k=1,4
        do i=1,55 !12 i=1,55
           ma(i)=ma(i)-ma(1+mod(i+30,55))
           if (ma(i).lt.MZ) ma(i)=ma(i)+MBIG
!12         CONTINUE
        enddo
!13         CONTINUE
     enddo
     inext=0
     inextp=31
     idum=1
  endif
  inext=inext+1
  if (inext.eq.56) inext=1
  inextp=inextp+1
  if (inextp.eq.56) inextp=1
  mj=ma(inext)-ma(inextp)
  if (mj.lt.MZ) mj=mj+MBIG
  ma(inext)=mj
  ramran=mj*FAC

  return
end function RAMRAN








