! { dg-do run }
! PR 20661: Handle non-advancing I/O with iostat
! Test case by Walt Brainerd, The Fortran Company

program fc002
   character(len=1) :: c
   integer :: k,k2
   character(len=*), parameter :: f="(a)"
   open(11,status="scratch", iostat=k)
   if (k /= 0) STOP 1
   write(11,f) "x"
   rewind (11)
   read(11, f, advance="no", iostat=k) c
   if (k /= 0) STOP 2
   read(11, f, advance="no", iostat=k) c
   if (k >= 0) STOP 3
   read(11, f, advance="no", iostat=k2) c
   if (k2 >= 0 .or. k == k2) STOP 4
end program fc002


text:
Im not a member of the KKK. I just didnt want to put up my entire name and the stupid thing was getting pissy at me and I just started pushing buttons and finally it let me slip by with THAT. Maybe someday Ill fix it. :)

20060508 22:11:27 nbsp Welcome, Faryn! Hope you have fun here... I find it to be a productive way to waste time. ;) Users/CindySperry

20060508 22:54:35 nbsp Hi Faryn, welcome to the wiki. Usernames have to be formated LikeThis. If you plan on sticking around, I would suggest using your importance of using your RealName RealName. To change your username, click the settings button (upper right) and select Disable this account forever then make yourself a new account. Faryn isnt a very common name, and it would be easy for someone to find out who you are if they were so inclined, so you might as well use your RealName, or use a PseudoNym Users/ArlenAbraham

20060509 14:20:44 nbsp Faryn is a pseudonym. her real identity is cat woman. haha. get it? like the crazy cat lady... Users/JillBenciWoodward

20060509 18:25:01 nbsp MWAHAHAHA... Jill wins. Then again, Faryn gets the cats... Users/CindySperry

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!!
!! Simple program to read fifi and return the array to hw1
!!
!!
MODULE io    ! Every Fortran program starts with a program statement

  use precise, only : defaultp
  ! all variable declarations come here (before CONTAINS)
  ! Except subroutines
  IMPLICIT NONE
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

CONTAINS

!! Subroutine to read the input file-----------------------------------
!! Subroutint to read the input file-----------------------------------
  SUBROUTINE input( inputfile, outputfile, title, &
                         npanels, nfspanels, ntransompanels, npoints, &
                         panels, points,i,j,deltax, nfsl, nfst, ldx, &
                         ntransoml, ntransomt,nhpl )

!     INTEGER :: narg      ! Integer variables
     INTEGER :: i, j, n
     INTEGER :: npoints, npanels, nfspanels, nfsl, nfst
     INTEGER :: ntransompanels, ntransoml, ntransomt
     INTEGER :: nhpl

     INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels

     CHARACTER(len=*) :: inputfile   ! file name
     CHARACTER(len=*) :: outputfile  ! file name
     CHARACTER(len=*) :: title

     LOGICAL :: flexists  ! a logical variable. I .true. or .false.

     REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: points
     real(wp), allocatable, dimension(:)   :: ldx
     real(wp) :: deltax

     ! Variable declarations go before any executable statement

     OPEN(10,file=inputfile) ! open the file

     ! Read the data-------------------------------------------------
     read(10,'(AAAAA)') title
     read(10,*) i,j
     read(10,*) npanels, nfspanels, ntransompanels, npoints
     read(10,*) deltax !! shift the collocation (field) points deltax - see Raven 1996/1998
     read(10,*) nfsl !
     read(10,*) nfst !number of free surface transom panels
     read(10,*) ntransoml !number of transom  panels in a longitudinal row
     read(10,*) ntransomt ! number transom panels in a transverse row
     read(10,*) nhpl
     ALLOCATE( ldx(nfsl) )
     ALLOCATE( panels(4,npanels+nfspanels+ntransompanels) )
     ALLOCATE( points(3,npoints) )
     read(10,*) panels
     read(10,*) points
     read(10,*) ldx
     close(10)
     ! Finished Reading the data-------------------------------------

     ! Write the fifi data (just because I want to)------------------
     OPEN(20,file=outputfile)
     Write(20,*) ' Luke McCulloch, NAME 6160 Project, Outputfile '
     write(20,*)
     write(20,*) '(1.) Read the fifi data file and copy to "out.dat" '
     write(20,*) ' using the subroutine "input" via module "io"'
     write(20,*) '---------------------------------------------------------'
     write(20,*) title
     WRITE(20, FMT='(AI3A)') ' we have ', npanels+nfspanels+ntransompanels, ' panels '
     WRITE(20, FMT='(AI3A)') ' we have ', npoints, ' points '
     write(20,'(4I4)') panels
     write(20,'(3D16.8)') points  ! Use Implicit do loop array formating
     write(20,*) '--------------------------------------------------------'

     close(20)

     write(*,*)  ! Blank space
     !  IF (ALLOCATED(points)) DEALLOCATE(points)
     !  IF (ALLOCATED(panels)) DEALLOCATE(panels)
     !  IF (ALLOCATED(panels)) DEALLOCATE(op)

  END SUBROUTINE input
!! End of Subroutine to read the data ----------------------------------
!! End of Subroutine to read the data ----------------------------------

!! Subroutine writes to file the data manipulated by the main program---
!! Subroutine writes to file the data manipulated by the main program---

  SUBROUTINE output( outputfile, iter, sourcesink, cw, profilewave )

     CHARACTER(len=*) :: outputfile
     !real(wp), allocatable, dimension(:,:) :: op
     real(wp) :: sourcesink, cw
     integer :: iter
     real(wp), allocatable, dimension(:,:) :: profilewave

     Open(20,file= outputfile, Access= 'append', status='old')
     write(20,*)
     Write(20,*) ' Results From the Wigley Hull Linear Free Surface Panel Code '
     write(20,*) '---------------------------------------------------------------'
     write(20,*) ' (2.) Output data using the subroutine "output" in module "io" '
     write(20,*)
     write(20,*) 'source sink summation over all panels'
     write(20,'(3D16.8)') sourcesink
     write(20,*)
     write(20,*) 'Wave Resistance'
     write(20,'(3D16.8)') cw
     write(20,*)
     write(20,*) 'iter count from simquit'
     write(20,'(I4)') iter
     write(20,*)
     write(20,*)
     write(20,*) 'now output the wave profile on the centerline + ship hull'
     write(20,'(2f16.8)') profilewave
     write(20,*) '----------------------------------------------------------------'
     close(20)

  END SUBROUTINE output

!! End of Subroutine to write the data ---------------------------------
!! End of Subroutine to write the data ---------------------------------

END MODULE io


text:
        SUBROUTINE  LS_GRPT( lenb, bulltn, jpos, lszrpt, lsfrpt, iret )
C************************************************************************
C* LS_GRPT							        *
C*								        *
C* This subroutine gets the next report in bulletin.  The length of the *
C* report must be within the range limits; otherwise, the report is     *
C* rejected.  When there are no more reports in the bulletin, IRET will *
C* be set to 2.                                                         *
C*								        *
C* LS_GRPT  ( LENB, BULLTN, JPOS, LSZRPT, LSFRPT, IRET )                *
C*								        *
C* Input parameters:						        *
C*	LENB            INTEGER         Bulletin length                 *
C*      BULLTN          CHAR*           Bulletin to decode              *
C*								        *
C* Input and Output parameters:                                         *
C*      JPOS            INTEGER         Pointer to start of report      *
C*								        *
C* Output parameters:						        *
C*      LSZRPT          INTEGER         Report length                   *
C*      LSFRPT          CHAR*           Raw report                      *
C*	IRET		INTEGER		Return code		        *
C*				   	 0 = normal return 	        *
C*                                       1 = report rejected            *
C*                                       2 = no more reports in bulletin*
C*                                       3 = found another AAXX group   *
C*								        *
C**								        *
C* Log:								        *
C* R. Hollern/NCEP       4/96                                           *
C* R. Hollern/NCEP      10/96  Added logic to reject NIL reports        *
C* R. Hollern/NCEP       1/98  Cleaned up and improved logging          *
C* A. Hardy/GSC	         1/98  Added GEMINC                             *
C* R. Hollern/NCEP       2/98  Redefined jsize                          *
C* D. Kidwell/NCEP	 7/02  Added check for AAXX and return code 3   *
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
        INCLUDE 	'lscmn.cmn'
C*
        CHARACTER*(*)   bulltn, lsfrpt
C*
        LOGICAL  more
C------------------------------------------------------------------------
        iret = 0
        more = .true.
        lsfrpt = ' '
C
        DO WHILE ( more )
C
C*          Remove any spaces before start of report.
C*          Set pointer to start of report.
C
            IF ( bulltn ( jpos:jpos ) .eq. ' ' ) THEN
                jpos = jpos + 1
              ELSE
                more = .false.
            END IF
C
C*          Check for end of bulletin.
C
            jsize = lenb - jpos + 1
C
            IF ( jsize .lt. 18 ) THEN
                iret = 2
                RETURN
            END IF
        END DO
C
C*	Check for another AAXX group.
C
	IF ( bulltn ( jpos:jpos + 3 ) .eq. 'AAXX' ) THEN
	    jpos = jpos + 10
	    iret = 3
	    RETURN
	END IF
C
        lszrpt = 0
        kst = jpos
        more = .true.
C
        DO WHILE ( more )
C
C*          A report ends with the character '='.
C
            IF ( bulltn ( jpos:jpos ) .eq. '=' ) THEN
                jpos = jpos + 1
                more = .false.
              ELSE IF ( jpos .ge. lenb ) THEN
C
C*              End of bulletin reached.
C
                iret = 2
                RETURN
              ELSE
                jpos = jpos + 1
                lszrpt = lszrpt + 1
            END IF
        END DO
C
C*      Check for and reject NIL report.
C
        iipos = INDEX( bulltn ( kst:kst+10 ), 'NIL' )
        IF ( iipos .gt. 0 ) THEN
            iret = 1
            RETURN
        END IF
C
C*      Check that the length of the report is not too long.
C
        IF (  lszrpt .gt. 400 ) THEN
            loglvl = 4
            CALL DC_WLOG ( loglvl, 'LS', -1, bulltn(kst:kst+20), ierwl )
            iret = 1
            RETURN
        END IF
C
C*      Store report in lsfrpt.
C
        lsfrpt ( 1:lszrpt ) = bulltn ( kst:jpos )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      REAL FUNCTION NICKC (ANGLE, LXN)
C***********************************************************************

C  FUNCTION NICKC = RETURNS THE PENALTY FOR A BAD ANGLE AND A BAD
C                   CONNECTIVITY ON A CORNER

C***********************************************************************

      DIMENSION LXN(4)

      PID2 = 0.5 * ATAN2(0.0, -1.0)
      ADIFF = MAX (0., (ANGLE - PID2) )

C  IF THE ANGLE HAS 4 LINES ATTACHED
C  A REGULAR NODE WOULD BE FORMED - PENALIZE IT LIGHTLY
C  USE THIS SAME PENALTY FOR BOUNDARY NODES

      IF ( (LXN (4) .GT. 0) .OR. (LXN (2) .LT. 0) ) THEN
         NICKC = ADIFF

C  IF THE ANGLE HAS 3 LINES ATTACHED
C  THEN A THREE DEGREE IRREGULAR NODE WOULD BE FORMED
C  PENALIZE IT MORE STRINGENTLY

      ELSEIF ( (LXN (3) .GT. 0) .AND. (LXN (4) .EQ. 0) ) THEN
         NICKC = ADIFF * 1.3

C  IF THE ANGLE HAS MORE THAN 4 LINES ATTACHED
C  THEN A FIVE+ DEGREE IRREGULAR NODE WOULD BE FORMED
C  PENALIZE IT LESS STRINGENTLY

      ELSEIF (LXN (4) .GT. 0) THEN
         NICKC = ADIFF * 1.15

C  IF THE ANGLE HAS 2 LINES ATTACHED
C  THEN A TWO DEGREE IRREGULAR NODE WOULD BE FORMED (HIGHLY UNLIKELY)
C  PENALIZE IT SEVERELY

      ELSEIF (LXN (3) .EQ. 0) THEN
         NICKC = ADIFF * 1.6
      else
c         write (*,*) 'Undefined Option in nickc',
c     $        lxn(1), lxn(2), lxn(3), lxn(4)
         nickc = adiff * 2.0
      ENDIF

      RETURN

      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


!##############################################################################
! MODULE GLOBALS
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: Kbar = 10d0
    real*8, parameter :: Tbar = 30d0
    real*8, parameter :: alpha(2) = (/0.3d0, 0.4d0/)
    real*8, parameter :: beta(2) = (/ 0.3d0, 0.6d0/)
    real*8, parameter :: a0(2) = (/0.2d0, 0.2d0/)
    real*8, parameter :: a(2, 2) = reshape((/ 0d0, 0.3d0, 0.2d0, 0d0 /),(/2,2/))
    real*8, parameter :: ID(2, 2) = reshape((/ 1d0, 0d0, 0d0, 1d0 /),(/2,2/))
    real*8, parameter :: G = 3d0
    real*8            :: tauw = 0d0
    real*8            :: taur = 0d0
    real*8            :: tauc(2) = 0d0
    real*8            :: Ybarn, q(2), p(2), w, wn, r, rn
    real*8            :: Xd(2), Y(2), ky(2), ly(2), K(2), L(2), ell

contains

    ! function to determine market equilibrium
    function markets(x)

        use toolbox

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: markets(size(x, 1))

        ! copy producer prices and taxes
        w       = 1d0
        r       = x(1)
        tauc(1) = x(2)
        tauc(2) = tauc(1)

        ! 1. calkulate K/Y and L/Y
        ky = a0*((1d0-beta)/beta*w/r)**beta
        ly = a0*(beta/(1d0-beta)*r/w)**(1d0-beta)

        ! 2. determine producer prices
        q = w*ly+r*ky
        call lu_solve(ID-transpose(a), q)

        ! 3. consumer prices and demands
        p  = q*(1d0+tauc)
        wn = w*(1d0-tauw)
        rn = r*(1d0-taur)
        Ybarn = wn*Tbar+rn*Kbar
        Xd = alpha/p*Ybarn
        ell  = (1d0-alpha(1)-alpha(2))/wn*Ybarn

        ! 4. determine output levels
        Y(1) = Xd(1)+G
        Y(2) = Xd(2)
        call lu_solve(ID-a, Y)

        ! 5. compute K and L
        K = ky*Y
        L = ly*Y

        ! 6. check markets and budget
        markets(1) = K(1)+K(2)-Kbar
        markets(2) = q(1)*G-sum(tauc*q*Xd)-tauw*w*(Tbar-ell)-taur*r*Kbar

    end function

end module


text:
 Comedy Clubs

 Davis
  The Comedy Space / Luigis Davis
  New Weekly comedy night hosted and produced by Australian comedian Tim Logan and Bay area comedy legend Ray Molina.  Every Monday night from May 7th.
8pm Monday nights
$7 students $10 Full
crazy brilliant comedy

  Not exactly a club, but a new comedy crew Birdstrike Theater is forming.
 I often see flyers for some comedian nights at Cafe Roma, if someone could provide more info that would be cool.

 Sacramento
  wiki:sacramento:Laughs Unlimited
             1207 Front Street, Old Sacramento
             Although they usually do not have big headliners, this is a good place to see up and coming stars.
             They usually have open mics on Wednesdays, although you should always call to be sure. It is a great place to try standup, as the crowd will differ from week to week. To sign up just get there early, and get your name on the list. They usually take about 15 people. If you cant get on one week come back the next, as they give preference to people who could not get on the previous week.

  http://www.saccomedyspot.com/calendar.html The Sacramento Comedy Spot on the Road
             The Clarion Hotel, 2600 Auburn Blvd., Sacramento
             Performs every other Saturday night
             8:00 Deep Fried Comedy on a Stick sketch comedy, $7
             9:30 Free Hooch Comedy Troupe improv, $7
             Both shows, $12
             Two drink minimum

  http://sac.punchlinecomedyclub.com/main.html Punchline
             2100 Arden Way, Suite 225, in the Howe bout Arden Shopping Center
             Great place to catch established comedians.
             They also have open mic nights on Tuesday, they call it a Showcase. This open mic is a little more difficult to get in. You need to know people and have established your self as an amatuer, as opposed to a first nighter. Hang out at showcase nights, meet the other comedians, meet the staff, and you should be able to get on after about 6 months of greening it at Laughs Unlimited.

Davis could really benefit from a a regular openmic venue. Just look at how well RobotMedia has done. Id start it myself, but I have two jobs. I wouldnt mind be a part of its creation and would definetly perform. Users/MichaelGiardina


text:
program lfmpost

use lfmgrid
use grib
use mem_namelist, only : model_fcst_intvl

implicit none

!GFORTRAN integer, external :: iargc
integer :: iargc
integer :: narg,chr,nc,i,j,k
integer :: istatus
integer :: len_str

real :: xcen,ycen,latcen,loncen

character(len=256) :: laps_data_root,lfmprd_dir
character(len=24) :: a24time
character(len=16) :: atime,afcst
character(len=16) :: c_adv_cld,c_adv_pcp
character(len=9) :: a9time
character(len=4) :: fcst_hhmm
character(len=2) :: adomnum,domnum_str

!beka
integer ISTAT, I4_elapsed, ishow_timer, init_timer

logical :: back

! istatus: 1=good return, 0=ERROR/bad return
istatus = 1  ! assume good return

! Read command line arguments.

!beka

	ISTAT = INIT_TIMER()

narg=iargc()
write(6,*)' narg = ',narg

!call ugetarg(1,mtype)
!call ugetarg(2,filename)
!call ugetarg(3,adomnum)
!call ugetarg(4,atime)
!call ugetarg(5,afcst)
!call ugetarg(6,laps_data_root)
call getarg(1,mtype)
call getarg(2,filename)
call getarg(3,adomnum)
call getarg(4,atime)
call getarg(5,afcst)
if(narg .eq. 6)then
    call getarg(6,laps_data_root)
elseif(narg .eq. 8)then ! advection options are supplied
    call getarg(6,c_adv_cld)
    write(6,*)' c_adv_cld = ',c_adv_cld
    call getarg(7,c_adv_pcp)
    write(6,*)' c_adv_pcp = ',c_adv_pcp
    call getarg(8,laps_data_root)

    call s_len(c_adv_cld,len_str)
    if(len_str .gt. 0)then
!GFORTRAN        read(c_adv_cld,'(i)',err=900) i4_adv_cld
!GFORTRAN modifications begin
            read(c_adv_cld,*,err=900) i4_adv_cld
!GFORTRAN modifications end
    endif

    call s_len(c_adv_pcp,len_str)
    if(len_str .gt. 0)then
!GFORTRAN        read(c_adv_pcp,'(i)',err=900) i4_adv_pcp
!GFORTRAN modifications begin
        read(c_adv_pcp,*,err=900) i4_adv_pcp
!GFORTRAN modifications end
    endif
else
    call usage
endif

call right_justify(adomnum)
call right_justify(atime)
call right_justify(afcst)
read(adomnum,'(i2)',err=900) domnum
read(atime,'(i16)',err=900) laps_reftime
read(afcst,'(i16)',err=900) laps_valtime
fcsttime=laps_valtime
laps_valtime=laps_reftime+laps_valtime
write(domnum_fstr,'("d",i2.2)') domnum

write(6,*)' i4_adv_cld = ',i4_adv_cld
write(6,*)' i4_adv_pcp = ',i4_adv_pcp

! Convert mtype to lower case and check for valid model type.

do i=1,len_trim(mtype)
   chr=ichar(mtype(i:i))
   if (chr > 64 .and. chr < 91) mtype(i:i)=char(chr+32)
enddo

if (trim(mtype) /= 'mm5' .and. trim(mtype) /= 'wrf' .and.  &
    trim(mtype) /= 'nmm' .and. trim(mtype) /= 'st4') then
   print *, 'Unrecognized model type provided as first arg: ',trim(mtype)
   print *, '   mm5, wrf, nmm, and st4 are supported.'
   stop
endif

print*,' '
print*,'LAPS forecast model postprocessing for ',trim(mtype),' file:'
print*,'   '//trim(filename)
print*,'nest = ',domnum_fstr

! Read namelist.

back=.true.
nc=index(filename,'/',back)
if (nc > 1) then
   lfmprd_dir=filename(1:nc-1)
else
   lfmprd_dir="."
endif

call lfm_namelist(lfmprd_dir)

if (fcsttime .eq. 0 .and. c_m2z .eq. 'wrf') then
   write(6,*)' Set c_m2z to rams for initial time'
   c_m2z = 'rams'
endif

call get_laps_config('nest7grid',istatus)
if (istatus .ne. 1) then
   print *, 'ERROR: get_laps_config status = ',istatus
elseif(model_fcst_intvl .gt. 0)then
   print *, 'Setting precip_dt to nest7grid.parms parameter model_fcst_intvl = ',model_fcst_intvl
   precip_dt = model_fcst_intvl
else
   print *, 'WARNING: model_fcst_intvl unavailable, keeping precip_dt from lfmpost.nl = ',precip_dt
endif

! Obtain native model grid dimensions.

call get_native_dims(mtype,filename,nx,ny,nz,istatus)
if (istatus .ne. 1) then
  print *, 'ERROR getting dimensions or no records in file: ', trim(filename)
  print *, 'ERROR: Cannot process file...ABORTING!'
  stop
endif

! Obtain output laps isobaric grid dimensions, pressure levels, and lat/lons.

call get_laps_static(laps_data_root)

! Allocate and fill input native model data.

call alloc_native_grid
call fill_native_grid
if (verbose) then
   print*,' '
   print*,'Native map projection parameters          Output map projection parameters'
   print*,'--------------------------------          --------------------------------'
   print'(a,3i5,11x,a,3i5)',' grid dimensions:',nx,ny,nz,'grid dimensions:',lx,ly,lz
   print'(a,f10.1,16x,a,f10.1)',' grid spacing   :',ngrid_spacingx,'grid spacing   :',grid_spacing
   print'(1x,2(''proj: '',a32,4x))',nprojection,projection
   print'(a,f10.3,16x,a,f10.3)',' true latitude 1:',ntruelat1,'true latitude 1:',truelat1
   print'(a,f10.3,16x,a,f10.3)',' true latitude 2:',ntruelat2,'true latitude 2:',truelat2
   print'(a,f10.3,16x,a,f10.3)',' std longitude  :',nstdlon,'std longitude  :',stdlon
   print*,' '
   if (trim(mtype) /= 'st4') then
     print'(a,2f10.2)', ' Min/Max value of native terrain: ',minval(nzsfc),maxval(nzsfc)
   endif
   print*,' '
   print*,'Corner points from native grid:'
   print*,'==============================='
   print*,' '
   print'(f8.3,1x,f8.3,10x,f8.3,1x,f8.3)'  &
        ,nlat(1,ny),nlon(1,ny),nlat(nx,ny),nlon(nx,ny)
   print*,'      (NW)----------------------(NE)'
   print*,'        |                        |'
   print*,'        |                        |'
   print*,'      (SW)----------------------(SE)'
   print'(f8.3,1x,f8.3,10x,f8.3,1x,f8.3)'  &
        ,nlat(1,1),nlon(1,1),nlat(nx,1),nlon(nx,1)
   print*, ' '
   if (trim(mtype) /= 'st4') then
     xcen = 1. + (float(nx-1) / 2.)
     ycen = 1. + (float(ny-1) / 2.)
     print*,'Diagnostics from native domain center: ',xcen,ycen

     print'(a,f7.0)',' Terrain height at center = ',nzsfc(nx/2,ny/2)
     call bilinear_laps(xcen,ycen,nx,ny,nlat,latcen)
     call bilinear_laps(xcen,ycen,nx,ny,nlon,loncen)
     print'(a,f10.5)',' Approx Latitude at center = ',latcen
     print'(a,f10.5)',' Approx Longitude at center = ',loncen

     print*,'------------------------------------------------------------'
     print*,'LEVEL     PRES(Pa)  HEIGHT     T      QV         U       V'
     print*,'------------------------------------------------------------'
!HJ in the following several print lines, format changed from f8.6 to f9.6.
     do k=1,nz
       if(.not. large_ngrid)then
         print '(i5,2x,f12.1,2x,f6.0,2x,f6.2,2x,f9.6,2f8.2)'   &
             ,k,npsig(nx/2,ny/2,k),nzsig(nx/2,ny/2,k)  &
             ,ntsig(nx/2,ny/2,k),nmrsig(nx/2,ny/2,k)   &
             ,nusig(nx/2,ny/2,k),nvsig(nx/2,ny/2,k)
       elseif(.not. large_pgrid)then
         print '(i5,2x,f12.1,2x,6x,2x,f6.2,2x,f9.6,2f8.2)'   &
             ,k,npsig(nx/2,ny/2,k)                        &
             ,ntsig(nx/2,ny/2,k),nmrsig(nx/2,ny/2,k)   &
             ,nusig(nx/2,ny/2,k),nvsig(nx/2,ny/2,k)
       else ! both grids are large
         print '(i5,2x,f12.1,2x,6x,2x,f6.2,2x,f9.6,2f8.2)'   &
             ,k,npsig(nx/2,ny/2,k)                        &
             ,ntsig(nx/2,ny/2,k),nmrsig(nx/2,ny/2,k)
       endif
       call check_nan(npsig(nx/2,ny/2,k),istatus)
       if(istatus .ne. 1)then
         write(6,*)' ERROR: Nan detected in npsig via check_nan...'
         stop
       endif
!      if(npsig(nx/2,ny/2,k) / npsig(nx/2,ny/2,k) .ne. 1.0)then
!        write(6,*)' ERROR: Nan detected in npsig by division test and missed by check_nan...'
!        stop
!      endif
    enddo
  endif
endif

! Allocate and horizontally interpolate data.

call alloc_surface_grid
if (trim(mtype) /= 'st4') call alloc_hinterp_grid
call lfm_hinterp

call dealloc_grid('native')

!cj Added 6/21/2007
!cj Convert mixing ratio to specific humidity
hmrsig = hmrsig/(1.+hmrsig)

if (verbose) then
   print*,' '
   print'(a,2f10.2)', ' Min/Max value of hinterp terrain: ', minval(zsfc),maxval(zsfc)
   print*,' '
   print*,'Corner points from hinterp grid:'
   print*,'==============================='
   print*,' '
   print'(f8.3,1x,f8.3,10x,f8.3,1x,f8.3)'  &
        ,llat(1,ly),llon(1,ly),llat(lx,ly),llon(lx,ly)
   print*,'      (NW)----------------------(NE)'
   print*,'        |                        |'
   print*,'        |                        |'
   print*,'      (SW)----------------------(SE)'
   print'(f8.3,1x,f8.3,10x,f8.3,1x,f8.3)'  &
        ,llat(1,1),llon(1,1),llat(lx,1),llon(lx,1)
   if (trim(mtype) /= 'st4') then
     print*, ' '
     print*,'Diagnostics from hinterp domain center: ',lx/2,ly/2
     print'(a,f7.0)',' Terrain height at center = ',zsfc(lx/2,ly/2)
     print*,'------------------------------------------------------------'
     print*,'LEVEL     PRES(Pa)  HEIGHT     T      QV         U       V'
     print*,'------------------------------------------------------------'
!HJ in the following several print lines, format changed from f8.6 to f9.6.
     do k=1,nz
      if(.not. large_ngrid)then
        print '(i5,2x,f12.1,2x,f6.0,2x,f6.2,2x,f9.6,2f8.2)'   &
              ,k,hpsig(lx/2,ly/2,k),hzsig(lx/2,ly/2,k)  &
              ,htsig(lx/2,ly/2,k),hmrsig(lx/2,ly/2,k)   &
              ,husig(lx/2,ly/2,k),hvsig(lx/2,ly/2,k)
      elseif(.not. large_pgrid)then
        print '(i5,2x,f12.1,2x,6x,2x,f6.2,2x,f9.6,2f8.2)'   &
              ,k,hpsig(lx/2,ly/2,k)                        &
              ,htsig(lx/2,ly/2,k),hmrsig(lx/2,ly/2,k)   &
              ,husig(lx/2,ly/2,k),hvsig(lx/2,ly/2,k)
       else ! both grids are large
        print '(i5,2x,f12.1,2x,6x,2x,f6.2,2x,f9.6,2f8.2)'   &
              ,k,hpsig(lx/2,ly/2,k)                        &
              ,htsig(lx/2,ly/2,k),hmrsig(lx/2,ly/2,k)
      endif
     enddo
   endif
endif

! Set to zero any missing microphysics fields.

!if (make_micro) then
!   if (minval(hcldliqmr_sig)  == rmsg) hcldliqmr_sig=0.
!   if (minval(hcldicemr_sig)  == rmsg) hcldicemr_sig=0.
!   if (minval(hrainmr_sig)    == rmsg) hrainmr_sig=0.
!   if (minval(hsnowmr_sig)    == rmsg) hsnowmr_sig=0.
!   if (minval(hgraupelmr_sig) == rmsg) hgraupelmr_sig=0.
!endif

! Allocate and vertically interpolate data to isobaric grid.

if (trim(mtype) /= 'st4') then
 write(6,*)' call alloc_isobaric_grid'
 call alloc_isobaric_grid

!beka
 I4_elapsed = ishow_timer()

 write(6,*)' call lfm_vinterp'
 call lfm_vinterp(1)

!beka
 I4_elapsed = ishow_timer()

 if (verbose .and. .not. large_pgrid) then
    print*,' '
    print*,'Diagnostics from isobaric domain center:'
    print*,'------------------------------------------------------------------------------'
    print*,'LEVEL     PRES(Pa)  HEIGHT     T       QV        QL        QI       U        V'
    print*,'------------------------------------------------------------------------------'
    do k=1,lz
       print '(i5,2x,f12.1,2x,f6.0,2x,f6.2,3(2x,f9.6),2f8.2)'   &
             ,k,lprs(k)*100.,zprs(lx/2,ly/2,k)  &
             ,tprs(lx/2,ly/2,k),shprs(lx/2,ly/2,k) &
             ,cldliqmr_prs(lx/2,ly/2,k) &
             ,cldicemr_prs(lx/2,ly/2,k) &
             ,uprs(lx/2,ly/2,k),vprs(lx/2,ly/2,k)
    enddo

    print*,' '
    print*,'Diagnostics from isobaric domain level maxvals:'
    print*,'------------------------------------------------------------------------------'
    print*,'LEVEL     PRES(Pa)  HEIGHT     T       QV        QL        QI       U        V'
    print*,'------------------------------------------------------------------------------'
    do k=1,lz
       print '(i5,2x,f12.1,2x,f6.0,2x,f6.2,3(2x,f9.6),2f8.2)'   &
             ,k,lprs(k)*100.,maxval(zprs(:,:,k))  &
             ,maxval(tprs(:,:,k)),maxval(shprs(:,:,k)) &
             ,maxval(cldliqmr_prs(:,:,k)) &
             ,maxval(cldicemr_prs(:,:,k)) &
             ,maxval(uprs(:,:,k)),maxval(vprs(:,:,k))
    enddo
 endif

! Fill any missing surface fields and generate derived fields.

 write(6,*)' call lfm_derived'
 call lfm_derived
 I4_elapsed = ishow_timer()

 write(6,*)' call lfm_vinterp (2nd time)'
 call lfm_vinterp(2)
 I4_elapsed = ishow_timer()

 if (verbose) then
    print*,' '
    print*,'lfm_reflectivity pressure max/min: ',maxval(refl_prs),minval(refl_prs)
    print*,'lfm_reflectivity hsig max/min: ',maxval(hrefl_sig),minval(hrefl_sig)
    print*,'lfm_reflectivity pressure max/min: ',maxval(zdr_prs),minval(zdr_prs)
    print*,'lfm_reflectivity hsig max/min: ',maxval(hzdr_sig),minval(hzdr_sig)
    print*,'lfm_reflectivity pressure max/min: ',maxval(ldr_prs),minval(ldr_prs)
    print*,'lfm_reflectivity hsig max/min: ',maxval(hldr_sig),minval(hldr_sig)
 endif

! Create point forecasts, if requested.

 call set_laps_projection
 if (make_points(domnum)) then
    call cv_i4tim_asc_lp(laps_valtime,a24time,istatus)
    call make_fnam_lp(laps_reftime,a9time,istatus)
    call lfm_initpts(lfmprd_dir,a24time,a9time)
 endif
endif

! Write data to desired output formats.

if (out_cdf) call output_laps(lfmprd_dir,laps_data_root,domnum,laps_reftime,laps_valtime)

if (out_grib) then
   write(domnum_str,'(i2.2)') domnum
   call make_igds(proj,igds)
   call make_fnam_lp(laps_reftime,a9time,istatus)
   call make_fcst_time(laps_valtime,laps_reftime,fcst_hhmm,istatus)
   if (fcst_hhmm(3:4) == "00") fcst_hhmm(3:4)="  "
   gribfile=trim(lfmprd_dir)//'/d'//domnum_str//'/grib/'//a9time//'00'//trim(fcst_hhmm)//'.grib'
   print*,' '
   print*,'Writing 2d fields to grib: ',trim(gribfile)
   call open_grib_c(gribfile,funit)
   if (verbose) print*,'Opened funit =',funit,' for ',trim(gribfile)
   startbyte=1
   nbytes=0
   call grib_sfc_vars(laps_reftime,laps_valtime)
   print*,' '
   print*,'Writing 3d fields to grib: ',trim(gribfile)
   call grib_ua_vars(laps_reftime,laps_valtime)
   call close_grib_c(funit)
   if (verbose) print*,'Number of bytes written in grib:',nbytes
endif

call dealloc_grid('horiz')
call dealloc_grid('surface')
call dealloc_grid('isobaric')

stop ' '
900 continue
call usage

end

!===============================================================================

subroutine usage

implicit none

!GFORTRAN print*,'Usage: lfmpost.exe ''model type'' ''filename'' ''grid no'' ''laps i4time'' ''fcst time (sec)'' ''laps_data_root'''
!GFORTRAN print*,'OR:    lfmpost.exe ''model type'' ''filename'' ''grid no'' ''laps i4time'' ''fcst time (sec)'' ''adv cloud (sec)'' ''adv pcp (sec)'' ''laps_data_root'''
!GFORTRAN modifications begin
print*,'Usage: lfmpost.exe ''model type'' ''filename'' ''grid no''',&
        ' ''laps i4time'' ''fcst time (sec)'' ''laps_data_root'''
print*,'OR:    lfmpost.exe ''model type'' ''filename'' ''grid no''',&
        ' ''laps i4time'' ''fcst time (sec)'' ''adv cloud (sec)''',&
!GFORTRAN modifications end
        ' ''adv pcp (sec)'' ''laps_data_root'''

stop

return
end

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


!
!  @GLOBAL.SOURCE@ - This file contains the global data and functions
!  for the COM Server
!
!  Generated by the Intel(R) Visual Fortran COM Server Wizard on
!  @GLOBAL.DATE@ at @GLOBAL.TIME@.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

!
!  M O D U L E S
!

!  Module containg DLL global data

module @GLOBAL.NAME@_Global
    use ifwinty
    use kernel32
    use IClassFactory_Types

    integer(HANDLE) ghinst
@#IFTRUE EXESERVER
@#ELSE
    integer         gCntLock
@#ENDIF
    type (T_RTL_CRITICAL_SECTION) gGlobalCriticalSection
    !  Per Class
   	@#PER CLASS
    integer(int_ptr_kind()) g@CLASS.NAME@IClassFactory
    type (IClassFactory_Data), pointer :: gp@CLASS.NAME@CFData
    integer(int_ptr_kind()) g@CLASS.NAME@ITypeInfo
    @#ENDPER

    ! Type Library GUID
    type (guid), parameter :: GUID_TypeLib_@GLOBAL.NAME@ = &
        @(= TypeGUID(GLOBAL.TYPELIB_ID)@)

  contains

    integer function ServerLock ()
@#IFTRUE EXESERVER
        use ole32
@#ENDIF
        integer(LONG) r
@#IFTRUE EXESERVER
        r = CoAddRefServerProcess()
        ServerLock = r
@#ELSE
        r = InterlockedIncrement (loc(gCntLock))
        ServerLock = gCntLock
@#ENDIF
    end function

    integer function ServerUnlock ()
@#IFTRUE EXESERVER
        use ole32
        use user32
@#ENDIF
        integer(LONG) r
@#IFTRUE EXESERVER
        r = CoReleaseServerProcess()
        if (r == 0) then
            call PostQuitMessage(0)
        end if
        ServerUnlock = r
@#ELSE
        r = InterlockedDecrement (loc(gCntLock))
        ServerUnlock = gCntLock
@#ENDIF
    end function

end module @GLOBAL.NAME@_Global


program stdsleep
!! uses unistd.h for Fortran standard compliant sleep.
!! sleep() is a GNU extension, not standard Fortran.
use, intrinsic:: iso_c_binding, only: c_int
implicit none

!> use this interface in your module, that's all that's needed for sleep()
interface
subroutine usleep(us) bind (C)
  import c_int
  integer(c_int), value, intent(in) :: us
end subroutine usleep
end interface

integer(c_int), parameter :: us=500000

print *,'sleeping for ',us/1000,' milliseconds.'
call usleep(us)
print *,'what a nice nap. Goodbye.'

end program


text:
      subroutine ifill(n,val,a,ia)
C$Id$
      implicit none
      integer n, val, a(*), ia, i
c
c     initialise integer precision array to scalar value
c
      if (ia.eq.1) then
         do 10 i = 1, n
            a(i) = val
 10      continue
      else
         do 20 i = 1,(n-1)*ia+1,ia
            a(i) = val
 20      continue
      endif
c
      end
      subroutine ifill2(n,val,a,ia)
C$Id$
      implicit none
      integer n, val, ia, i
      integer*2 a(*)
c
c     initialise integer precision array to scalar value
c
      if (ia.eq.1) then
         do 10 i = 1, n
            a(i) = val
 10      continue
      else
         do 20 i = 1,(n-1)*ia+1,ia
            a(i) = val
 20      continue
      endif
c
      end
      subroutine lfill(n,val,a,ia)
C$Id$
      implicit none
      integer n, ia, i
      logical a(*),val
c
c     initialise logical array to false
c
      if (ia.eq.1) then
         do 10 i = 1, n
            a(i) = val
 10      continue
      else
         do 20 i = 1,(n-1)*ia+1,ia
            a(i) = val
 20      continue
      endif
c
      end

max_stars_repo_name: dinisAbranches/nwchem

max_issues_repo_name: dinisAbranches/nwchem

max_forks_repo_name: dinisAbranches/nwchem


text:
	SUBROUTINE GR_STAT  ( z, kx, ky, imin, jmin, imax, jmax,
     +			      rmin, rmax, ravg, rdev, iret )
C************************************************************************
C* GR_STAT								*
C*									*
C* This subroutine computes grid statistics.				*
C* 									*
C* GR_STAT  ( Z, KX, KY, IMIN, JMIN, IMAX, JMAX, RMIN, RMAX, 		*
C*            RAVG, RDEV, IRET )					*
C*									*
C* Input parameters:							*
C*	Z  (KX,KY)	REAL		Data array			*
C*	KX		INTEGER		Number of points in x dir	*
C*	KY		INTEGER		Number of points in y dir	*
C*	IMIN		INTEGER		Lower left corner of subgrid	*
C*	JMIN		INTEGER		Lower left corner of subgrid	*
C*	IMAX		INTEGER		Upper right corner of subgrid	*
C*	JMAX		INTEGER		Upper right corner of subgrid	*
C*									*
C* Output parameters:							*
C*	RMIN		REAL		Minimum data value		*
C*	RMAX		REAL		Maximum data value		*
C*	RAVG		REAL		Average data value		*
C*	RDEV		REAL		Standard deviation		*
C* 	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -8 = no data in range		*
C*					 -9 = invalid subset area	*
C**									*
C* Log:									*
C* G. Chatters/RDS	 6/82						*
C* M. Vilardo/RDS	11/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	12/84	Converted from GEMPLT for GEMPAK	*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* G. Huffman/USRA	 7/89	Use REAL*8 to avoid precision errors	*
C* K. Brill              5/90   Return distinct RMIN, RMAX for 0 < n < 4*
C* M. desJardins/GSFC	10/90	Return missing values for no data	*
C* S. Chiswell/Unidata	11/06	use double precision gpt		*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	REAL		z ( kx, ky )
C*
	DOUBLE PRECISION	sum, sumsq, var, gpt
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Check values given for imin, imax, jmin, jmax.
C
	IF  ( ( imin .lt. 1 ) .or. ( imax .gt. kx ) .or.
     +	      ( imin .gt. imax ) .or. ( jmin .lt. 1 ) .or.
     +	      ( jmax .gt. ky ) .or. ( jmin .gt. jmax ) )  THEN
	    iret = -9
	    RETURN
	END IF
C
C*	Initialize variables for computing average and standard
C*	deviation.
C
	sum    = 0.0
	sumsq  = 0.0
	nsum   = 0
	rmax   = RMISSD
	rmin   = RMISSD
C
C*	Read through all the data in the subgrid.
C
	DO  i = imin, imax
	    DO  j = jmin, jmax
		IF  ( .not. ERMISS ( z (i,j) ) )  THEN
		    gpt = z (i,j)
		    IF  ( nsum .eq. 0 )  THEN
			sum   = gpt
			sumsq = gpt * gpt
			nsum  = 1
			rmax  = z (i,j)
			rmin  = z (i,j)
		      ELSE
			sum   = sum + gpt
			sumsq = sumsq + gpt * gpt
			nsum  = nsum + 1
			IF  ( z (i,j) .gt. rmax )  rmax = z (i,j)
			IF  ( z (i,j) .lt. rmin )  rmin = z (i,j)
		    END IF
		END IF
	    END DO
	END DO
C
C*	Check for at least four points and that data has some range
C*      before computing standard deviation.
C
	IF  ( ( nsum .ge. 4 ) .and. ( rmin .lt. rmax ) )  THEN
	    ravg  = sum / nsum
	    var   = sumsq / nsum - ( sum / nsum ) ** 2
	    IF  ( var .lt. 0. )  THEN
		rdev = 0.0
		iret = -8
	      ELSE
		rdev  = SQRT ( var )
	    END IF
	  ELSE IF ( nsum .gt. 0 ) THEN
	    ravg  = 0.0
	    rdev  = 0.0
	  ELSE
	    iret = -8
	END IF
C*
	RETURN
	END


text:
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine zatom  --  adds a single atom to Z-matrix  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "zatom" adds an atom to the end of the current Z-matrix
c     and then increments the atom counter; atom type, defining
c     atoms and internal coordinates are passed as arguments
c
c
      subroutine zatom (bionum,bond,angle,dihed,iz1,iz2,iz3,iz4)
      implicit none
      include 'sizes.i'
      include 'angle.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bond.i'
      include 'fields.i'
      include 'iounit.i'
      include 'kangs.i'
      include 'katoms.i'
      include 'kbonds.i'
      include 'zclose.i'
      include 'zcoord.i'
      integer i,size
      integer bionum
      integer na,nb
      integer iz1,iz2
      integer iz3,iz4
      integer ita,itb
      integer itc,itd
      real*8 bond,angle
      real*8 dihed
      character*4 pa,pb,pc,pd
      character*8 blank8,ptb
      character*12 blank12,pta
c
c
c     fill various arrays with information for this atom
c
      if (bionum .gt. 0) then
         type(n) = biotyp(bionum)
         if (type(n) .gt. 0) then
            name(n) = symbol(type(n))
         else
            name(n) = 'XXX'
         end if
         zbond(n) = bond
         zang(n) = angle
         ztors(n) = dihed
         if (ztors(n) .lt. -180.0d0) then
            ztors(n) = ztors(n) + 360.0d0
         else if (ztors(n) .gt. 180.0d0) then
            ztors(n) = ztors(n) - 360.0d0
         end if
         iz(1,n) = iz1
         iz(2,n) = iz2
         iz(3,n) = iz3
         iz(4,n) = iz4
c
c     find ideal force field bond length and angle values
c
         ita = 0
         itb = 0
         itc = 0
         itd = 0
         if (n .ne. 0)  ita = atmcls(type(n))
         if (iz1 .ne. 0)  itb = atmcls(type(iz1))
         if (iz2 .ne. 0)  itc = atmcls(type(iz2))
         if (iz3 .ne. 0)  itd = atmcls(type(iz3))
         blank8 = '        '
         blank12 = '            '
         do i = maxnb, 1, -1
            if (kb(i) .eq. blank8)  nb = i - 1
         end do
         do i = maxna, 1, -1
            if (ka(i) .eq. blank12)  na = i - 1
         end do
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         if (ita .le. itb) then
            ptb = pa//pb
         else
            ptb = pb//pa
         end if
         do i = 1, nb
            if (kb(i) .eq. ptb) then
               if (blen(i) .ne. 0.0d0)  zbond(n) = blen(i)
               goto 10
            end if
         end do
   10    continue
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         if (ita .le. itc) then
            pta = pa//pb//pc
         else
            pta = pc//pb//pa
         end if
         do i = 1, na
            if (ka(i) .eq. pta) then
               if (ang(1,i) .ne. 0.0d0)  zang(n) = ang(1,i)
               goto 20
            end if
         end do
20       continue
         if (iz4 .ne. 0) then
            call numeral (ita,pa,size)
            call numeral (itb,pb,size)
            call numeral (itd,pd,size)
            if (ita .le. itd) then
               pta = pa//pb//pd
            else
               pta = pd//pb//pa
            end if
            do i = 1, na
               if (ka(i) .eq. pta) then
                  if (ang(1,i) .ne. 0.0d0)  ztors(n) = ang(1,i)
                  goto 30
               end if
            end do
   30       continue
         end if
c
c     increment atom counter and check for too many atoms
c
         n = n + 1
         if (n .gt. maxatm) then
            write (iout,40)  maxatm
   40       format (/,' ZATOM  --  The Maximum of',i8,' Atoms',
     &                 ' has been Exceeded')
            call fatal
         end if
c
c     add an extra bond to make a ring closure
c
      else if (bionum .eq. -1) then
         nadd = nadd + 1
         iadd(1,nadd) = iz1
         iadd(2,nadd) = iz2
c
c     delete an extra bond to make separate molecules
c
      else if (bionum .eq. -2) then
         ndel = ndel + 1
         idel(1,ndel) = iz1
         idel(2,ndel) = iz2
      end if
      return
      end

max_stars_repo_name: htna/HCsbLib

max_issues_repo_name: htna/HCsbLib

max_forks_repo_name: htna/HCsbLib


text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief Module provides the ability to import and interact with
!> Functional Mock Up Units (FMU).
!>
!> Currently supported FMU versions:
!>  - 2.0
!>
!> The FMU is a zip file contaning an XML file and a *.so library.
!> The file layout of an unzipped FMU is as follows:
!>
!>  FMU_unzipDirectory
!>   |-> binaries
!>   |   |-> linux64
!>   |       |-> modelIdentifier.so
!>   |-> modelDescription.xml
!>
!> Where modelIdentifier and unzipDirectory are specified in the input pList
!>
!> See: https://fmi-standard.org for additional info.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE FMU_Wrapper
#include "Futility_DBC.h"
USE Futility_DBC
USE ISO_C_BINDING
USE IntrType
USE ExceptionHandler
USE ParameterLists
USE Strings
USE FMU2_f_api

IMPLICIT NONE
PRIVATE

!
! List of public members
PUBLIC :: FMU2_Slave
PUBLIC :: FMU2_Model
PUBLIC :: eFMU_Wrapper

!> @brief The base FMU type.
!>        Defines interface methods applicable all FMUs and all FMI standards.
!>        The abstract methods here define what an FMU is, from the perspective of Futilty.
TYPE,ABSTRACT :: FMU
  PRIVATE
  !> Initialization status
  LOGICAL(SBK),PUBLIC :: isInit=.FALSE.
  !> Model id
  INTEGER(SIK),PUBLIC :: idFMU
  !> Model globaly unique id
  TYPE(StringType),PUBLIC :: guid
  !> Model file name used in FMU XML file open
  TYPE(StringType),PUBLIC :: modelIdentifier
  !> Path to unziped FMU
  TYPE(StringType),PUBLIC :: unzipDirectory
  !> User defined FMU instance label
  TYPE(StringType),PUBLIC :: instanceName
  !> XML derived model description
  TYPE(ParamType) :: modelDescription
  !> FMU C opaque pointer to FMU obj
  TYPE(C_PTR) :: fmu_c_ptr=c_null_ptr
!
! List of Type Bound Procedures
  CONTAINS
    !> Defered init routine
    PROCEDURE(fmu_init_sub_absintfc),DEFERRED,PASS :: init
    !> Defered clear routine
    PROCEDURE(fmu_clear_sub_absintfc),DEFERRED,PASS :: clear
    !> Defered getReal routine
    PROCEDURE(fmu_getReal_sub_absintfc),DEFERRED,PASS :: getReal
    !> Defered setReal routine
    PROCEDURE(fmu_setReal_sub_absintfc),DEFERRED,PASS :: setReal
    !> Defered getInteger routine
    PROCEDURE(fmu_getInteger_sub_absintfc),DEFERRED,PASS :: getInteger
    !> Defered setInteger routine
    PROCEDURE(fmu_setInteger_sub_absintfc),DEFERRED,PASS :: setInteger
    !> Defered getBoolean routine
    PROCEDURE(fmu_getBoolean_sub_absintfc),DEFERRED,PASS :: getBoolean
    !> Defered setBoolean routine
    PROCEDURE(fmu_setBoolean_sub_absintfc),DEFERRED,PASS :: setBoolean
ENDTYPE FMU

ABSTRACT INTERFACE
  SUBROUTINE fmu_init_sub_absintfc(self,id,pList)
    IMPORT FMU,SIK,ParamType
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: id
    TYPE(ParamType),INTENT(IN) :: pList
  ENDSUBROUTINE
  SUBROUTINE fmu_clear_sub_absintfc(self)
    IMPORT FMU,SIK,ParamType
    CLASS(FMU),INTENT(INOUT) :: self
  ENDSUBROUTINE
  SUBROUTINE fmu_getReal_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    REAL(SRK),INTENT(INOUT) :: val
  ENDSUBROUTINE
  SUBROUTINE fmu_setReal_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    REAL(SRK),INTENT(IN) :: val
  ENDSUBROUTINE
  SUBROUTINE fmu_getInteger_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    INTEGER(SIK),INTENT(INOUT) :: val
  ENDSUBROUTINE
  SUBROUTINE fmu_setInteger_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    INTEGER(SIK),INTENT(IN) :: val
  ENDSUBROUTINE
  SUBROUTINE fmu_getBoolean_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK,SBK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    LOGICAL(SBK),INTENT(INOUT) :: val
  ENDSUBROUTINE
  SUBROUTINE fmu_setBoolean_sub_absintfc(self, valueReference, val)
    IMPORT FMU,SIK,SRK,SBK
    CLASS(FMU),INTENT(INOUT) :: self
    INTEGER(SIK),INTENT(IN) :: valueReference
    LOGICAL(SBK),INTENT(IN) :: val
  ENDSUBROUTINE
ENDINTERFACE

!> @brief The base FMU2 type.
!>        Contains methods applicable to all FMUs that conform to the FMI v2.0 standard.
TYPE,EXTENDS(FMU) :: FMU2_Base
  !> FMU version
  INTEGER(SIK) :: FMU_version=2_SIK
!
!List of Type Bound Procedures
  CONTAINS
    !
    ! Mandatory FMU methods for concretion
    !
    !> @copybrief FMU_Wrapper::init_FMU2_Base
    !> @copydetails FMU_Wrapper::init_FMU2_Base
    PROCEDURE,PASS :: init => init_FMU2_Base
    !> @copybrief FMU_Wrapper::clear_FMU2_Base
    !> @copydetails FMU_Wrapper::clear_FMU2_Base
    PROCEDURE,PASS :: clear => clear_FMU2_Base
    !> @copybrief FMU_Wrapper::setupExperiment_FMU2_Base
    !> @copydetails FMU_Wrapper::setupExperiment_FMU2_Base
    PROCEDURE,PASS :: setupExperiment => setupExperiment_FMU2_Base
    !> @copybrief FMU_Wrapper::enterInitializationMode_FMU2_Base
    !> @copydetails FMU_Wrapper::enterInitializationMode_FMU2_Base
    PROCEDURE,PASS :: enterInitializationMode => enterInitializationMode_FMU2_Base
    !> @copybrief FMU_Wrapper::exitInitializationMode_FMU2_Base
    !> @copydetails FMU_Wrapper::exitInitializationMode_FMU2_Base
    PROCEDURE,PASS :: exitInitializationMode => exitInitializationMode_FMU2_Base
    !> @copybrief FMU_Wrapper::getReal_FMU2_Base
    !> @copydetails FMU_Wrapper::getReal_FMU2_Base
    PROCEDURE,PASS :: getReal => getReal_FMU2_Base
    !> @copybrief FMU_Wrapper::setReal_FMU2_Base
    !> @copydetails FMU_Wrapper::setReal_FMU2_Base
    PROCEDURE,PASS :: setReal => setReal_FMU2_Base
    !> @copybrief FMU_Wrapper::getInteger_FMU2_Base
    !> @copydetails FMU_Wrapper::getInteger_FMU2_Base
    PROCEDURE,PASS :: getInteger => getInteger_FMU2_Base
    !> @copybrief FMU_Wrapper::setInteger_FMU2_Base
    !> @copydetails FMU_Wrapper::setInteger_FMU2_Base
    PROCEDURE,PASS :: setInteger => setInteger_FMU2_Base
    !> @copybrief FMU_Wrapper::getBoolean_FMU2_Base
    !> @copydetails FMU_Wrapper::getBoolean_FMU2_Base
    PROCEDURE,PASS :: getBoolean => getBoolean_FMU2_Base
    !> @copybrief FMU_Wrapper::setBoolean_FMU2_Base
    !> @copydetails FMU_Wrapper::setBoolean_FMU2_Base
    PROCEDURE,PASS :: setBoolean => setBoolean_FMU2_Base
    !
    ! Convinience FMU XML inspection methods
    !
    !> @copybrief FMU_Wrapper::getValueReference_FMU2_Base
    !> @copydetails FMU_Wrapper::getValueReference_FMU2_Base
    PROCEDURE,PASS :: getValueReference => getValueReference_FMU2_Base
    !> @copybrief FMU_Wrapper::isXmlVar_FMU2_Base
    !> @copydetails FMU_Wrapper::isXmlVar_FMU2_Base
    PROCEDURE,PASS :: isXmlVar => isXmlVar_FMU2_Base
    !> @copybrief FMU_Wrapper::getCausality_FMU2_Base
    !> @copydetails FMU_Wrapper::getCausality_FMU2_Base
    PROCEDURE,PASS :: getCausality => getCausality_FMU2_Base
    !
    ! Convinience FMU wrapper getters and setters
    !
    !> @copybrief FMU_Wrapper::getNamedReal_FMU2_Base
    !> @copydetails FMU_Wrapper::getNamedReal_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: getNamedReal_FMU2_Base
    !> @copybrief FMU_Wrapper::setNamedReal_FMU2_Base
    !> @copydetails FMU_Wrapper::setNamedReal_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: setNamedReal_FMU2_Base
    !> @copybrief FMU_Wrapper::getNamedInteger_FMU2_Base
    !> @copydetails FMU_Wrapper::getNamedInteger_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: getNamedInteger_FMU2_Base
    !> @copybrief FMU_Wrapper::setNamedInteger_FMU2_Base
    !> @copydetails FMU_Wrapper::setNamedInteger_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: setNamedInteger_FMU2_Base
    !> @copybrief FMU_Wrapper::getNamedBoolean_FMU2_Base
    !> @copydetails FMU_Wrapper::getNamedBoolean_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: getNamedBoolean_FMU2_Base
    !> @copybrief FMU_Wrapper::setNamedBoolean_FMU2_Base
    !> @copydetails FMU_Wrapper::setNamedBoolean_FMU2_Base
    PROCEDURE,PASS,PRIVATE :: setNamedBoolean_FMU2_Base
    GENERIC :: getNamedVariable => getNamedReal_FMU2_Base, &
        getNamedInteger_FMU2_Base, getNamedBoolean_FMU2_Base
    GENERIC :: setNamedVariable => setNamedReal_FMU2_Base, &
        setNamedInteger_FMU2_Base, setNamedBoolean_FMU2_Base
ENDTYPE FMU2_Base

!> @brief FMU run in slave mode intended for use with external driver, such as CTF.
!>        Contains methods only applicable to Co-Simulation FMUs.
TYPE,EXTENDS(FMU2_Base) :: FMU2_Slave
!
!List of Type Bound Procedures
  CONTAINS
    !> @copybrief FMU_Wrapper::doStep_FMU2_Slave
    !> @copydetails FMU_Wrapper::doStep_FMU2_Slave
    PROCEDURE,PASS :: doStep => doStep_FMU2_Slave
    !> @copybrief FMU_Wrapper::setNoRewindFlag_FMU2_Slave
    !> @copydetails FMU_Wrapper::setNoRewindFlag_FMU2_Slave
    PROCEDURE,PASS :: setNoRewindFlag => setNoRewindFlag_FMU2_Slave
    !> @copybrief FMU_Wrapper::setRestart_FMU2_Slave
    !> @copydetails FMU_Wrapper::setRestart_FMU2_Slave
    PROCEDURE,PASS :: setRestart => setRestart_FMU2_Slave
    !> @copybrief FMU_Wrapper::rewindToRestart_FMU2_Slave
    !> @copydetails FMU_Wrapper::rewindToRestart_FMU2_Slave
    PROCEDURE,PASS :: rewindToRestart => rewindToRestart_FMU2_Slave
ENDTYPE FMU2_Slave

!> @brief FMU run in model exchange mode for use with Futility ODESolverTypes.
!>        Contains methods only applicable to Model Exchange FMUs.
TYPE,EXTENDS(FMU2_Base) :: FMU2_Model
!
!List of Type Bound Procedures
  CONTAINS
    !> @copybrief FMU_Wrapper::setTime_FMU2_Model
    !> @copydetails FMU_Wrapper::setTime_FMU2_Model
    PROCEDURE,PASS :: setTime => setTime_FMU2_Model
    !> @copybrief FMU_Wrapper::enterEventMode_FMU2_Model
    !> @copydetails FMU_Wrapper::enterEventMode_FMU2_Model
    PROCEDURE,PASS :: enterEventMode => enterEventMode_FMU2_Model
    !> @copybrief FMU_Wrapper::enterContinuousTimeMode_FMU2_Model
    !> @copydetails FMU_Wrapper::enterContinuousTimeMode_FMU2_Model
    PROCEDURE,PASS :: enterContinuousTimeMode => enterContinuousTimeMode_FMU2_Model
    !> @copybrief FMU_Wrapper::getDerivatives_FMU2_Model
    !> @copydetails FMU_Wrapper::getDerivatives_FMU2_Model
    PROCEDURE,PASS :: getDerivatives => getDerivatives_FMU2_Model
    !> @copybrief FMU_Wrapper::getEventIndicators_FMU2_Model
    !> @copydetails FMU_Wrapper::getEventIndicators_FMU2_Model
    PROCEDURE,PASS :: getEventIndicators => getEventIndicators_FMU2_Model
    !> @copybrief FMU_Wrapper::getNumberOfContinuousStates_FMU2_Model
    !> @copydetails FMU_Wrapper::getNumberOfContinuousStates_FMU2_Model
    PROCEDURE,PASS :: getNumberOfContinuousStates => getNumberOfContinuousStates_FMU2_Model
    !> @copybrief FMU_Wrapper::getContinuousStates_FMU2_Model
    !> @copydetails FMU_Wrapper::getContinuousStates_FMU2_Model
    PROCEDURE,PASS :: getContinuousStates => getContinuousStates_FMU2_Model
    !> @copybrief FMU_Wrapper::setContinuousStates_FMU2_Model
    !> @copydetails FMU_Wrapper::setContinuousStates_FMU2_Model
    PROCEDURE,PASS :: setContinuousStates => setContinuousStates_FMU2_Model
    !> @copybrief FMU_Wrapper::completedIntegratorStep_FMU2_Model
    !> @copydetails FMU_Wrapper::completedIntegratorStep_FMU2_Model
    PROCEDURE,PASS :: completedIntegratorStep => completedIntegratorStep_FMU2_Model
ENDTYPE FMU2_Model

!> Exception Handler for use in the FMU_Wrapper
TYPE(ExceptionHandlerType),SAVE :: eFMU_Wrapper

!> Name of module
CHARACTER(LEN=*),PARAMETER :: modName='FMU_Wrapper'

!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Initializes the FMU
!>
!> @param self the FMU2_Base to act on
!> @param id Unique id for this FMU
!> @param pList A parameter list with input options
!>
SUBROUTINE init_FMU2_Base(self,id,pList)
  CHARACTER(LEN=*),PARAMETER :: myName='init_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: id
  TYPE(ParamType),INTENT(IN) :: pList

  ! Required FMU pList
  IF(.NOT. pList%has('unzipDirectory')) CALL eFMU_Wrapper%raiseError( &
      modName//'::'//myName//' - No FMU unzipDirectory')
  CALL pList%get('unzipDirectory', self%unzipDirectory)
  self%idFMU=id
  self%FMU_version=2_SIK

  ! Parse the FMU XML model description
  CALL eFMU_Wrapper%raiseDebug('Opening FMU XML File: '// &
      self%unzipDirectory//'/modelDescription.xml' )
  CALL self%modelDescription%initFromXML(self%unzipDirectory// &
      '/modelDescription.xml',.TRUE.)

  ! Optional FMU pList
  IF(pList%has('instanceName')) THEN
    CALL pList%get('instanceName', self%instanceName)
  ELSE
    self%instanceName = "default_fmu_instance"
  ENDIF
  IF(pList%has('modelIdentifier')) THEN
    CALL pList%get('modelIdentifier', self%modelIdentifier)
  ELSE
    CALL self%modelDescription%get('modelIdentifier', self%modelIdentifier)
  ENDIF
  IF(pList%has('guid')) THEN
    CALL pList%get('guid', self%guid)
  ELSE
    CALL self%modelDescription%get('guid', self%guid)
  ENDIF

  ! Initilize the FMU
  self%fmu_c_ptr = InitilizeFMU2_Base(self%idFMU, &
    CHAR(self%guid)//c_null_char, &
    CHAR(self%modelIdentifier)//c_null_char, &
    CHAR(self%unzipDirectory)//c_null_char, &
    CHAR(self%instanceName)//c_null_char)

  self%isInit=.TRUE.

ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set the FMU internal ODE integrator settings
!>
!> @param self the FMU2_Base to act on
!> @param toleranceDefined flag to override internal FMU ODE tolerance settings
!> @param tolerance tolerance of FMU ODE integrator
!> @param startTime start time of FMU ODE integration
!> @param stopTimeDefined flag to determine if ODE integration stops at stopTime
!> @param stopTime  end time of ODE integration
!>
SUBROUTINE setupExperiment_FMU2_Base(self, toleranceDefined, tolerance, startTime, &
    stopTimeDefined, stopTime, finalizeInitialization_opt)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  LOGICAL(SBK),INTENT(IN) :: toleranceDefined
  REAL(SRK),INTENT(IN) :: tolerance
  REAL(SRK),INTENT(IN) :: startTime
  LOGICAL(SBK),INTENT(IN) :: stopTimeDefined
  REAL(SRK),INTENT(IN) :: stopTime
  LOGICAL(SBK),INTENT(IN),OPTIONAL :: finalizeInitialization_opt

  LOGICAL(SBK) :: finalizeInitialization=.TRUE.

  IF(PRESENT(finalizeInitialization_opt)) finalizeInitialization=finalizeInitialization_opt

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setupExperimentFMU2_Base(self%fmu_c_ptr, LOGICAL(toleranceDefined,1), tolerance, &
      startTime, LOGICAL(stopTimeDefined,1), stopTime, LOGICAL(finalizeInitialization,1))
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get the valueReference that corresponds to the FMU variableName
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @returns valueReference the value reference of variable in the FMU.
!>          The valueReference is an integer handle to an FMU variable.
!>
FUNCTION getValueReference_FMU2_Base(self, variableName) RESULT(valueReference)
  CHARACTER(LEN=*),PARAMETER :: myName='getValueReference_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  INTEGER(SIK) :: valueReference

  TYPE(StringType) :: valueReference_str
  TYPE(StringType) :: baseAddr

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  ! check that requrested variable exists in the modelDescription
  baseAddr='MODELVARIABLES->'//variableName
  IF(self%isXmlVar(variableName)) THEN
    ! get valueReference assc with this variableName
    CALL self%modelDescription%get(baseAddr//'->valueReference', valueReference_str)
    ! convert str to int and check valueReference is valid
    valueReference = valueReference_str%str_to_sik()
    IF(valueReference < 0) CALL eFMU_Wrapper%raiseError(modName//'::'// &
        ' - variable has invalid valueReference')
  ELSE
    CALL eFMU_Wrapper%raiseError(modName//'::'//myName//' - No Variable named: '//variableName)
  ENDIF
ENDFUNCTION
!
!-------------------------------------------------------------------------------
!> @brief Check if variableName is in the FMU XML file
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @returns isVar boolean if the FMU XML contains the variableName
!>
FUNCTION isXmlVar_FMU2_Base(self, variableName) RESULT(isVar)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  LOGICAL(SBK) :: isVar

  REQUIRE(self%isInit)

  ! check that requrested variable exists in the modelDescription
  IF(self%modelDescription%has(variableName)) THEN
    isVar=.TRUE.
  ELSE
    isVar=.FALSE.
  ENDIF

ENDFUNCTION
!
!-------------------------------------------------------------------------------
!> @brief Get the causality of the FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @returns causality the FMU variable causality.  The causality is an FMU
!>          variable property that signifies how the FMU variable obtains
!>          its value.  See fmi-standard.org for additional info.
!>
FUNCTION getCausality_FMU2_Base(self, variableName) RESULT(causality)
  CHARACTER(LEN=*),PARAMETER :: myName='getCausality_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  TYPE(StringType) :: causality

  TYPE(StringType) :: baseAddr
  TYPE(StringType) :: causalityAddr

  REQUIRE(self%isInit)

  ! check that requrested variable exists in the modelDescription
  baseAddr='MODELVARIABLES->'//variableName
  IF(self%isXmlVar(variableName)) THEN
    ! get valueReference assc with this variableName
    causalityAddr = baseAddr//'->causality'
    IF(self%modelDescription%has(CHAR(causalityAddr))) THEN
      CALL self%modelDescription%get(CHAR(causalityAddr), causality)
    ELSE
      ! default causality is local as defined by FMI standard
      causality='local'
    ENDIF
  ELSE
    CALL eFMU_Wrapper%raiseError(modName//'::'//myName//' - No Variable named: '//variableName)
  ENDIF
ENDFUNCTION
!
!-------------------------------------------------------------------------------
!> @brief Get real FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE getReal_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  REAL(SRK),INTENT(INOUT) :: val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL getRealFMU2_Base(self%fmu_c_ptr, valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set real FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE setReal_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  REAL(SRK),INTENT(IN) :: val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setRealFMU2_Base(self%fmu_c_ptr, valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get integer FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE getInteger_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  INTEGER(SIK),INTENT(INOUT) :: val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL getIntegerFMU2_Base(self%fmu_c_ptr, valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set integer FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE setInteger_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  INTEGER(SIK),INTENT(IN) :: val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setIntegerFMU2_Base(self%fmu_c_ptr, valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get boolean FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE getBoolean_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  LOGICAL(SBK),INTENT(INOUT) :: val
  LOGICAL(1) :: tmp_val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL getBooleanFMU2_Base(self%fmu_c_ptr, valueReference, tmp_val)
  val = tmp_val
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set boolean FMU variable
!>
!> @param self the FMU2_Base to act on
!> @param valueReference the integer identifer of the FMU variable
!> @param val variable value
!>
SUBROUTINE setBoolean_FMU2_Base(self, valueReference, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  INTEGER(SIK),INTENT(IN) :: valueReference
  LOGICAL(SBK),INTENT(IN) :: val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setBooleanFMU2_Base(self%fmu_c_ptr, valueReference, LOGICAL(val,1))
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get a real variable in the FMU model
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE getNamedReal_FMU2_Base(self, variableName, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  REAL(SRK),INTENT(OUT) :: val

  INTEGER(SIK) :: valueReference

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  CALL self%getReal(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set a real variable in the FMU model
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE setNamedReal_FMU2_Base(self, variableName, val)
  CHARACTER(LEN=*),PARAMETER :: myName='setNamedReal_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  REAL(SRK),INTENT(IN) :: val

  INTEGER(SIK) :: valueReference
  TYPE(StringType) :: causality

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  causality = self%getCausality(variableName)
  IF(.NOT.(causality == 'parameter' .OR. causality == 'input')) &
      CALL eFMU_Wrapper%raiseWarning(modName//'::'//myName// &
      ' - Attempting to set variable '//variableName//' with causality: '//causality)
  CALL self%setReal(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get an integer variable in the FMU model
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE getNamedInteger_FMU2_Base(self, variableName, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  INTEGER(SIK),INTENT(OUT) :: val

  INTEGER(SIK) :: valueReference

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  CALL self%getInteger(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set an integer variable in the FMU model to val
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE setNamedInteger_FMU2_Base(self, variableName, val)
  CHARACTER(LEN=*),PARAMETER :: myName='setNamedInteger_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  INTEGER(SIK),INTENT(IN) :: val

  INTEGER(SIK) :: valueReference
  TYPE(StringType) :: causality

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  causality = self%getCausality(variableName)
  IF(.NOT.(causality == 'parameter' .OR. causality == 'input')) &
      CALL eFMU_Wrapper%raiseWarning(modName//'::'//myName// &
      ' - Attempting to set variable '//variableName//' with causality: '//causality)
  CALL self%setInteger(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get a boolean variable in the FMU model to val
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE getNamedBoolean_FMU2_Base(self, variableName, val)
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  LOGICAL(SBK),INTENT(OUT) :: val

  INTEGER(SIK) :: valueReference

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  CALL self%getBoolean(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set a boolean variable in the FMU model to val
!>
!> @param self the FMU2_Base to act on
!> @param variableName name of FMU variable
!> @param val variable value
!>
SUBROUTINE setNamedBoolean_FMU2_Base(self, variableName, val)
  CHARACTER(LEN=*),PARAMETER :: myName='setNamedBoolean_FMU2_Base'
  CLASS(FMU2_Base),INTENT(INOUT) :: self
  CHARACTER(LEN=*),INTENT(IN) :: variableName
  LOGICAL(SBK),INTENT(IN) :: val

  INTEGER(SIK) :: valueReference
  TYPE(StringType) :: causality

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  valueReference = self%getValueReference(variableName)
  causality = self%getCausality(variableName)
  IF(.NOT.(causality == 'parameter' .OR. causality == 'input')) &
      CALL eFMU_Wrapper%raiseWarning(modName//'::'//myName// &
      ' - Attempting to set variable '//variableName//' with causality: '//causality)
  CALL self%setBoolean(valueReference, val)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Enter FMU initialization mode
!>
!> @param self the FMU2_Base to act on
!>
SUBROUTINE enterInitializationMode_FMU2_Base(self)
  CLASS(FMU2_Base),INTENT(INOUT) :: self

  CALL enterInitializationModeFMU2_Base(self%fmu_c_ptr)

ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Exit FMU initialization mode
!>
!> @param self the FMU2_Base to act on
!>
SUBROUTINE exitInitializationMode_FMU2_Base(self)
  CLASS(FMU2_Base),INTENT(INOUT) :: self

  CALL exitInitializationModeFMU2_Base(self%fmu_c_ptr)

ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Clear the FMU model
!>
!> @param self the FMU2_Base to act on
!>
SUBROUTINE clear_FMU2_Base(self)
  CLASS(FMU2_Base),INTENT(INOUT) :: self

  CALL clearFMU2_Base(self%fmu_c_ptr)
  self%isInit=.FALSE.
  self%fmu_c_ptr = c_null_ptr

  CALL self%modelDescription%clear()
  ENSURE(.NOT. c_associated(self%fmu_c_ptr))

ENDSUBROUTINE
!
! ========================= Slave Mode =============================
!
!-------------------------------------------------------------------------------
!> @brief Set flag to disable FMU rewind capability
!>
!> @param self the FMU2_Slave to act on
!> @param noRw flag to disable rewind capability. Default in FMU2_Slave is
!>   to allow the FMU to be rewound
!>
!> Depending on the FMU implementation, this flag may be ignored
SUBROUTINE setNoRewindFlag_FMU2_Slave(self,noRw)
  CLASS(FMU2_Slave),INTENT(INOUT) :: self
  LOGICAL(SBK),INTENT(IN) :: noRw

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setNoRewindFlagFMU2_Slave(self%fmu_c_ptr, LOGICAL(noRw,1))
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Step the FMU model forward in time
!>
!> @param self the FMU2_Slave to act on
!> @param h time step size
!>
SUBROUTINE doStep_FMU2_Slave(self,h)
  CLASS(FMU2_Slave),INTENT(INOUT) :: self
  REAL(SRK),INTENT(IN) :: h

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL doStepFMU2_Slave(self%fmu_c_ptr, h)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set FMU model restart point
!>
!> @param self the FMU2_Slave to act on
!>
SUBROUTINE setRestart_FMU2_Slave(self)
  CHARACTER(LEN=*),PARAMETER :: myName='setRestart_FMU2_Slave'
  CLASS(FMU2_Slave),INTENT(INOUT) :: self

  TYPE(StringType) :: baseAddr
  TYPE(StringType) :: getSetAddr
  TYPE(StringType) :: isGetSet_str

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  ! check that requrested variable exists in the modelDescription
  baseAddr='COSIMULATION'
  getSetAddr=baseAddr//'->canGetAndSetFMUstate'
  IF(self%modelDescription%has(CHAR(getSetAddr))) THEN
    CALL self%modelDescription%get(baseAddr//'->canGetAndSetFMUstate', isGetSet_str)
    IF(.NOT. (isGetSet_str == "true" .OR. isGetSet_str == "True" .OR. isGetSet_str == "TRUE")) &
        CALL eFMU_Wrapper%raiseError(modName//'::'//' - FMU does not support GetSetFMUstate.')
  ELSE
    CALL eFMU_Wrapper%raiseWarning(modName//'::'//myName// &
        ' - GetSetFMUstate capability was not detected.')
  ENDIF

  CALL serializeStateFMU2_Slave(self%fmu_c_ptr)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Rewind FMU to restart point
!>
!> @param self the FMU2_Slave to act on
!>
SUBROUTINE rewindToRestart_FMU2_Slave(self)
  CLASS(FMU2_Slave),INTENT(INOUT) :: self

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL deSerializeStateFMU2_Slave(self%fmu_c_ptr)
ENDSUBROUTINE
!
! ========================= Model Exchange Mode =============================
!
!-------------------------------------------------------------------------------
!> @brief Set the Model Exchange FMU time
!>
!> @param self the FMU2_Model to act on
!> @param time the time to pass to the FMU
!>
SUBROUTINE setTime_FMU2_Model(self, time)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  REAL(SRK),INTENT(IN) :: time

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setTimeFMU2_Model(self%fmu_c_ptr, time)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Enter event mode in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!>
SUBROUTINE enterEventMode_FMU2_Model(self)
  CLASS(FMU2_Model),INTENT(INOUT) :: self

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL enterEventModeFMU2_Model(self%fmu_c_ptr)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Enter continuous time mode in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!>
SUBROUTINE enterContinuousTimeMode_FMU2_Model(self)
  CLASS(FMU2_Model),INTENT(INOUT) :: self

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL enterContinuousTimeModeFMU2_Model(self%fmu_c_ptr)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get derivatives of all state vars in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @param dx A one dimensional array of derivatives of all state variables
!>
SUBROUTINE getDerivatives_FMU2_Model(self, dx)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  REAL(SRK),INTENT(INOUT),ALLOCATABLE :: dx(:)

  INTEGER(SIK) :: nx

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  nx = self%getNumberOfContinuousStates()
  ALLOCATE(dx(nx))
  CALL getDerivativesFMU2_Model(self%fmu_c_ptr, dx, nx)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get number of continuous states in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @returns number of continuous state variables in the FMU model
!>
FUNCTION getNumberOfContinuousStates_FMU2_Model(self) RESULT(nx)
  CLASS(FMU2_Model),INTENT(INOUT) :: self

  INTEGER(SIK) :: nx

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL self%modelDescription%get('nDerivatives', nx)
ENDFUNCTION
!
!-------------------------------------------------------------------------------
!> @brief Get value of all state vars in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @param x A one dimensional array of state variable values
!>
SUBROUTINE getContinuousStates_FMU2_Model(self, x)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  REAL(SRK),INTENT(INOUT),ALLOCATABLE :: x(:)

  INTEGER(SIK) :: nx

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  nx = self%getNumberOfContinuousStates()
  ALLOCATE(x(nx))
  CALL getContinuousStatesFMU2_Model(self%fmu_c_ptr, x, nx)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Set the value of all state vars in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @param x A one dimensional array of state variable values
!>
SUBROUTINE setContinuousStates_FMU2_Model(self, x)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  REAL(SRK),INTENT(IN) :: x(:)

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL setContinuousStatesFMU2_Model(self%fmu_c_ptr, x, SIZE(x))
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get the event indicators in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @param xi A one dimensional array of all FMU event indicators
!>
SUBROUTINE getEventIndicators_FMU2_Model(self, xi)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  REAL(SRK),INTENT(INOUT),ALLOCATABLE :: xi(:)

  INTEGER(SIK) :: ni

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL self%modelDescription%get('numberOfEventIndicators', ni)
  ALLOCATE(xi(ni))
  CALL getEventIndicatorsFMU2_Model(self%fmu_c_ptr, xi, ni)
ENDSUBROUTINE
!
!-------------------------------------------------------------------------------
!> @brief Get the status of the integrator step in the Model Exchange FMU
!>
!> @param self the FMU2_Model to act on
!> @param completed_step flag is true if integrator step is complete
!>
SUBROUTINE completedIntegratorStep_FMU2_Model(self, completed_step)
  CLASS(FMU2_Model),INTENT(INOUT) :: self
  LOGICAL(SBK),INTENT(OUT) :: completed_step

  LOGICAL(1) :: tmp_val

  REQUIRE(self%isInit)
  REQUIRE(c_associated(self%fmu_c_ptr))

  CALL completedIntegratorStepFMU2_Model(self%fmu_c_ptr, tmp_val)
  completed_step = tmp_val
ENDSUBROUTINE

ENDMODULE FMU_Wrapper

max_stars_repo_name: picmc/Futility

max_issues_repo_name: picmc/Futility

max_forks_repo_name: picmc/Futility


text:
To ensure that comments reflect the current state of UPS Store (Downtown), the comments made before new management took over have been moved here. Please put new developments on the UPS Store (Downtown) page.

20060330 17:51:13 nbsp The downtown one was atrocious. They told me over the phone that I could get something overnighted to UCLA as long as I was there by 5 pmso I went there instead of to USPS. Never again. Not only was the UPS driver a complete ass and wouldnt wait one minute for me to give him my package (and worse, shouted something about being in luck...as he flew out the door and drove off), the person there couldnt find the address I needed, although it was quite clear. By the grace of god, I got to the post office before 5:30, and I was lucky enough to be sending it to SoCal, so it got there the next day (though not guaranteed). The amount of incompetence almost cost me getting something in on time; I couldve just gone to the P.O., no stress, if theyd just said, hey we cant do it. Yargh. Users/JulieEickhof

20060429 12:32:06 nbsp The Downtown location is completely useless. They wont give you quotes over the phone, or tell you their prices. The MarketPlace location is a lot better, but the boxes are overpriced. Users/ShayanMoini

20070314 17:05:42 nbsp The statement that the ups store does package recieving is misleading. Yeah you can pick up a package there, but only for a large fee (something in the neighborhood of 520 dollars depending on certain factors). Thus i always tell people to send packages Fedex so i can pick it up at the downtown kinkos for free instead of going to sac or wasting 520 bucks. Users/MattHh


text:
      SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To construct the block Hankel expansion T of a multivariable
C     parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k)
C     is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NH1     (input) INTEGER
C             The number of rows in each parameter M(k).  NH1 >= 0.
C
C     NH2     (input) INTEGER
C             The number of columns in each parameter M(k).  NH2 >= 0.
C
C     NR      (input) INTEGER
C             The number of parameters required in each column of the
C             block Hankel expansion matrix T.  NR >= 0.
C
C     NC      (input) INTEGER
C             The number of parameters required in each row of the
C             block Hankel expansion matrix T.  NC >= 0.
C
C     H       (input) DOUBLE PRECISION array, dimension
C             (LDH,(NR+NC-1)*NH2)
C             The leading NH1-by-(NR+NC-1)*NH2 part of this array must
C             contain the multivariable sequence M(k), where k = 1,2,
C             ...,(NR+NC-1). Specifically, each parameter M(k) is an
C             NH1-by-NH2 matrix whose (i,j)-th element must be stored in
C             H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,NH1).
C
C     T       (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC)
C             The leading NH1*NR-by-NH2*NC part of this array contains
C             the block Hankel expansion of the multivariable sequence
C             M(k).
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= MAX(1,NH1*NR).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The NH1-by-NH2 dimensional parameters M(k) of a multivariable
C     sequence are arranged into a matrix T in Hankel form such that
C
C
C              | M(1)   M(2)    M(3)    . . .  M(NC)     |
C              |                                         |
C              | M(2)   M(3)    M(4)    . . .  M(NC+1)   |
C         T =  |  .      .       .              .        |.
C              |  .      .       .              .        |
C              |  .      .       .              .        |
C              |                                         |
C              | M(NR)  M(NR+1) M(NR+2) . . .  M(NR+NC-1)|
C
C     REFERENCES
C
C     [1] Johvidov, J.S.
C         Hankel and Toeplitz Matrices and Forms: Algebraic Theory,
C         (translated by G.P.A. Thijsse, I. Gohberg, ed.).
C         Birkhaeuser, Boston, 1982.
C
C     NUMERICAL ASPECTS
C
C     The time taken is approximately proportional to
C     NH1 x NH2 x NR x NC.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke
C     Univ. Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Hankel matrix, multivariable system.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, LDT, NC, NH1, NH2, NR
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), T(LDT,*)
C     .. Local Scalars ..
      INTEGER           IH, IT, JT, NROW
C     .. External Subroutines ..
      EXTERNAL          DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NH1.LT.0 ) THEN
         INFO = -1
      ELSE IF( NH2.LT.0 ) THEN
         INFO = -2
      ELSE IF( NR.LT.0 ) THEN
         INFO = -3
      ELSE IF( NC.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN
         INFO = -6
      ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( NH1, NH2, NR, NC ).EQ.0 )
     $   RETURN
C
C     Construct the first block column of T.
C
      IH = 1
      NROW = (NR-1)*NH1
C
      DO 10 IT = 1, NROW+NH1, NH1
         CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT )
         IH = IH + NH2
   10 CONTINUE
C
C     Construct the remaining block columns of T.
C
      DO 20 JT = NH2+1, NC*NH2, NH2
         CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT),
     $                LDT )
         CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT),
     $                LDT )
         IH = IH + NH2
   20 CONTINUE
C
      RETURN
C *** Last line of TF01OD ***
      END

max_stars_repo_name: bgin/MissileSimulation

max_issues_repo_name: bgin/MissileSimulation

max_forks_repo_name: bgin/MissileSimulation


#INCLUDE 'MR_H_ALIGN_PADDING.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_CALC_EQK_A3_B3_C3_D3

    USE MR_KINDS

    USE MR_DEF_CURVED_GEOS
    USE MR_DEF_CONSTS_N_REF_PARS
    USE MR_DEF_FIELD_VARS
    USE MR_DEF_ACTIVITY
    USE MR_DEF_TIMING

    USE MR_MOC_K_EPS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_CALC_EQK_A3_B3_C3 , MR_CALC_EQK_D3

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQK_A3_B3_C3( NI , NJ , NK , EQK_A3 , EQK_B3 , EQK_C3 )

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,2:NK  ) :: EQK_A3
    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:NK  ) :: EQK_B3
    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:NK-1) :: EQK_C3

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          !BLOCK
            EQK_B3( I , J , K ) = MW( I , J )
          !END BLOCK
        END DO
      END DO
    END DO

    DO K = 2 , NK
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            EQK_A3( I , J , K ) =-DT * PHI * EKZ/SIK * MW( I , J ) * VZW( I , J ,K-1) / ( H( I , J ) * DSIGMA )**2
            EQK_B3( I , J , K ) = EQK_B3( I , J , K ) - EQK_A3( I , J , K )
          ELSE
            EQK_A3( I , J , K ) = 0.0
          END IF
        END DO
      END DO
    END DO

    K = 1
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          !BLOCK
            EQK_C3( I , J , K ) = 0.0
          !END BLOCK
        END DO
      END DO
    !END K = 1
    DO K = 2 , NK-1
      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            EQK_C3( I , J , K ) = EQK_A3( I , J ,K+1)
            EQK_B3( I , J , K ) = EQK_B3( I , J , K ) - EQK_C3( I , J , K )
          ELSE
            EQK_C3( I , J , K ) = 0.0
          END IF
        END DO
      END DO
    END DO

  END SUBROUTINE MR_CALC_EQK_A3_B3_C3

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_CALC_EQK_D3( NI , NJ , NK , EQKD_PRO_XY , EQKD_PRO_Z , EQKD_BRO_Z , EQK_D3 )

    USE MR_MOD_CALC_EQK_ADV_N_DIF_Z
    USE MR_MOD_CALC_EQK_ADV_N_DIF_XY
    USE MR_MOD_CALC_EQK_SRC_XYZ

    IMPLICIT NONE

    INTEGER(IJID_KIND) , INTENT(IN ) :: NI , NJ
    INTEGER(KKID_KIND) , INTENT(IN ) :: NK

    REAL   (FDRD_KIND) , INTENT(IN ) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK  ) :: EQKD_PRO_XY , EQKD_PRO_Z , EQKD_BRO_Z

    REAL   (CARD_KIND) , INTENT(OUT) , DIMENSION(1:NI1(NI,CARD_KIND),1:NJ,1:NK  ) :: EQK_D3

    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ,1:NK) :: EQK_ADV_Z  , EQK_DIF_Z
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ     ) :: EQK_ADV_XY , EQK_DIF_XY
    REAL   (FDRD_KIND) , DIMENSION(1:NI1(NI,FDRD_KIND),1:NJ     ) :: EQK_SRC_XYZ

    INTEGER(IJID_KIND) :: I , J
    INTEGER(KKID_KIND) :: K

    DO K = 1 , NK

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          !BLOCK
            EQK_D3( I , J , K ) = MW( I , J ) * KI( I , J , K )
          !END BLOCK
        END DO
      END DO

    END DO

  ! ASSIGN NONEQUILIBRIUM TERMS
    CALL MR_CALC_EQK_ADV_N_DIF_Z( NI , NJ , NK , EQK_ADV_Z , EQK_DIF_Z )

    DO K = 2 , NK

      CALL MR_CALC_EQK_ADV_N_DIF_XY( NI , NJ , K , EQK_ADV_XY , EQK_DIF_XY )
      CALL MR_CALC_EQK_SRC_XYZ( NI , NJ , K , EQKD_PRO_XY(:,:, K ) , EQKD_PRO_Z(:,:, K ) , EQKD_BRO_Z(:,:, K ) , EQK_SRC_XYZ )

      DO J = 1 , NJ
       !DIR$ VECTOR ALIGNED
        DO I = 1 , NI
          IF( ACTIVITY( I , J ) == BEACTIVE ) THEN
            EQK_D3( I , J , K ) = EQK_D3( I , J , K ) +  &
            & EQK_ADV_XY( I , J ) + EQK_ADV_Z( I , J , K ) +   &
            & EQK_DIF_XY( I , J ) + EQK_DIF_Z( I , J , K ) +   &
            & EQK_SRC_XYZ( I , J )
          END IF
        END DO
      END DO

    END DO

  END SUBROUTINE MR_CALC_EQK_D3

  END MODULE MR_MOD_CALC_EQK_A3_B3_C3_D3