text:
	SUBROUTINE GQBARB  ( szbarb, ibrwid, ibrtyp, iret )
C************************************************************************
C* GQBARB								*
C*									*
C* This subroutine returns the current wind barb size, barb line width  *
C* and barb type. 						        *
C*									*
C* GQBARB  ( SZBARB, IBRWID, IBRTYP, IRET )				*
C*									*
C* Output parameters:							*
C*	SZBARB		REAL		Wind barb size 			*
C* 	IBRWID		INTEGER		Line width 			*
C*	IBRTYP		INTEGER		Barb type			*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* I. Graffman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* S. Schotz/GSC	 1/90	Added wind bard width and type		*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* A. Hardy/GSC          6/98   Cleaned up prolog                       *
C************************************************************************
	INCLUDE		'FUNCCODE.PRM'
	INCLUDE		'ERROR.PRM'
C*
	INTEGER		isend (2), ircv(2)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 2
	isend (2) = FQBARB
C
	CALL GPUT  ( isend, 2, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
C*	Get output parameters.
C
	CALL GGET  ( iret, 1, ierr )
	IF  ( ierr .ne. NORMAL )  THEN
	    iret = ierr
	    RETURN
	END IF
C
	CALL GGETR  ( szbarb, 1, ierr )
	IF ( ierr .eq. NORMAL ) THEN
	    CALL GGET ( ircv, 2, ierr )
	    IF ( ierr .eq. NORMAL ) THEN
                ibrwid = ircv (1)
                ibrtyp = ircv (2)
	    END IF
        END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
        SUBROUTINE  MA_S4EG ( marrpt, ipt, iret )
C************************************************************************
C* MA_S4EG                                                              *
C*                                                                      *
C* This subroutine decodes the first of the drifting buoy section 4     *
C* groups 8V(i)V(i)V(i)V(i), which contains information on the          *
C* engineering status of the buoy.                                      *
C*                                                                      *
C* MA_S4EG ( MARRPT, IPT, IRET )                                        *
C*                                                                      *
C* Input parameters:                                                    *
C*      MARRPT         CHAR*       Report array                         *
C*                                                                      *
C* Input and output parameters:                                         *
C*	IPT	       INTEGER	   On input, points to the space before *
C*                                 group 8VVVV; on output, to the last  *
C*                                 V in group                           *
C* Output parameters:                                                   *
C*      RIVALS(IRBENG) REAL        Engineering status info on buoy      *
C*      IRET           INTEGER     Return code                          *
C*                                   0 = normal return                  *
C*                                   1 = problems                       *
C*                                                                      *
C**                                                                     *
C* Log:                                                                 *
C* R. Hollern/NCEP       9/99                                           *
C************************************************************************
        INCLUDE         'macmn.cmn'
C*
        CHARACTER*(*)   marrpt
C*
        CHARACTER       fld4*4
C------------------------------------------------------------------------
        iret = 0
        ipt  = ipt + 2
        fld4 = marrpt ( ipt:ipt+3 )
        CALL  ST_INTG ( fld4, ival, ier )
        ipt  = ipt + 3
        IF ( ier .eq. 0 ) THEN
            rivals ( irbeng )  =  FLOAT ( ival )
        END IF
C*
	RETURN
	END

ext: f


text:
Z-System Resident Command Package (RCP) in source code form, version
1.1.  Complete Z80 source code to the RCP plus documentation, for
ZCPR versions 3.3 and above.  Adds several exciting new commands and
features and fixes various bugs in the previous release.  See
companion file RCPZRL11.LBR for pre-compiled RCP modules which may
be loaded with NZ-COM, Z3PLUS, or JetLDR.

ext: for

max_stars_repo_name: davidknoll/RomWBW

max_stars_repo_licenses: DOC MIT

max_issues_repo_name: davidknoll/RomWBW

max_issues_repo_licenses: DOC MIT

max_forks_repo_name: davidknoll/RomWBW

max_forks_repo_licenses: DOC MIT


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------

!C
!C***
!C*** module hecmw_precond_DIAG_66
!C***
!C
module hecmw_precond_DIAG_66
  use  hecmw_util

  private

  public:: hecmw_precond_DIAG_66_setup
  public:: hecmw_precond_DIAG_66_apply
  public:: hecmw_precond_DIAG_66_clear

  integer(kind=kint) :: N
  real(kind=kreal), pointer :: ALU(:) => null()

contains

  subroutine hecmw_precond_DIAG_66_setup(hecMAT)
    use hecmw_matrix_misc
    implicit none
    type(hecmwST_matrix), intent(in) :: hecMAT
    integer(kind=kint ) :: NP
    real   (kind=kreal) :: SIGMA_DIAG
    real(kind=kreal), pointer:: D(:)

    real   (kind=kreal):: ALUtmp(6,6), PW(6)
    integer(kind=kint ):: ii, i, j, k

    N = hecMAT%N
    NP = hecMAT%NP
    D => hecMAT%D
    SIGMA_DIAG = hecmw_mat_get_sigma_diag(hecMAT)

    allocate(ALU(36*NP))
    ALU = 0.d0

    do ii= 1, N
      ALU(36*ii-35) = D(36*ii-35)
      ALU(36*ii-34) = D(36*ii-34)
      ALU(36*ii-33) = D(36*ii-33)
      ALU(36*ii-32) = D(36*ii-32)
      ALU(36*ii-31) = D(36*ii-31)
      ALU(36*ii-30) = D(36*ii-30)
      ALU(36*ii-29) = D(36*ii-29)
      ALU(36*ii-28) = D(36*ii-28)
      ALU(36*ii-27) = D(36*ii-27)
      ALU(36*ii-26) = D(36*ii-26)
      ALU(36*ii-25) = D(36*ii-25)
      ALU(36*ii-24) = D(36*ii-24)
      ALU(36*ii-23) = D(36*ii-23)
      ALU(36*ii-22) = D(36*ii-22)
      ALU(36*ii-21) = D(36*ii-21)
      ALU(36*ii-20) = D(36*ii-20)
      ALU(36*ii-19) = D(36*ii-19)
      ALU(36*ii-18) = D(36*ii-18)
      ALU(36*ii-17) = D(36*ii-17)
      ALU(36*ii-16) = D(36*ii-16)
      ALU(36*ii-15) = D(36*ii-15)
      ALU(36*ii-14) = D(36*ii-14)
      ALU(36*ii-13) = D(36*ii-13)
      ALU(36*ii-12) = D(36*ii-12)
      ALU(36*ii-11) = D(36*ii-11)
      ALU(36*ii-10) = D(36*ii-10)
      ALU(36*ii-9 ) = D(36*ii-9 )
      ALU(36*ii-8 ) = D(36*ii-8 )
      ALU(36*ii-7 ) = D(36*ii-7 )
      ALU(36*ii-6 ) = D(36*ii-6 )
      ALU(36*ii-5 ) = D(36*ii-5 )
      ALU(36*ii-4 ) = D(36*ii-4 )
      ALU(36*ii-3 ) = D(36*ii-3 )
      ALU(36*ii-2 ) = D(36*ii-2 )
      ALU(36*ii-1 ) = D(36*ii-1 )
      ALU(36*ii   ) = D(36*ii   )
    enddo

    !    if (hecMAT%cmat%n_val.gt.0) then
    !      do k= 1, hecMAT%cmat%n_val
    !        if (hecMAT%cmat%pair(k)%i.ne.hecMAT%cmat%pair(k)%j) cycle
    !        ii = hecMAT%cmat%pair(k)%i
    !        ALU(9*ii-8) = ALU(9*ii-8) + hecMAT%cmat%pair(k)%val(1, 1)
    !        ALU(9*ii-7) = ALU(9*ii-7) + hecMAT%cmat%pair(k)%val(1, 2)
    !        ALU(9*ii-6) = ALU(9*ii-6) + hecMAT%cmat%pair(k)%val(1, 3)
    !        ALU(9*ii-5) = ALU(9*ii-5) + hecMAT%cmat%pair(k)%val(2, 1)
    !        ALU(9*ii-4) = ALU(9*ii-4) + hecMAT%cmat%pair(k)%val(2, 2)
    !        ALU(9*ii-3) = ALU(9*ii-3) + hecMAT%cmat%pair(k)%val(2, 3)
    !        ALU(9*ii-2) = ALU(9*ii-2) + hecMAT%cmat%pair(k)%val(3, 1)
    !        ALU(9*ii-1) = ALU(9*ii-1) + hecMAT%cmat%pair(k)%val(3, 2)
    !        ALU(9*ii  ) = ALU(9*ii  ) + hecMAT%cmat%pair(k)%val(3, 3)
    !      enddo
    !
    !      !call hecmw_cmat_LU( hecMAT )
    !
    !    endif

    do ii= 1, N
      ALUtmp(1,1)= ALU(36*ii-35) * SIGMA_DIAG
      ALUtmp(1,2)= ALU(36*ii-34)
      ALUtmp(1,3)= ALU(36*ii-33)
      ALUtmp(1,4)= ALU(36*ii-32)
      ALUtmp(1,5)= ALU(36*ii-31)
      ALUtmp(1,6)= ALU(36*ii-30)

      ALUtmp(2,1)= ALU(36*ii-29)
      ALUtmp(2,2)= ALU(36*ii-28) * SIGMA_DIAG
      ALUtmp(2,3)= ALU(36*ii-27)
      ALUtmp(2,4)= ALU(36*ii-26)
      ALUtmp(2,5)= ALU(36*ii-25)
      ALUtmp(2,6)= ALU(36*ii-24)

      ALUtmp(3,1)= ALU(36*ii-23)
      ALUtmp(3,2)= ALU(36*ii-22)
      ALUtmp(3,3)= ALU(36*ii-21) * SIGMA_DIAG
      ALUtmp(3,4)= ALU(36*ii-20)
      ALUtmp(3,5)= ALU(36*ii-19)
      ALUtmp(3,6)= ALU(36*ii-18)

      ALUtmp(4,1)= ALU(36*ii-17)
      ALUtmp(4,2)= ALU(36*ii-16)
      ALUtmp(4,3)= ALU(36*ii-15)
      ALUtmp(4,4)= ALU(36*ii-14) * SIGMA_DIAG
      ALUtmp(4,5)= ALU(36*ii-13)
      ALUtmp(4,6)= ALU(36*ii-12)

      ALUtmp(5,1)= ALU(36*ii-11)
      ALUtmp(5,2)= ALU(36*ii-10)
      ALUtmp(5,3)= ALU(36*ii-9 )
      ALUtmp(5,4)= ALU(36*ii-8 )
      ALUtmp(5,5)= ALU(36*ii-7 ) * SIGMA_DIAG
      ALUtmp(5,6)= ALU(36*ii-6 )

      ALUtmp(6,1)= ALU(36*ii-5 )
      ALUtmp(6,2)= ALU(36*ii-4 )
      ALUtmp(6,3)= ALU(36*ii-3 )
      ALUtmp(6,4)= ALU(36*ii-2 )
      ALUtmp(6,5)= ALU(36*ii-1 )
      ALUtmp(6,6)= ALU(36*ii   ) * SIGMA_DIAG

      do k= 1, 6
        ALUtmp(k,k)= 1.d0/ALUtmp(k,k)
        do i= k+1, 6
          ALUtmp(i,k)= ALUtmp(i,k) * ALUtmp(k,k)
          do j= k+1, 6
            PW(j)= ALUtmp(i,j) - ALUtmp(i,k)*ALUtmp(k,j)
          enddo
          do j= k+1, 6
            ALUtmp(i,j)= PW(j)
          enddo
        enddo
      enddo

      ALU(36*ii-35)= ALUtmp(1,1)
      ALU(36*ii-34)= ALUtmp(1,2)
      ALU(36*ii-33)= ALUtmp(1,3)
      ALU(36*ii-32)= ALUtmp(1,4)
      ALU(36*ii-31)= ALUtmp(1,5)
      ALU(36*ii-30)= ALUtmp(1,6)
      ALU(36*ii-29)= ALUtmp(2,1)
      ALU(36*ii-28)= ALUtmp(2,2)
      ALU(36*ii-27)= ALUtmp(2,3)
      ALU(36*ii-26)= ALUtmp(2,4)
      ALU(36*ii-25)= ALUtmp(2,5)
      ALU(36*ii-24)= ALUtmp(2,6)
      ALU(36*ii-23)= ALUtmp(3,1)
      ALU(36*ii-22)= ALUtmp(3,2)
      ALU(36*ii-21)= ALUtmp(3,3)
      ALU(36*ii-20)= ALUtmp(3,4)
      ALU(36*ii-19)= ALUtmp(3,5)
      ALU(36*ii-18)= ALUtmp(3,6)
      ALU(36*ii-17)= ALUtmp(4,1)
      ALU(36*ii-16)= ALUtmp(4,2)
      ALU(36*ii-15)= ALUtmp(4,3)
      ALU(36*ii-14)= ALUtmp(4,4)
      ALU(36*ii-13)= ALUtmp(4,5)
      ALU(36*ii-12)= ALUtmp(4,6)
      ALU(36*ii-11)= ALUtmp(5,1)
      ALU(36*ii-10)= ALUtmp(5,2)
      ALU(36*ii-9 )= ALUtmp(5,3)
      ALU(36*ii-8 )= ALUtmp(5,4)
      ALU(36*ii-7 )= ALUtmp(5,5)
      ALU(36*ii-6 )= ALUtmp(5,6)
      ALU(36*ii-5 )= ALUtmp(6,1)
      ALU(36*ii-4 )= ALUtmp(6,2)
      ALU(36*ii-3 )= ALUtmp(6,3)
      ALU(36*ii-2 )= ALUtmp(6,4)
      ALU(36*ii-1 )= ALUtmp(6,5)
      ALU(36*ii   )= ALUtmp(6,6)
    enddo
  end subroutine hecmw_precond_DIAG_66_setup

  subroutine hecmw_precond_DIAG_66_apply(WW)
    implicit none
    real(kind=kreal), intent(inout) :: WW(:)
    integer(kind=kint) :: i
    real(kind=kreal) :: X1, X2, X3, X4, X5, X6

    !C
    !C== Block SCALING
    do i= 1, N
      X1= WW(6*i-5)
      X2= WW(6*i-4)
      X3= WW(6*i-3)
      X4= WW(6*i-2)
      X5= WW(6*i-1)
      X6= WW(6*i  )
      X2= X2 -ALU(36*i-29)*X1
      X3= X3 -ALU(36*i-23)*X1 -ALU(36*i-22)*X2
      X4= X4 -ALU(36*i-17)*X1 -ALU(36*i-16)*X2 -ALU(36*i-15)*X3
      X5= X5 -ALU(36*i-11)*X1 -ALU(36*i-10)*X2 -ALU(36*i-9 )*X3 -ALU(36*i-8)*X4
      X6= X6 -ALU(36*i-5 )*X1 -ALU(36*i-4 )*X2 -ALU(36*i-3 )*X3 -ALU(36*i-2)*X4 -ALU(36*i-1)*X5
      X6= ALU(36*i   )*  X6
      X5= ALU(36*i-7 )*( X5 -ALU(36*i-6 )*X6 )
      X4= ALU(36*i-14)*( X4 -ALU(36*i-12)*X6 -ALU(36*i-13)*X5)
      X3= ALU(36*i-21)*( X3 -ALU(36*i-18)*X6 -ALU(36*i-19)*X5 -ALU(36*i-20)*X4)
      X2= ALU(36*i-28)*( X2 -ALU(36*i-24)*X6 -ALU(36*i-25)*X5 -ALU(36*i-26)*X4 -ALU(36*i-27)*X3)
      X1= ALU(36*i-35)*( X1 -ALU(36*i-30)*X6 -ALU(36*i-31)*X5 -ALU(36*i-32)*X4 -ALU(36*i-33)*X3 -ALU(36*i-34)*X2)
      WW(6*i-5)= X1
      WW(6*i-4)= X2
      WW(6*i-3)= X3
      WW(6*i-2)= X4
      WW(6*i-1)= X5
      WW(6*i  )= X6
    enddo
  end subroutine hecmw_precond_DIAG_66_apply

  subroutine hecmw_precond_DIAG_66_clear()
    implicit none
    if (associated(ALU)) deallocate(ALU)
    nullify(ALU)
  end subroutine hecmw_precond_DIAG_66_clear

end module     hecmw_precond_DIAG_66


text:
*dk,getreg
      subroutine getreg(x,y,z,epsln,irtype,iregck,
     &                   iregno,isurfno,
     &                   ierr)
C
C#######################################################################
C
C     PURPOSE -
C
C
C     THIS ROUTINE RETURNS THE REGION NO. THAT THE POINT (x,y,z) LIES
C     IN.  IF IT DOES NOT LIE IN ANY REGION, iregno AND isurfno
C     ARE SET TO 0.  IF IT LIES ON A SURFACE, iregno IS SET TO 0 AND
C     isurfno IS SET TO THE SURFACE NUMBER  THE REGION NO. AND SURFACE
C     NO. ARE SET TO THE REGION NAME ORDER AND SURFACE NAME ORDER AS
C     STORED IN THE STORAGE BLOCK.
C
C
C     INPUT ARGUMENTS -
C
C        x - X COORDINATE OF THE POINT TO CHECK
C        y - Y COORDINATE OF THE POINT TO CHECK
C        z - Z COORDINATE OF THE POINT TO CHECK
C        epsln - EPSILON FOR SURFACE CHECKS
C        irtype - TYPE OF REGION TO CHECK (region or mregion)
C        iregck - PARTICULAR REGION TO CHECK AGAINST (0=ALL REGIONS)
C
C
C     OUTPUT ARGUMENTS -
C
C        iregno - REGION NO. THAT THE POINT LIES IN
C        isurfno - SURFACE NO. THAT THE POINT LIES ON
C        ierr - ERROR FLAG
C
C
C     CHANGE HISTORY -
C
C        $Log: getreg.f,v $
C        Revision 2.00  2007/11/05 19:45:57  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.3   Fri Apr 07 10:11:46 2000   dcg
CPVCS    replace use of KNWPN for length calculation with mmgetblk type 3
CPVCS    remove machine.h
CPVCS
CPVCS       Rev 1.2   Wed Feb 02 12:57:50 2000   dcg
CPVCS
CPVCS       Rev 1.1   13 Jan 2000 14:47:58   dcg
CPVCS
CPVCS       Rev 1.0   04 Jan 2000 16:47:38   dcg
CPVCS
CPVCS
CPVCS       Rev 1.7   Fri Jan 22 12:08:18 1999   dcg
CPVCS    remove duplicate and unused declarations
CPVCS
CPVCS       Rev 1.6   Mon Nov 24 16:33:36 1997   dcg
CPVCS    use geom.h and calls to get_regions, get_mregions, get_surfaces
CPVCS    to access geometry data - start to isolate integer*8 dependencies
CPVCS
CPVCS       Rev 1.5   Mon Apr 14 16:49:58 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.4   11/07/95 17:18:16   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.3   05/11/95 19:53:08   het
CPVCS    Comment out the termgen() call
CPVCS
CPVCS       Rev 1.2   05/01/95 08:34:30   het
CPVCS    Modifiy all the storage block calles for long names
CPVCS
CPVCS       Rev 1.1   01/09/95 17:32:26   het
CPVCS    Unicos changes.
CPVCS
CPVCS
CPVCS       Rev 1.0   11/10/94 12:14:30   pvcs
CPVCS    Original version.
C
C#######################################################################
C
      implicit none
C
      character*132 logmess
C
      include 'geom_lg.h'
C
C#######################################################################
C
      character*8 iregdup(50)
      logical surftst,stack(500),l1,l2,regck
      integer stkptr
C
      character*32 irtype, isubname, iword, iword1, iword2,
     *             cpolish, ick, cmo,geom_name
      pointer(ipout,out)
      real*8 out(*)
C
      pointer(ipiltgt, iltgt)
      pointer(ipsurfnm, isurfnm)
      pointer(ipnewdef, newdef)
      pointer(ippolish, polish)
      character*32 iltgt(10000000),isurfnm(10000000),
     *  newdef(10000000),polish(10000000)
      integer icharlnf
      integer ierr,length,icscode,irstrt,irend,iregck,iout,lout,itype,
     *   ir,ndef,nltgt,nstr,idefreg,len0, len1,len2,nxsurf,i,
     *   npol,ierrp,iopflg,ns,ii,iregno,isurfno,ierror,ioff,
     *   nregdup,is
      real*8 x,y,z,epsln,rout
C
C#######################################################################
C
      isubname='getreg'
      call cmo_get_name(cmo,ierror)
      call cmo_get_attinfo('geom_name',cmo,iout,rout,geom_name,
     *                        ipout,lout,itype,ierror)
C
C     ******************************************************************
C
C     INITIALIZE THE RETURN VARIABLES.
C
      iregno=0
      isurfno=0
      ierr=0
C
C     ******************************************************************
C
C     MAKE SURE WE HAVE REGIONS AND SURFACES.
C
      if ( (nregs.le.0.and.irtype(1:7).eq.'region') .or.
     *   (nmregs.le.0.and.irtype(1:7).eq.'mregion')
     *      .or. nsurf.le.0) then
         ierr=1
         go to 9999
      endif
      call mmfindbk('csall',geom_name,ipcsall,length,ierror)
      call mmfindbk('istype',geom_name,ipistype,length,ierror)
      call mmfindbk('ibtype',geom_name,ipibtype,length,ierror)
      call mmfindbk('sheetnm',geom_name,ipsheetnm,length,ierror)
      call mmfindbk('surfparam',geom_name,ipsurfparam,length,ierror)
      call mmfindbk('offsparam',geom_name,ipoffsparam,length,ierror)
      nregdup=0
C
C     ******************************************************************
C
C     SET POINTERS FOR SCRATCH ARRAYS TO ALLOCATED STORAGE.
C
      length=max(maxdef,maxmdef)
      call mmgetblk('iltgt',isubname,ipiltgt,length,3,icscode)
      call mmgetblk('surfnm',isubname,ipsurfnm,length,3,icscode)
      call mmgetblk('newdef',isubname,ipnewdef,length,3,icscode)
      call mmgetblk('polish',isubname,ippolish,length,3,icscode)
C
C     ******************************************************************
C
C     IF CHECKING AGAINST A PARTICULAR REGION, SET irstrt AND irend.
C
      irstrt=1
      irend=nregs
      if(irtype(1:7).eq.'mregion') irend=nmregs
      if (iregck .gt. 0) then
         irstrt=iregck
         irend=iregck
      endif
C
C     ******************************************************************
C
C     LOOP THROUGH REGION DEFINITIONS.
C
      do 50 ir=irstrt,irend
C
C        ---------------------------------------------------------------
C        SET THE REGION DEFINITION POINTER AND NO. ELEMENTS FROM iregs
C
         ioff=offregdef(ir)
         ndef=ndefregs(ir)
C
C        ---------------------------------------------------------------
C        LOOP THROUGH THE ELEMENTS OF THE REGION DEFINITION, SAVE
C        SURFACE OPERATOR(lt,gt), AND SURFACE NAME IN CORRESPONDING
C        ARRAYS.  BUILD A NEW DEFINITION LIST WITH THE ARRAY INDEX
C        AND LOGICAL OPERATORS(and,or,not).
C
         nxsurf=0
         nltgt=0
         nstr=0
         idefreg=1
         do 10 i=1,ndef
            iword=regdef(ioff+i)
            idefreg=idefreg+1
            len0=icharlnf(iword)
            if (iword(1:len0) .eq. 'lt' .or.
     &          iword(1:len0) .eq. 'gt' .or.
     &          iword(1:len0) .eq. 'le' .or.
     &          iword(1:len0) .eq. 'ge') then
               nxsurf=i+1
               nltgt=nltgt+1
               iltgt(nltgt)=iword
               nstr=nstr+1
               newdef(nstr)=' '
               write(newdef(nstr),'(i8)') nltgt
C
             else
               if (i .eq. nxsurf) then
                  isurfnm(nltgt)=iword
                else
                  nstr=nstr+1
                  newdef(nstr)=iword
               endif
C
            endif
C
   10    continue
C
C        ---------------------------------------------------------------
C        CALL eorpt TO GET A REVERSE POLISH STACK OF THE NEW DEFINITION
C        IN CORRECT PRIORITY ORDER
C
         call eorpt(newdef,nstr,polish,npol,ierrp)
C
C        ---------------------------------------------------------------
C        EVALUATE THE REVERSE POLISH STACK
C        LOOP THROUGH THE NO. OF TOKENS IN THE POLISH STACK
C
         stkptr=0
C
         do 20 i=1,npol
            iopflg=0
            cpolish=polish(i)
            len0=icharlnf(cpolish)

C
C           ............................................................
C           IF THE TOKEN IS THE and OPERATOR, PERFORM THE OPERATION
C           AND REPLACE THE RESULT IN THE EVALUATION STACK.
C
            if (cpolish(1:len0) .eq. 'and') then
               iopflg=1
               l1=stack(stkptr)
               l2=stack(stkptr-1)
               stkptr=stkptr-1
               stack(stkptr)=(l1 .and. l2)
            endif
C
C           ............................................................
C           IF THE TOKEN IS THE or OPERATOR, PERFORM THE OPERATION
C           AND REPLACE THE RESULT IN THE EVALUATION STACK.
C
            if (cpolish(1:len0) .eq. 'or') then
               iopflg=1
               l1=stack(stkptr)
               l2=stack(stkptr-1)
               stkptr=stkptr-1
               stack(stkptr)=(l1 .or. l2)
            endif
C
C           ............................................................
C           IF THE TOKEN IS THE not OPERATOR, PERFORM THE OPERATION
C           AND REPLACE THE RESULT IN THE EVALUATION STACK.
C
            if (cpolish(1:len0) .eq. 'not') then
               iopflg=1
               l1=stack(stkptr)
               stack(stkptr)=(.not. l1)
            endif
C
C           ............................................................
C           IF THE TOKEN IS THE LEFT OR RIGHT PARENTHESIS, SKIP IT.
C
            if (cpolish(1:len0) .eq. '(' .or. cpolish(1:len0) .eq. ')')
     &         iopflg=1
C
C           ............................................................
C           IF NOT AN OPERATOR, THEN IT MUST BE AN ARRAY ID, EVALUATE
C           AND ADD TO THE EVALUATION STACK.
C
            if (iopflg .eq. 0) then
               read(cpolish,'(i10)') ns
C
C              .........................................................
C              LOOP THROUGH isall TO FIND MATCHING SURFACE POINTERS.
C              THEN TEST WITH SURFTST.
C
               do 15 ii=1,nsurf
                  iword1=isurfnm(ns)
                  iword2=csall(ii)
                  len1=icharlnf(iword1)
                  len2=icharlnf(iword2)
                  len0=max(len1,len2)
                  if (iword1(1:len0) .eq. iword2(1:len0)) is=ii
   15          continue
               l1=surftst(x,y,z,epsln,cmo,istype(is),
     *            surfparam(offsparam(is)+1),sheetnm(is),iltgt(ns))
               stkptr=stkptr+1
               stack(stkptr)=l1
            endif
C
   20    continue
C
         regck=stack(stkptr)
C
C        ---------------------------------------------------------------
C        SEE IF THIS POINT EXISTS IN MULTIPLE REGIONS
C
         if (regck) then
            nregdup=nregdup+1
            if (nregdup .le. 50) iregdup(nregdup)=cregs(ir)
         endif
C
C        ---------------------------------------------------------------
C        SAVE REGION NUMBER.
C
         if (regck) iregno=ir
C
C        ---------------------------------------------------------------
C
   50 continue
C
C     ******************************************************************
C     CHECK FOR MULTIPLE REGIONS IN mregion TYPE.
C
      if (irtype .eq. 'mregion' .and. nregdup .gt. 1) then
         write(logmess,9000) nregdup,x,y,z
 9000    format('  ERROR, ',i3,' OVERLAPPING MREGIONS AT POINT (',
     &          e14.7,',',e14.7,',',e14.7,')')
         call writloga('default',1,logmess,0,ierr)
         write(logmess,9001)
 9001    format(5x,'THE OVERLAPPING REGIONS ARE:')
         call writloga('default',0,logmess,0,ierr)
         do 60 i=1,nregdup
            write(logmess,9002) iregdup(i)
 9002       format(10x,a8)
            call writloga('default',0,logmess,0,ierr)
   60    continue
C********call termgen(1)
      endif
C
C     ******************************************************************
C     IF A POINT IS NOT IN A REGION, SEE IF IT IS ON A SURFACE.
C
      if (iregno .eq. 0) then
C
C        ---------------------------------------------------------------
C        LOOP THROUGH THE SURFACES
C
         ick='eq      '
         do 100 is=1,nsurf
            if (surftst(x,y,z,epsln,cmo,istype(is),
     *        surfparam(offsparam(is)+1),sheetnm(is),ick)) isurfno=is
  100    continue
C
      endif
C
C
C     ******************************************************************
C
C     SET UP THE CFT IMMUNE STATEMENT FOR DDT
C
      goto 9999
 9999 continue
C
C     ******************************************************************
C
      call mmrelprt(isubname,icscode)
      return
      end

max_forks_repo_name: daniellivingston/LaGriT


text:
c
c Check the handling of error strings from Fortran
c

      program errstringsf

      include 'mpif.h'

      character*(MPI_MAX_ERROR_STRING) errs
      integer i, reslen, reserr, ierr

c
c     Fill the string with 'x' to check that
c     blank padding happens correctly.
c
      call MPI_Init( ierr )
      do i = 1,MPI_MAX_ERROR_STRING
         errs(i:i) = 'x'
      end do

      call mpi_error_string(mpi_err_buffer, errs, reslen, reserr)

      if (errs(reslen+1:) .ne. ' ') then
         print *,' Fortran strings are not correctly blank padded'
         if (errs(reslen+1:reslen+1) .eq. char(0)) then
c
c           Very strictly interpreted, an since an error string must be
c           MPI_MAX_ERROR_STRING characters long, and the Fortran rules
c           for such assignements is to blank pad them, there should not
c           be a null character (C-like) in them.  However, the standard
c           is ambiguous on this.
c
            print *, ' Fortran strings have bogus null character'
         end if
      else
         print *,' Fortran strings are assigned ok'
      end if

c     Check that the length was right
      if (errs(reslen:reslen) .eq. ' ') then
         print *,' Length of result is wrong'
      else
         print *,' Length of result is correct'
      end if

      call MPI_Finalize( ierr )

      end

max_stars_repo_name: scottkwarren/config-db

max_issues_repo_name: scottkwarren/config-db

max_forks_repo_name: scottkwarren/config-db


text:
      SUBROUTINE foutp(NT,NE,NAX,NDX,NTX,NEX,NF,NFX,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE OPENS AND LABELS OUTPUT FILES
C     FOR PLANT DATA
C
      include "parameters.h"
      include "filec.h"
      include "files.h"
      include "blkc.h"
      include "blk3.h"
      SAVE LUN
      CHARACTER*16 DATA(30),DATAC(30,250,250),DATAP(JP,JY,JX)
     2,DATAM(JP,JY,JX),DATAX(JP),DATAY(JP),DATAZ(JP,JY,JX)
     3,OUTS(10),OUTP(10),OUTFILS(10,JY,JX),OUTFILP(10,JP,JY,JX)
      CHARACTER*3 CHOICE(102,20)
      CHARACTER*8 CDATE
      CHARACTER*8 CDOY,DATE,HOUR
      CHARACTER*1 CHARM,CHARN,CHARZ,CHARO
      CHARACTER*2 CHARX,CHARY
      CHARACTER*4 CHARR
      CHARACTER*16 HEAD(50)
      CHARACTER*80 PREFIX
      CDOY='DOY     '
      DATE='DATE    '
      HOUR='HOUR    '
      CHARM='0'
      CHARO='1'
      DO 8995 NX=NHW,NHE
      DO 8995 NY=NVN,NVS
      DO 8995 NZ=1,NP0(NY,NX)
      DO 8995 N=1,10
      OUTFILP(N,NZ,NY,NX)= '                '
8995  CONTINUE
C
C     OPEN AND NAME OUTPUT FILES
C
      DO 1010 N=21,30
      IF(DATAC(N,NE,NEX).NE.'NO')THEN
      WRITE(CHARR,'(I4)')IYRC
      OUTP(N-20)=CHARO//CHARR//DATAC(N,NE,NEX)
      DO 9995 NX=NHW,NHE
      DO 9990 NY=NVN,NVS
      DO 9985 NZ=1,NP0(NY,NX)
      IF(NX.LT.10)THEN
      WRITE(CHARN,'(I1)')NX
      CHARX=CHARM//CHARN
      ELSE
      WRITE(CHARX,'(I2)')NX
      ENDIF
      IF(NY.LT.10)THEN
      WRITE(CHARN,'(I1)')NY
      CHARY=CHARM//CHARN
      ELSE
      WRITE(CHARY,'(I2)')NY
      ENDIF
      WRITE(CHARZ,'(I1)')NZ
      OUTFILP(N-20,NZ,NY,NX)=CHARX//CHARY//CHARZ//CHARR
     2//DATAC(N,NE,NEX)
9985  CONTINUE
9990  CONTINUE
9995  CONTINUE
      LUN=N+20
      OPEN(LUN,FILE=trim(outdir)//OUTP(N-20),STATUS='UNKNOWN')
C
C     WRITE HEADINGS TO OUTPUT FILES
C
      M=0
      IF(N.EQ.21)THEN
      DO 1021 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='CAN_CO2_FLUX'
      IF(L.EQ.52)HEAD(M)='CAN_GPP'
      IF(L.EQ.53)HEAD(M)='CAN_RA'
      IF(L.EQ.54)HEAD(M)='[TNC]'
      IF(L.EQ.55)HEAD(M)='STOML_RSC'
      IF(L.EQ.56)HEAD(M)='BLYR_RSC'
      IF(L.EQ.57)HEAD(M)='[CAN_CO2]'
      IF(L.EQ.58)HEAD(M)='LAI'
      ENDIF
1021  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.22)THEN
      DO 1022 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='PSI_CAN'
      IF(L.EQ.52)HEAD(M)='TURG_CAN'
      IF(L.EQ.53)HEAD(M)='STOM_RSC'
      IF(L.EQ.54)HEAD(M)='BLYR_RSC'
      IF(L.EQ.55)HEAD(M)='TRANSPN'
      IF(L.EQ.56)HEAD(M)='O2_STRESS'
      IF(L.EQ.57)HEAD(M)='PSI_RT_1'
      IF(L.EQ.58)HEAD(M)='PSI_RT_2'
      IF(L.EQ.59)HEAD(M)='PSI_RT_3'
      IF(L.EQ.60)HEAD(M)='PSI_RT_4'
      IF(L.EQ.61)HEAD(M)='PSI_RT_5'
      IF(L.EQ.62)HEAD(M)='PSI_RT_6'
      IF(L.EQ.63)HEAD(M)='PSI_RT_7'
      IF(L.EQ.64)HEAD(M)='PSI_RT_8'
      IF(L.EQ.65)HEAD(M)='PSI_RT_9'
      IF(L.EQ.66)HEAD(M)='PSI_RT_10'
      IF(L.EQ.67)HEAD(M)='PSI_RT_11'
      IF(L.EQ.68)HEAD(M)='PSI_RT_12'
      IF(L.EQ.69)HEAD(M)='PSI_RT_13'
      IF(L.EQ.70)HEAD(M)='PSI_RT_14'
      IF(L.EQ.71)HEAD(M)='PSI_RT_15'
      ENDIF
1022  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.23)THEN
      DO 1023 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='NH4_UPTK'
      IF(L.EQ.52)HEAD(M)='NO3_UPTK'
      IF(L.EQ.53)HEAD(M)='N2_FIXN'
      IF(L.EQ.54)HEAD(M)='[TNN]'
      IF(L.EQ.55)HEAD(M)='NH3_FLUX'
      IF(L.EQ.56)HEAD(M)='UP_NH4_1'
      IF(L.EQ.57)HEAD(M)='UP_NH4_2'
      IF(L.EQ.58)HEAD(M)='UP_NH4_3'
      IF(L.EQ.59)HEAD(M)='UP_NH4_4'
      IF(L.EQ.60)HEAD(M)='UP_NH4_5'
      IF(L.EQ.61)HEAD(M)='UP_NH4_6'
      IF(L.EQ.62)HEAD(M)='UP_NH4_7'
      IF(L.EQ.63)HEAD(M)='UP_NH4_8'
      IF(L.EQ.64)HEAD(M)='UP_NH4_9'
      IF(L.EQ.65)HEAD(M)='UP_NH4_10'
      IF(L.EQ.66)HEAD(M)='UP_NH4_11'
      IF(L.EQ.67)HEAD(M)='UP_NH4_12'
      IF(L.EQ.68)HEAD(M)='UP_NH4_13'
      IF(L.EQ.69)HEAD(M)='UP_NH4_14'
      IF(L.EQ.70)HEAD(M)='UP_NH4_15'
      IF(L.EQ.71)HEAD(M)='UP_NO3_1'
      IF(L.EQ.72)HEAD(M)='UP_NO3_2'
      IF(L.EQ.73)HEAD(M)='UP_NO3_3'
      IF(L.EQ.74)HEAD(M)='UP_NO3_4'
      IF(L.EQ.75)HEAD(M)='UP_NO3_5'
      IF(L.EQ.76)HEAD(M)='UP_NO3_6'
      IF(L.EQ.77)HEAD(M)='UP_NO3_7'
      IF(L.EQ.78)HEAD(M)='UP_NO3_8'
      IF(L.EQ.79)HEAD(M)='UP_NO3_9'
      IF(L.EQ.80)HEAD(M)='UP_NO3_10'
      IF(L.EQ.81)HEAD(M)='UP_NO3_11'
      IF(L.EQ.82)HEAD(M)='UP_NO3_12'
      IF(L.EQ.83)HEAD(M)='UP_NO3_13'
      IF(L.EQ.84)HEAD(M)='UP_NO3_14'
      IF(L.EQ.85)HEAD(M)='UP_NO3_15'
      ENDIF
1023  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.24)THEN
      DO 1024 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='PO4_UPTK'
      IF(L.EQ.52)HEAD(M)='[TNP]'
      IF(L.EQ.53)HEAD(M)='UP_PO4_1'
      IF(L.EQ.54)HEAD(M)='UP_PO4_2'
      IF(L.EQ.55)HEAD(M)='UP_PO4_3'
      IF(L.EQ.56)HEAD(M)='UP_PO4_4'
      IF(L.EQ.57)HEAD(M)='UP_PO4_5'
      IF(L.EQ.58)HEAD(M)='UP_PO4_6'
      IF(L.EQ.59)HEAD(M)='UP_PO4_7'
      IF(L.EQ.60)HEAD(M)='UP_PO4_8'
      IF(L.EQ.61)HEAD(M)='UP_PO4_9'
      IF(L.EQ.62)HEAD(M)='UP_PO4_10'
      IF(L.EQ.63)HEAD(M)='UP_PO4_11'
      IF(L.EQ.64)HEAD(M)='UP_PO4_12'
      IF(L.EQ.65)HEAD(M)='UP_PO4_13'
      IF(L.EQ.66)HEAD(M)='UP_PO4_14'
      IF(L.EQ.67)HEAD(M)='UP_PO4_15'
      ENDIF
1024  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.25)THEN
      DO 1025 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='CAN_RN'
      IF(L.EQ.52)HEAD(M)='CAN_LE'
      IF(L.EQ.53)HEAD(M)='CAN_H'
      IF(L.EQ.54)HEAD(M)='CAN_G'
      IF(L.EQ.55)HEAD(M)='CAN_TEMP'
      IF(L.EQ.56)HEAD(M)='TEMP_FN'
      ENDIF
1025  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.26)THEN
      DO 1026 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='SHOOT_C'
      IF(L.EQ.52)HEAD(M)='LEAF_C'
      IF(L.EQ.53)HEAD(M)='SHTH_C'
      IF(L.EQ.54)HEAD(M)='STALK_C'
      IF(L.EQ.55)HEAD(M)='RESERVE_C'
      IF(L.EQ.56)HEAD(M)='REPRO_C'
      IF(L.EQ.57)HEAD(M)='GRAIN_C'
      IF(L.EQ.58)HEAD(M)='ROOT_C'
      IF(L.EQ.59)HEAD(M)='NDL_C'
      IF(L.EQ.60)HEAD(M)='STORED_C'
      IF(L.EQ.61)HEAD(M)='GRAIN_NO.'
      IF(L.EQ.62)HEAD(M)='LAI'
      IF(L.EQ.63)HEAD(M)='GPP'
      IF(L.EQ.64)HEAD(M)='EXUD_C'
      IF(L.EQ.65)HEAD(M)='LITTER_C'
      IF(L.EQ.66)HEAD(M)='SF_LIT_C'
      IF(L.EQ.67)HEAD(M)='AUTO_RESP'
      IF(L.EQ.68)HEAD(M)='ABV_GRD_RESP'
      IF(L.EQ.69)HEAD(M)='[SOL._C]'
      IF(L.EQ.70)HEAD(M)='HVST_C'
      IF(L.EQ.71)HEAD(M)='DNS_RT_1'
      IF(L.EQ.72)HEAD(M)='DNS_RT_2'
      IF(L.EQ.73)HEAD(M)='DNS_RT_3'
      IF(L.EQ.74)HEAD(M)='DNS_RT_4'
      IF(L.EQ.75)HEAD(M)='DNS_RT_5'
      IF(L.EQ.76)HEAD(M)='DNS_RT_6'
      IF(L.EQ.77)HEAD(M)='DNS_RT_7'
      IF(L.EQ.78)HEAD(M)='DNS_RT_8'
      IF(L.EQ.79)HEAD(M)='DNS_RT_9'
      IF(L.EQ.80)HEAD(M)='DNS_RT_10'
      IF(L.EQ.81)HEAD(M)='DNS_RT_11'
      IF(L.EQ.82)HEAD(M)='DNS_RT_12'
      IF(L.EQ.83)HEAD(M)='DNS_RT_13'
      IF(L.EQ.84)HEAD(M)='DNS_RT_14'
      IF(L.EQ.85)HEAD(M)='DNS_RT_15'
      IF(L.EQ.86)HEAD(M)='C_BALANCE'
      IF(L.EQ.87)HEAD(M)='STG_DEAD_C'
      IF(L.EQ.88)HEAD(M)='FIRE_CO2'
      IF(L.EQ.89)HEAD(M)='FIRE_CH4'
      IF(L.EQ.90)HEAD(M)='NPP'
      IF(L.EQ.91)HEAD(M)='CAN_HT'
      IF(L.EQ.92)HEAD(M)='POPN'
      ENDIF
1026  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.27)THEN
      DO 1027 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='TRANSPN'
      IF(L.EQ.52)HEAD(M)='WTR_STRESS'
      IF(L.EQ.53)HEAD(M)='OXY_STRESS'
      ENDIF
1027  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.28)THEN
      DO 1028 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='SHOOT_N'
      IF(L.EQ.52)HEAD(M)='LEAF_N'
      IF(L.EQ.53)HEAD(M)='SHTH_N'
      IF(L.EQ.54)HEAD(M)='STALK_N'
      IF(L.EQ.55)HEAD(M)='RESERVE_N'
      IF(L.EQ.56)HEAD(M)='HUSK_N'
      IF(L.EQ.57)HEAD(M)='GRAIN_N'
      IF(L.EQ.58)HEAD(M)='ROOT_N'
      IF(L.EQ.59)HEAD(M)='NDL_N'
      IF(L.EQ.60)HEAD(M)='STORED_N'
      IF(L.EQ.61)HEAD(M)='UPTK_N'
      IF(L.EQ.62)HEAD(M)='LITTER_N'
      IF(L.EQ.63)HEAD(M)='TL_N_FIXED'
      IF(L.EQ.64)HEAD(M)='[SOL_N]'
      IF(L.EQ.65)HEAD(M)='N_STRESS'
      IF(L.EQ.66)HEAD(M)='[SOL_P]'
      IF(L.EQ.67)HEAD(M)='P_STRESS'
      IF(L.EQ.68)HEAD(M)='NH3_FLUX'
      IF(L.EQ.69)HEAD(M)='HVST_N'
      IF(L.EQ.70)HEAD(M)='N_BALANCE'
      IF(L.EQ.71)HEAD(M)='STG_DEAD_N'
      IF(L.EQ.72)HEAD(M)='FIRE_N'
      IF(L.EQ.73)HEAD(M)='SF_LIT_N'
      ENDIF
1028  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.29)THEN
      DO 1029 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='SHOOT_P'
      IF(L.EQ.52)HEAD(M)='LEAF_P'
      IF(L.EQ.53)HEAD(M)='SHTH_P'
      IF(L.EQ.54)HEAD(M)='STALK_P'
      IF(L.EQ.55)HEAD(M)='RESERVE_P'
      IF(L.EQ.56)HEAD(M)='HUSK_P'
      IF(L.EQ.57)HEAD(M)='GRAIN_P'
      IF(L.EQ.58)HEAD(M)='ROOT_P'
      IF(L.EQ.59)HEAD(M)='NDL_P'
      IF(L.EQ.60)HEAD(M)='STORED_P'
      IF(L.EQ.61)HEAD(M)='UPTK_P'
      IF(L.EQ.62)HEAD(M)='LITTER_P'
      IF(L.EQ.63)HEAD(M)='[SOL_P]'
      IF(L.EQ.64)HEAD(M)='P_STRESS'
      IF(L.EQ.65)HEAD(M)='HVST_P'
      IF(L.EQ.66)HEAD(M)='P_BALANCE'
      IF(L.EQ.67)HEAD(M)='STG_DEAD_P'
      IF(L.EQ.68)HEAD(M)='FIRE_P'
      IF(L.EQ.69)HEAD(M)='SF_LIT_P'
      ENDIF
1029  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.EQ.30)THEN
      DO 1030 L=51,100
      IF(CHOICE(L,N-20).EQ.'YES')THEN
      M=M+1
      IF(L.EQ.51)HEAD(M)='GROWTH_STG'
      IF(L.EQ.52)HEAD(M)='BRANCH_NO.'
      IF(L.EQ.53)HEAD(M)='NODE_NO.'
      IF(L.EQ.54)HEAD(M)='RUB_ACTVN'
      IF(L.EQ.55)HEAD(M)='LEAF_N/C'
      IF(L.EQ.56)HEAD(M)='LEAF_P/C'
      IF(L.EQ.57)HEAD(M)='MIN_LWP'
      IF(L.EQ.58)HEAD(M)='O2_STRESS'
      IF(L.EQ.59)HEAD(M)='TEMP_STRESS'
      ENDIF
1030  CONTINUE
      NOUTP(N-20)=M
      ENDIF
      IF(N.LE.25)WRITE(LUN,'(A12,2A8,50A16)')CDOY,DATE,HOUR
     2,(HEAD(K),K=1,M)
      IF(N.GE.26)WRITE(LUN,'(A12,A8,50A16)')CDOY,DATE
     2,(HEAD(K),K=1,M)
      ENDIF
1010  CONTINUE
      RETURN
      END

max_stars_repo_name: ThemosTsikas/ECOSYS

max_issues_repo_name: ThemosTsikas/ECOSYS

max_forks_repo_name: ThemosTsikas/ECOSYS


text:
We currently have just one server  a 1U rackmount machine with a 2.0GHz Athlon64 dual core processor (x2 3200+), 4GB of ECC memory and 200GB of RAID1 storage. The server is based on a Tyan Transport barebone package and runs Gentoo Linux.

We are hosted in Cernio Technology Cooperative Cernios cabinet at United Layers facility in the 200 Paul data center in San Francisco.  We recently moved the server from Cernios halfcab at Sonic.nets facility in Santa Rosa to take advantage of better pricing, connectivity, and logistics.

Our colocation expenses are approximately USD$70/mo.

There are several other Wikis hosted on the system, including http://scwiki.org/ Santa Cruz Wiki, http://anthill.org/ The Ant Hill Housing Cooperative, and http://projectsycamore.org/ Project Sycamore, but DavisWiki is by far the largest.

Below is the discussion that took place when we were debating whether and how to purchase and colocate our own server equipment.

 Buying a server

 Colocation

 Background and Definitions

In this context, colocation (see wiki:WikiPedia:Colocation ), or colo for short, means renting physical space, an Internet connection, electrical power, and physical security in a central facility whose amenities and capabilities far surpass anything an individual or small company could build on their own.

Rack space is measured in Rack Units (abbreviated U) equaling 1.75 inches in height. Width is 19 inches. see http://www.sizes.com/units/rack_unit.htm

Power consumption is usually derived from current, measured in amps, as measured at any given point of time, rather than Kilowatthours used over the course of a month as youd see on a utility bill.  Its assumed that all equipment in a colo facility is always on  fluctuations are usually relatively minor and vary with disk and CPU use.

Network use is usually billed perGBtransferredpermonth on lowerend contracts, and using the 95th percentile measurement on higherend contracts.  With the 95th percentile measurement, transfer rates are measured every 5 minutes over the course of a month.  The highest 5% of the usage is ignored, and the bill is based on the average usage for the remaining 95% of the time.

 Available to DavisWiki.org

Users/GrahamFreeman Graham Freeman of Cernio Cernio has a halfcabinet (21U) at the enterpriseclass http://sonic.net/sales/colo/ Sonic.net datacenter in Santa Rosa.  Cernio has offered to make up to 4U of space, 2 Amps (ongoing, spotchecked every once in a while), 2 public static IP addresses, 512Kbps@95%, and physical access available to the DavisWiki.org project on a cooperative basis.  This means that DavisWiki would pay for what it uses based on the actual cost of these resources  Cernio will not attempt to make money off of the deal.  Cernio would benefit by having increased purchasing power and by working closely with goodnatured, communityminded, competent, and technically skilled people.

Users/LukeCrawford of http://prgmr.com/  has a full rack (2 post) in the community cage at herakles data (Its down by Frys)  and a 100 megabit commit.   You are welcome to drop a 1u server in, or if you dont mind NetBSD, I can give you a NetBSD/xen server with 2G ram and a 10G  slice of my raid 1+0 fibre channel disk without charging you.   You are welcome to use this setup for a primary or a backup.    Serial consoles and remote rebooters will be provided either way.

 Notes on colocation

Space:  Rackmounted hardware only.  (No desktops, nor towers.)  Rack rails arent necessary, but they help.  A cable management arm may not fit if its on a long server.

Power:  2A is mostly a guideline to make sure we dont get carried away with unnecessarily power consumptive equipment.  More is available, but probably wont be necessary.

IP addresses: Well probably only need one public static IP address, but more are available if theyre used wisely.

Bandwidth consumption:  512Kbps@95% means that most of the time (24h/7d), the site is transferring data to/from clients at a cumulative rate of 512Kbps.  DavisWiki and RocWiki combined are not likely to use even half that any time soon.  Even so, bandwidth consumption (and its associated cost) is the most significant variable.

Physical access:  Granting physical access to Cernios cabinet space means granting physical access to Cernios equipment as well as to the DavisWiki equipment.  It requires an wiki:WikiPedia:Rfid RFIDembedded picture ID, wiki:WikiPedia:Biometric biometric (hand print, body shape, total weight) verification, and a key.  Physical access will not be granted casually.  Users/PhilipNeustrom Philip Neustrom and Users/AmitVainsencher Amit Vainsencher have passed the initial screening.

 Commentary/discussion on colocation
I dont think 2 Amps is enough to run a server. 2amps x 125volts  250 watts.  Users/ArlenAbraham arlen
   Im surprised that would even be mentioned but, assuming that is typical and not peak, that should be fine. Even though power supplies are rated 300450 watts (or more) for desktops, 1Us often have 250 watt ratings. The actual draw is considerably less, even for desktops. BTW, an amp is a unit of current, a watt is a unit of power, and a kilowatthour is a unit of energy. Oh, and North American line voltage is standardized at 120VAC. Users/SteveDavison
    It depends mostly on how many hard drives you have, how fast they spin, and how busy they are.  Some CPUs are very powerconsumptive as well.  I only use 3A right now for three servers, two switches, a firewall, and a PDU.  Besides, if 2A isnt enough, more is available  I just want to make sure its used wisely so that we dont deploy a power hog when its not necessary to do so. Users/GrahamFreeman

Why in the world is colocation even being talked about? How big IS this site?! Users/DomenicSantangelo
  We are running off of a dedicated machine right now, and its in a data center.  It would be no different, except that we would own the server and have physical access to it (and be able to upgrade it). We were in a shared hosting environment a year ago but ate up too much RAM and CPU for that to work (and we also need root to install software, etc).  Were not talking about owning a rack  just putting a single machine in someone elses space and paying for the space/bandwidth.  It would actually be cheaper than the $100/month we pay now, in all likelihood.  If youre wondering about traffic figures, I can provide those (last I checked it was ~6000 unique hits/day, ~2GB/day transfer) but keep in mind that serving up dynamic content is much harder than static content.

  Colocation is not that big of a deal, really.

     Yeah, I mean, I work for a webhosting firm so I have an idea of whats involved... I just didnt realize the wiki was so large in size. 2GB/transfer isnt that big, but the RAM and CPU figures would be interesting to see. Users/DomenicSantangelo

  I think the main thing is to plan ahead on all fronts, which we started doing from the beginning, and which Philip continues especially on the programming side, so this seems like a very opportune time to upgrade our hosting.  Plus it would just feel better to have the server in Santa Rosa rather than in New York or wherever it is now. Users/MikeIvanov
     Well, making decisions based on feeling definately seems like the logical thing to do. Joking aside, why not host somewhere in Davis? If youre going to colocate, ISPs usually offer that, too (my webhosting firms server farm is in San Diego, else Id be plugging them)... Itd be kind of cool to make it a fully Davis operation, wouldnt it? Plus, no driving to Santa Rosa if things go south! Users/DomenicSantangelo
      By feeling I really meant ownership and peace of mind rather than warm and fuzzy.  I guess those can be pretty close, though.  But my understanding is the hosts in town dont offer a reasonable solution for us.  It would be great to be hosted in Davis, just doesnt seem to be in the cards for now.  The Santa Rosa offer is to share a cabinet with a company already paying for the whole thing, which really reduces the cost of our share. Users/MikeIvanov
        Omsoft is the only place you can throw a server in Davis, and they are somewhat pricey.  Sacramento colo seems to be on the shady end of things, too.  I wish we could be in Davis, too, but Santa Rosa beats New York.

 Initial Recommendations for a System
 Case/PSU/Motherboard
  http://www.tyan.com/products/html/gt20b2865_spec.html Tyan Transport GT20 B2865 (1U)  Estimated cost: $650   Users/AmitVainsencher AV
   Right now, we dont need a ton of processor power, but the option to add more would be nice. I think a dual processor Xeon or Opteron motherboard like http://www.newegg.com/Product/Product.asp?ItemN82E16813131560 this one ($300) with a single CPU (for now) would be a good bet. Also, $650 is a bit steep.  Users/ArlenAbraham arlen
   Doesnt seem that steep to me since the $650 gets you a PSU, case, and motherboard. Further, the case can hold up to 4 SATA drives, which would allow us the possibility of a RAID5 setup.  Users/AmitVainsencher AV
   Another note: the motherboard used in this package is basically the same as what Sun uses for their AMD64 workstations and lowend servers. Industry backing is a plus, and Tyan is historically a rather good server solutions manufacturer.  Users/AmitVainsencher AV
   Seconded.  Most of my to order servers are Tyan.  Excellent motherboards.  Users/JabberWokky jw

 Processor
  Athlon64 dual core 3800  Estimated cost: $300  Users/AmitVainsencher AV
   I think this is more expensive than its worth. Wed probably be better off with Xeons or Opterons.  Users/ArlenAbraham arlen
   Opterons are significantly more expensive than Athlon64s. Beyond that, I guess choosing between AMD and Intel is a preference thing. Personally, I like AMD more since Ive had good experiences with their processors. Also this processor gives us two cores, saving money that might go to a dual CPU motherboard.  Users/AmitVainsencher AV

 Memory
  Two 1GB PC3200 ECC DIMMs  Estimated cost: $250  Users/AmitVainsencher AV
   This particular server needs a lot of memory, probably 4 gigs. If we get a  motherboard with four slots and want to upgrade ram, youre going to need 2x2gb sticks, which are expensive.  Users/ArlenAbraham  Arlen
   If you see the motherboard spec, it maxes out at 4GB.

 Storage
  Two 74GB Western Digital Raptor hard drives (10K RPM, Serial ATA)  Estimated cost: $300 (These would be configured in a RAID1 for data redundancy)  Users/AmitVainsencher AV
   Raptors are nice, but expensive for the amount of storage they provide. On the plus side, they have five year warranties. Also, if youre limited by the number of drive bays (most 1U cases have three bays), you max out quickly. SATA is definitely the way to go (faster than IDE, cheaper than SCSI). Rather than raptors, I think that we should get a few intermediately sized drives, like 250GB, and put them in RAID 5. A hot spare would be nice, but no one is going to lose money if the wiki goes down for a few hours while we rebuild the RAID.  Users/ArlenAbraham arlen
   We are currently using a total of 13GB on our machine, including the OS, etc.  74GB would certainly be enough space, but it might get in the way of: 1) Allowing for new things that would potentially take up more space, such as uploads of any size 2) Hosting more local wikis on our machine to bring our bottom line down.  Also, we would almost certainly eventually fill up the 74GB, but it would take a while if all factors were kept the same as they are now.
   Personally, I dont trust the larger consumer grade drives with high activity and  the burden of being constantly on. In my experience, such drives dont last very long in server situations. However, we definitely need to find a middle ground between price, size, and reliability... when I made my initial post I was under the impression that the server would never need more than 74GB.   Users/AmitVainsencher AV

 Case
  Needs 1U or 2U. Redundant power supplies would be an additional ~$200. Any suggestions?

 RAID Controller
  If we want to do anything fancy like RAID 5 or matrix RAID, well need a SATA RAID controller. I dont know much about these.  Users/ArlenAbraham arlen

Price estimates were found through http://www.pricewatch.com/ Pricewatch. This configuration would cost roughly $1600. Users/AmitVainsencher AV

Are you considering purchasing a built server?  It may be cheaper and will save the trouble of configuring the hardware.  The hard part, of course, is finding something that fits what we need, but it shouldnt be all that hard.  For example, http://www.visionman.com/RackmountServer/VCPRE1USUP.htm this setup is pretty close, but I dont know anything about this company.  In a couple of weeks I should be able to help out with some funds.  Should we set a deadline for a week before New Years or so to have a built server? Users/MikeIvanov

Id strongly recommend buying a preconfigured server rather than building your own.  If you throw in all the extra shipping charges and, most of all, time spent hunting down the best prices and dealing with inevitable vendor SNAFUs, youre going to spend a lot more resources building your own than you would buying something from a server vendor.  PN mentioned that http://www.siliconmechanics.com/ is strongly recommended by the LiveJournal folks, and Ive been reasonably happy with Dell.  Users/GrahamFreeman

I wouldnt have a problem doing the hunting, configuring, assembling. Also at least with the inital setup I suggested, everything comes from one vendor except for standard parts such as the CPU, RAM, and hard drives.  Users/AmitVainsencher AV
  This is an offer we cannot afford to pass up no matter which route we decide to go.  I have every confidence in Amits skills, even from one brief interaction with him online. Users/MikeIvanov

 Purchased items and status
The following items were purchased on 20051226: (4) STT D400 1G/64X8 ECC Memory, (1)Tyan Transport GT20 B2865G20S4H SATA 1U Server Platform, (1) Chenbro 24 Mounting Rail Set for RM124, (2) Maxtor 7Y250M0 250GB Serial ATA 7200rpm 8MB cache Hard Drive, (1) AMD Athlon 64 X2 DualCore Processor 3800+ (2.0GHz) Retail.

After a courageous fight against hardware demons, Amit found the hardware defective.  On 20050215 the barebones components were shipped back to the manufacturer for replacement/fixing.  After a motherboard replacement, the problem is still appearing.  A hard drive was purchased to test possible issues with Maxor drives, but it turned out that there were no issues with the hard drive.  2 DIMMs (certified) were ordered on 200639 and solve the problem, and more ordered on 2006328 after we figured out they actually work.

The old memory needs to be sold to recover costs.  As such, were selling (4) http://www.supertalent.com/SuperTalentMemory/products/product_detail.php?PND32EB1GW STT D400 1G 64X8 ECC DIMMs (memory). They work fine, just not with nforce4 chipsets which is why we have to sell them. $70 a piece or better offer. Weve managed to sell two of these sticks, but two more are still up for grabs. Theyve been verified working on various P4 motherboards (by the manufacturer), on an Athlon64 Socket 754 (with a VIA chipset), and a Dual Athlon MP system (both by us).

The new system was installed in Cernios cabinet at Sonic.net on the evening of April 5th (picture below!). Its been completely stable since the installation of the new memory, and were in the process of moving data over to it for the site transition. Thanks for all the help, Graham!

 Raising funds
Okay, so buying a server is obviously going to cost some dough.  How are we going to get said moolah?

A: Donate DONATE!!!

  I can afford to throw in about $400 out of pocket, currently.  I may likely be able to contribute more after Christmas due to gifts as well as a job (but Im not positive I will be getting said job). Users/PhilipNeustrom
  I could put down about $150  Users/AmitVainsencher AV
  My contribution is really kind of a wild card, but unless things go terribly wrong in the next two weeks, I can definitely match Philips ($400 at least).  I really think we should set some target sums/dates. Users/MikeIvanov
  wiki:RocWiki:Front_Page RocWiki: Robert Polyn donated $100, Rudy Bang donated $100

How about, as suggested, we go with Dec. 27th as the deadline to have the stuff purchased  thus giving us time over Winter Break to get configuration done.  We will have $~1050 in personal contributions, but having more than that would give us much more leverage.  We should set a deadline for collecting funds for Dec. 19th, giving about a week for the parts to ship.  Any ideas for fundraising? Users/PhilipNeustrom

  Just to be clear, are there additional costs involved in maintaining the wiki till 07, or is this it? I recommend teaming up with MSN and having lots of pop up ads. Just kidding. I recommend having some kind of a please donate for the holidays kind of message on the front page. I think a lot of people would be willing to donate over the next year, and a little goading to have them do it now instead wouldnt hurt. Alternatively, we can contact one of those shirt making places, and sell Wiki Shirts at 100% markup. Users/CraigBrozinsky

    We will still have to pay for the hosting costs, as we do now.  This is an extra cost because we need to purchase hardware, which is unfortunate, but it happens.  I am thinking of getting a bunch of shirts made and selling them for donations, but Im not sure I will have time to do this (if anyone else does, do it!).  Last year we raised a total of $1000  which entirely offset the hosting costs.  Im confident we can keep doing that.  Users/PhilipNeustrom

     The sale of Wiki Shirts is underway.  Users/GrahamFreeman

     Emailed Samplistic Records Samplistic Records about a proposal to sell Samplistic CDs on behalf of DavisWiki  initial response is favourable, but this isnt yet working out as well as the Wiki Shirts.  Users/GrahamFreeman

 Awesome photos of the machine in the data center

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module advance_module

  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bc_module
  use multifab_physbc_module
  use multifab_fill_ghost_module
  use ml_cc_restriction_module
  use bndry_reg_module
  use compute_flux_module
  use update_phi_module

  implicit none

  private

  public :: advance

contains

  subroutine advance(mla,phi_old,phi_new,bndry_flx,dx,dt,the_bc_tower,do_subcycling,num_substeps)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi_old(:)
    type(multifab) , intent(inout) :: phi_new(:)
    type(bndry_reg), intent(inout) :: bndry_flx(2:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower
    logical        , intent(in   ) :: do_subcycling
    integer        , intent(in   ) :: num_substeps

    ! local variables
    integer   :: i,istep,dm,n,nlevs,ng_p
    ! Array of edge-based multifabs; one for each direction
    type(multifab) :: flux(mla%dim,mla%nlevel)

    dm    = mla%dim
    nlevs = mla%nlevel
    ng_p = phi_new(1)%ng

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Explicit time advancement
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if (do_subcycling) then

          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
          ! subcycling in time
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

          n = 1
          istep = 1
          ! note that update_level is recursive
          call update_level(n,mla,phi_old,phi_new,bndry_flx,&
               dx,dt,the_bc_tower,istep,num_substeps)

    else

          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
          ! no subcycling in time
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

          ! flux(i,n) has one component, zero ghost cells, and is nodal in direction i,
          !    i.e. it lives on the i-edges.
          do n = 1,nlevs
             do i = 1, dm
                call multifab_build_edge(flux(i,n),mla%la(n),1,0,i)
             end do
          end do

          ! Copy phi_new from the previous time step into phi_old for this time step
          do n = 1, nlevs
             call multifab_copy(mdst=phi_old(n),msrc=phi_new(n),ng=ng_p)
          end do

          ! Compute the face-centered gradients in each direction
          call compute_flux(mla,phi_old,flux,dx,dt,the_bc_tower)

          ! update phi using forward Euler discretization
          call update_phi(mla,phi_old,phi_new,flux,dx,dt,the_bc_tower)

          do n = 1,nlevs
             do i = 1, dm
                call multifab_destroy(flux(i,n))
             end do
          end do

    end if

  end subroutine advance

  recursive subroutine update_level(n,mla,phi_old,phi_new,bndry_flx,&
                                    dx,dt,the_bc_tower,step,num_substeps)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi_old(:)
    type(multifab) , intent(inout) :: phi_new(:)
    type(bndry_reg), intent(inout) :: bndry_flx(2:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower
    integer        , intent(in   ) :: n,step
    integer        , intent(in   ) :: num_substeps

    real(kind=dp_t) :: alpha, scale
    integer         :: istep, i, dm, ng_p
    ! Array of edge-based multifabs; one for each direction
    type(multifab) :: flux(mla%dim)

    dm = mla%dim
    ng_p = phi_new(n)%ng

    ! We only want one processor to write to screen
    if ( parallel_IOProcessor() ) &
       print*,'   Advancing level: ',n,' with dt = ',dt(n)

    ! Copy phi_new from the previous time step into phi_old for this time step
    call multifab_copy(mdst=phi_old(n),msrc=phi_new(n),ng=ng_p)

    if (n .eq. 1) then

        ! Fill ghost cells for two adjacent grids at the same level
        ! this includes periodic domain boundary ghost cells
        call multifab_fill_boundary(phi_old(n))

        ! Fill non-periodic domain boundary ghost cells
        call multifab_physbc(phi_old(n),1,1,1,the_bc_tower%bc_tower_array(n))

     else if (step .eq. 1) then
        ! First update boundary conditions
        ! Fill level n ghost cells using interpolation from level n-1 data
        ! Note that multifab_fill_boundary and multifab_physbc are called for
        ! both levels n-1 and n
        ! The coarsest level
        call multifab_fill_ghost_cells(phi_old(n),phi_old(n-1),ng_p,&
                                       mla%mba%rr(n-1,:), &
                                       the_bc_tower%bc_tower_array(n-1), &
                                       the_bc_tower%bc_tower_array(n), &
                                       1,1,1)
    else
        !
        ! This version of multifab_fill_ghost_cells takes both a crse_old and a crse_new
        !     and does interpolation in time as well as in space.  The coefficient alpha
        !     is used to define:   fine = interp (alpha*crse_old + (1-alpha)*crse_new )
        !
        ! If num_substeps = 2, then at step = 1, alpha = 1.0
        !                           at step = 2, alpha = 0.5
        ! If num_substeps = 4, then at step = 1, alpha = 1.0
        !                           at step = 2, alpha = 0.75
        !                           at step = 3, alpha = 0.5
        !                           at step = 4, alpha = 0.25
        !
        alpha = 1.d0 - dble(step-1)/dble(num_substeps)
        call multifab_fill_ghost_cells_t(phi_old(n),phi_old(n-1),phi_new(n-1),alpha,&
                                         ng_p,mla%mba%rr(n-1,:), &
                                         the_bc_tower%bc_tower_array(n-1), &
                                         the_bc_tower%bc_tower_array(n), &
                                         1,1,1)
    end if

    do i = 1, dm
       call multifab_build_edge(flux(i),mla%la(n),1,0,i)
    end do

    ! Compute fluxes at level n.
    call compute_flux_single_level(mla,phi_old(n),flux,dx(n),dt(n),the_bc_tower%bc_tower_array(n))

    ! Update solution at level n.
    call update_phi_single_level(mla,phi_old(n),phi_new(n),flux,dx(n),dt(n))

    if (n .gt. 1) then
       ! Copy fine fluxes from cell boundaries into boundary registers for use in refluxing.
       scale = dt(n)*dx(n)**(dm-1) ! dt*area
       call flux_reg_fine_add(bndry_flx(n),flux,scale)
    end if

    if (n .eq. mla%nlevel) then ! finest level

       do i = 1, dm
          call multifab_destroy(flux(i))
       end do

    else  ! Now recursively update the next finer level

       scale = -dt(n)*dx(n)**(dm-1) ! -dt*area
       call flux_reg_crse_init(bndry_flx(n+1), flux, scale)

       do i = 1, dm
          call multifab_destroy(flux(i))
       end do

       do istep = 1, num_substeps
          call update_level(n+1,mla,phi_old,phi_new,bndry_flx,&
               dx,dt,the_bc_tower,istep,num_substeps)
       end do

       if ( parallel_IOProcessor() ) &
            print*,'   Refluxing level: ',n

       ! note that bndry_flx contains sum_{fine}{flux*dt*area} - {flux*dt*area}_crse
       scale = 1.d0/dx(n)**dm ! 1/volume
       call reflux(phi_new(n),bndry_flx(n+1),scale)

       ! Average the level (n+1) phi down onto level n. This overwrites all
       !     previous values of phi at level n under level (n+1) grids.
       call ml_cc_restriction_c(phi_new(n),1,phi_new(n+1),1,mla%mba%rr(n,:),1)
    end if

  end subroutine update_level

end module advance_module

max_stars_repo_name: memmett/BoxLib

max_issues_repo_name: memmett/BoxLib

max_forks_repo_name: memmett/BoxLib


!  OpenACC Runtime Library Definitions.

!  Copyright (C) 2014-2020 Free Software Foundation, Inc.

!  Contributed by Tobias Burnus <burnus@net-b.de>
!              and Mentor Embedded.

!  This file is part of the GNU Offloading and Multi Processing Library
!  (libgomp).

!  Libgomp is free software; you can redistribute it and/or modify it
!  under the terms of the GNU General Public License as published by
!  the Free Software Foundation; either version 3, or (at your option)
!  any later version.

!  Libgomp is distributed in the hope that it will be useful, but WITHOUT ANY
!  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
!  FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
!  more details.

!  Under Section 7 of GPL version 3, you are granted additional
!  permissions described in the GCC Runtime Library Exception, version
!  3.1, as published by the Free Software Foundation.

!  You should have received a copy of the GNU General Public License and
!  a copy of the GCC Runtime Library Exception along with this program;
!  see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
!  <http://www.gnu.org/licenses/>.

! Wrapper functions will be built from openacc.f90.  We use a separate file
! here, because for using ../../openacc.f90, implementations are required for
! all the functions that it wraps, which we currently don't provide, so linking
! would fail.

module openacc_kinds
  use iso_fortran_env, only: int32
  implicit none

  public
  private :: int32

  ! When adding items, also update 'public' setting in 'module openacc' below.

  integer, parameter :: acc_device_kind = int32

  ! Keep in sync with include/gomp-constants.h.
  integer (acc_device_kind), parameter :: acc_device_current = -1
  integer (acc_device_kind), parameter :: acc_device_none = 0
  integer (acc_device_kind), parameter :: acc_device_default = 1
  integer (acc_device_kind), parameter :: acc_device_host = 2
  ! integer (acc_device_kind), parameter :: acc_device_host_nonshm = 3 removed.
  integer (acc_device_kind), parameter :: acc_device_not_host = 4
  integer (acc_device_kind), parameter :: acc_device_nvidia = 5
  integer (acc_device_kind), parameter :: acc_device_radeon = 8

end module openacc_kinds

module openacc_internal
  use openacc_kinds
  implicit none

  interface
    function acc_on_device_h (devicetype)
      import
      integer (acc_device_kind) devicetype
      logical acc_on_device_h
    end function
  end interface

  interface
    function acc_on_device_l (devicetype) &
        bind (C, name = "acc_on_device")
      use iso_c_binding, only: c_int
      integer (c_int) :: acc_on_device_l
      integer (c_int), value :: devicetype
    end function
  end interface
end module openacc_internal

module openacc
  use openacc_kinds
  use openacc_internal
  implicit none

  private

  ! From openacc_kinds
  public :: acc_device_kind
  public :: acc_device_none, acc_device_default, acc_device_host
  public :: acc_device_not_host, acc_device_nvidia, acc_device_radeon

  public :: acc_on_device

  interface acc_on_device
    procedure :: acc_on_device_h
  end interface

end module openacc

function acc_on_device_h (devicetype)
  use openacc_internal, only: acc_on_device_l
  use openacc_kinds
  integer (acc_device_kind) devicetype
  logical acc_on_device_h
  acc_on_device_h = acc_on_device_l (devicetype) /= 0
end function