text:
************************************************************************
*     UPDATE_EST - Updates the estimated yield of magic beans given
*       some additional amount of rainfall
************************************************************************
*
*     VARIABLES
*
*     INPUT RAIN      = Additional rainfall
*
*     INOUT YIELD_EST = Crop yield to update
*
************************************************************************

************************************************************************
*     CROP_YIELD - Estimate the yield of magic beans given a simple
*       model for rainfall
************************************************************************
*
*     VARIABLES
*
*     INPUT MAX_RAIN   = The maximum rain for the month
*     INPUT CONSITENCY = The consistency of the rainfall
*       (higher = more consistent)
*     INPUT ABSORBTION = Estimates the % of rainfall absorbed into the
*       soil (i.e. % lost due to evaporation, runoff)
*
*     OUTPUT YIELD_EST = The estimated yield of magic beans
*
*     DAY              = The current day of the month
*     RAIN             = The rainfall estimate for the current day
*
************************************************************************
      PROGRAM CROP_YIELD
      IMPLICIT NONE

      INTEGER DAY
      DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN, NEWS
      DOUBLE PRECISION MAX_RAIN, CONSISTENCY, ABSORBTION

      MAX_RAIN = 4.0
      CONSISTENCY = 64.0
      ABSORBTION = 0.6

      YIELD_EST = 0
      TOTAL_RAIN = 0

      DO 20 DAY=1,31
        PRINT *, "(", DAY, CONSISTENCY, MAX_RAIN, ABSORBTION, ")"
*       Compute rainfall for the current day
        RAIN = (-(DAY - 16) ** 2 / CONSISTENCY + MAX_RAIN) * ABSORBTION
        PRINT *, RAIN

*       Update rainfall estimate
        YIELD_EST = UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
        NEWS = TEST_FUNC(TOTAL_RAIN, YIELD_EST)

        PRINT *, "Day ", DAY, " Estimate: ", YIELD_EST

   20 ENDDO

      PRINT *, "Crop Yield(%): ", YIELD_EST
      PRINT *, "News: ", NEWS

      CONTAINS
       DOUBLE PRECISION FUNCTION UPDATE_EST(RAIN, TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION RAIN, YIELD_EST, TOTAL_RAIN
          TOTAL_RAIN = TOTAL_RAIN + RAIN

*         Yield increases up to a point
          IF(TOTAL_RAIN .le. 40) THEN
            YIELD_EST = -(TOTAL_RAIN - 40) ** 2 / 16 + 100

*         Then sharply declines
          ELSE
              YIELD_EST = -TOTAL_RAIN + 140
          ENDIF
          UPDATE_EST = YIELD_EST

        END FUNCTION UPDATE_EST

       DOUBLE PRECISION FUNCTION TEST_FUNC(TOTAL_RAIN, YIELD_EST)
          IMPLICIT NONE
          DOUBLE PRECISION TOTAL_RAIN, YIELD_EST, NEW_VAR
          NEW_VAR = 5.0
          IF (NEW_VAR .le. 4.0) THEN
            TEST_FUNC = TOTAL_RAIN
          ELSE
            TEST_FUNC = YIELD_EST
          ENDIF

       END FUNCTION TEST_FUNC

      END PROGRAM CROP_YIELD

max_stars_repo_name: cthoyt/delphi

max_issues_repo_name: cthoyt/delphi

max_forks_repo_name: cthoyt/delphi


text:
        SUBROUTINE LS_WGEM ( lunf, nparm, parms, cprms, imnem,
     +			     numprm, iret )
C************************************************************************
C* LS_WGEM                                                              *
C*                                                                      *
C* This subroutine retrievs interface-stored data, converts it into     *
C* GEMPAK output, and then writes the GEMPAK output to the GEMPAK       *
C* output file.                                                         *
C* 								        *
C* LS_WGEM ( LUNF, NPARM, PARMS, CPRMS, IMNEM, NUMPRM, IRET )           *
C*								        *
C* Input parameters:                                                    *
C*      LUNF           INTEGER        GEMPAK file unit number           *
C*      NPARM          INTEGER        Number of parms in packing table  *
C*      PARMS (*)      CHAR*          List of parms in packing table    *
C*	CPRMS (*)      CHAR*          GEMPAK parms chosen for output    *
C*      IMNEM (*)      INTEGER        Subscript mappings, data to GEMPAK*
C*      NUMPRM         INTEGER        Count of chosen GEMPAK parameters *
C*								        *
C* Output parameters:						        *
C*      IRET           INTEGER        Return code                       *
C*                                      0 = normal return               *
C*                                      1 = problems                    *
C*                                                                      *
C**                                                                     *
C* Log:							                *
C* R. Hollern/NCEP       6/96                                           *
C* D. Kidwell/NCEP       1/98	Changed interface, cleaned up code      *
C* D. Kidwell/NCEP       2/98	Added snow parameters to output         *
C* D. Kidwell/NCEP       3/98	Added time check for max/min temps,     *
C*                              removed rpttim from calling sequence    *
C* T. Lee/GSC		 2/99	Added calls to surface pressure checks	*
C* D. Kidwell/NCEP      10/99	Converted auto weather to manned equiv. *
C************************************************************************
	INCLUDE 	'GEMPRM.PRM'
        INCLUDE 	'lscmn.cmn'
C*
        CHARACTER*(*)  	parms (*), cprms (*)
	INTEGER		imnem (*)
C*
	REAL		rdata (MMPARM)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
        iret = 0
C
C*	Surface pressure quality checks.
C
	CALL LS_QCTL ( ier )
C
C*      Initialize GEMPAK output array.
C
        DO i = 1, MMPARM
            rdata ( i ) = RMISSD
        END DO
C
C*      Get hours and minutes of report obs time.
C
        ihhmm = 100 * irptdt ( 4 ) + irptdt ( 5 )
C
        DO  k = 1, numprm
C
C*          Check for the parameter in the list.
C
            CALL ST_FIND  ( cprms ( k ), parms, nparm, ilc, ier )
C
            IF ( ilc .eq. 0 )  THEN
                CALL DC_WLOG  ( 2, 'DCLSFC', -3, cprms(k), ierr )
              ELSE
C
C*              Retrieve the requested data and store it into the
C*		GEMPAK array.
C
                IF ( imnem ( k ) .ne. 0 ) THEN
                    rdata ( ilc ) = rivals ( imnem ( k ) )
C
C*                  Check for missing wind direction interface value.
C
                    IF ( cprms ( k ) .eq. 'DRCT' ) THEN
                        IF ( rdata ( ilc ) .eq. 99. )
     +                       rdata ( ilc ) = RMISSD
C
C*			Check for time period for max and min
C*			temperatures, and only save 24 hour periods.
C
		      ELSE IF ( cprms ( k ) .eq. 'TDXC' ) THEN
			IF ( rivals ( irdtv1 ) .le. 23.9 )
     +			  rdata ( ilc ) = RMISSD
		      ELSE IF ( cprms ( k ) .eq. 'TDNC' ) THEN
			IF ( rivals ( irdtv2 ) .le. 23.9 )
     +			  rdata ( ilc ) = RMISSD
C
C*			Check for automated present or past weather,
C*			and convert to manned equivalent.
C
		      ELSE IF ( cprms ( k ) .eq. 'WWMO' ) THEN
			IF ( .not. ERMISS ( rivals ( irwwma ) ) )
     +			  rdata ( ilc ) = PR_WMAO ( rivals ( irwwma ) )
		      ELSE IF ( cprms ( k ) .eq. 'PWWM' ) THEN
			IF ( .not. ERMISS ( rivals ( irpwwa ) ) )
     +			  rdata ( ilc ) = PR_PWAO ( rivals ( irpwwa ) )
C
C*			Check for SNOW and convert cm to inches.
C
		      ELSE IF ( cprms ( k ) .eq. 'SNOW' ) THEN
			IF ( .not. ERMISS ( rdata ( ilc ) ) ) THEN
			    IF ( rdata ( ilc ) .lt. 997 ) THEN
         		        rdata (ilc) = PR_MMIN ( rdata(ilc) *10.)
			      ELSE
				rdata ( ilc ) = RMISSD
			    END IF
			END IF
C
C*			Check for SNEW and convert meters to inches.
C
		      ELSE IF ( cprms ( k ) .eq. 'SNEW' ) THEN
			IF ( .not. ERMISS ( rdata ( ilc ) ) )
     +   		  rdata (ilc) = PR_MMIN ( rdata (ilc) * 1000. )
C
C*                      Check for trace precipitation interface value.
C
                      ELSE IF ( rdata ( ilc ) .eq. -1. ) THEN
                        IF ( ( cprms ( k ) .eq. 'P03M' ) .or.
     +			     ( cprms ( k ) .eq. 'P06M' ) .or.
     +			     ( cprms ( k ) .eq. 'P09M' ) .or.
     +		             ( cprms ( k ) .eq. 'P12M' ) .or.
     +		             ( cprms ( k ) .eq. 'P18M' ) .or.
     +		             ( cprms ( k ) .eq. 'P24M' ) )
     +                       rdata ( ilc ) = 0.
                    END IF
                END IF
            END IF
C
        END DO
C
C*	Write the decoded report data to GEMPAK land surface data file.
C
        CALL SF_WDAT ( lunf, ihhmm, rdata, ier )
C
        IF ( ier .ne. 0 ) THEN
C
C*          Write an error message if there was a file write error.
C
            CALL DC_WLOG( 2, 'SF', ier, ' ', ierr )
            iret = 1
            RETURN
        END IF
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
program t
  call s
end program t

subroutine s
!sms$ignore begin
  print '(a)','hello'
!sms$ignore end
end subroutine s

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
      SUBROUTINE MRED2F
C
C     THIS SUBROUTINE COMPUTES THE FREEBODY EFFECTS FOR THE MRED2
C     MODULE.
C
C     INPUT DATA
C     GINO   - MAA    - SUBSTRUCTURE MASS MATRIX
C              DMR    - FREEBODY MATRIX
C     SOF    - GIMS   - G TRANSFORMATION MATRIX FOR BOUNDARY POINTS OF
C                       ORIGINAL SUBSTRUCTURE
C
C     OUTPUT DATA
C     GINO   - HGH    - HORG PARTITION MATRIX
C     SOF    - HORG   - H TRANSFORMATION MATRIX FOR ORIG. SUBSTRUCTURE
C
C     PARAMETERS
C     INPUT  - GBUF   - GINO BUFFERS
C              INFILE - INPUT FILE NUMBERS
C              ISCR   - SCRATCH FILE NUMBERS
C              KORLEN - LENGTH OF OPEN CORE
C              KORBGN - BEGINNING ADDRESS OF OPEN CORE
C              FREBDY - FREEBODY MODES OPTION FLAG
C     OTHERS - RPRTN  - ROW PARTITIONING VECTOR FILE NUMBER
C              LII    - LII PARTITION MATRIX FILE NUMBER (ISCR11)
C              IDENT  - IDENTITY MATRIX FILE NUMBER
C              ZERO   - ZERO MATRIX FILE NUMBER
C              HIE    - HIE PARTITION MATRIX FILE NUMBER
C              HIR    - HIR PARTITION MATRIX FILE NUMBER
C              HIRSCR - HIR SCRATCH PARTITION MATRIX FILE NUMBER
C              FBR    - FBR PARTITION MATRIX FILE NUMBER
C              FIR    - FIR PARTITION MATRIX FILE NUMBER
C              GIB    - GIMS INPUT FILE NUMBER
C              CPRTN  - COLUMN PARTITIONING VECTOR FILE NUMBER
C              HIM    - HIM PARTITION MATRIX FILE NUMBER
C              HGH    - HORG MATRIX FILE NUMBER
C
      LOGICAL          FREBDY,BOUNDS
      INTEGER          DRY,GBUF1,GBUF2,SBUF1,SBUF2,SBUF3,OLDNAM,Z,T,
     1                 SIGNAB,SIGNC,PRECMP,SCR,FUSET,PRECFB,SIGN,TYPINP,
     2                 TYPEOP,TYPINU,UN,UB,UI,DMR,FAR,FIR,FARIND,ZERO,
     3                 RPRTN,HIE,HIR,CPRTN,HIM,HGH,GIB,HIRSCR,USETMR,
     4                 DBLKOR,SGLKOR
      DOUBLE           PRECISION DZ,DHIRMG
      DIMENSION MODNAM (2),ITRLR1(7),ITRLR2(7),RZ(1),ISUB(4),ITMLST(4),
     1                 DZ(1)
      COMMON /BLANK /  IDUM1,DRY,IDUM7,GBUF1,GBUF2,IDUM2,SBUF1,SBUF2,
     1                 SBUF3,INFILE(12),OTFILE(6),ISCR(10),KORLEN,
     2                 KORBGN,OLDNAM(2),IDUM4(2),FREBDY,IDUM8(5),BOUNDS,
     3                 IDUM9(6),LSTZWD,ISCR11
      COMMON /ZZZZZZ/  Z(1)
      COMMON /MPYADX/  ITRLRA(7),ITRLRB(7),ITRLRC(7),ITRLRD(7),NZMPY,T,
     1                 SIGNAB,SIGNC,PRECMP,SCR
      COMMON /BITPOS/  IDUM5(9),UN,IDUM6(10),UB,UI
      COMMON /PATX  /  LCORE,NSUB(3),FUSET
      COMMON /FBSX  /  JTRLRL(7),JTRLRU(7),JTRLRB(7),JTRLRX(7),NZFBS,
     1                 PRECFB,SIGN
      COMMON /PACKX /  TYPINP,TYPEOP,IROWP,NROWP,INCRP
      COMMON /UNPAKX/  TYPINU,IROWU,NROWU,INCRU
      COMMON /SYSTEM/  IDUM3,IPRNTR
      EQUIVALENCE      (USETMR,INFILE(5)),(MAA,INFILE(7)),
     1                 (DMR,INFILE(11)),(RPRTN,ISCR(9)),(IDENT,ISCR(5)),
     2                 (CPRTN,ISCR(10)),(PPRTN,ISCR(4)),(RZ(1),Z(1)),
     3                 (DZ(1),Z(1)),(GIB,ISCR(4)),(LII ,ISCR11),
     4                 (HIRSCR,ISCR(5)),(HGH,ISCR(8)),(ZERO,ISCR(6)),
     5                 (HIM,ISCR(8)),(HIE,ISCR(7)),(HIR ,ISCR(9)),
     6                 (FAR,ISCR(9)),(FIR,ISCR(10))
      DATA    MODNAM/  4HMRED,4H2F  /
      DATA    FARIND,  ISCR7 ,ISCR8 /6, 307, 308  /
      DATA    ITMLST/  4HGIMS,4HHORG,4HUPRT,4HLMTX/
C
C     TEST FREEBODY MODES CALCULATION FLAG
C
      IF (DRY .EQ. -2) GO TO 300
      ITRLR2(1) = DMR
      CALL RDTRL (ITRLR2)
      IF (ITRLR2(1) .LT. 0) GO TO 110
C
C     COMPUTE FREEBODY MATRIX
C
C        **   **   **   ** **   **
C        *     *   *     * *     *
C        * FAR * = * MAA * * DMR *
C        *     *   *     * *     *
C        **   **   **   ** **   **
C
      CALL SOFCLS
      FREBDY = .TRUE.
      ITRLR1(1) = MAA
      CALL RDTRL (ITRLR1)
      DO 10 I = 1,7
      ITRLRA(I) = ITRLR1(I)
      ITRLRB(I) = ITRLR2(I)
   10 ITRLRC(I) = 0
      IFORM = 2
      IPRC  = 1
      ITYP  = 0
      IF (ITRLRA(5).EQ.2 .OR. ITRLRA(5).EQ.4) IPRC = 2
      IF (ITRLRB(5).EQ.2 .OR. ITRLRB(5).EQ.4) IPRC = 2
      IF (ITRLRA(5) .GE. 3) ITYP = 2
      IF (ITRLRB(5) .GE. 3) ITYP = 2
      ITYPE = IPRC + ITYP
      CALL MAKMCB (ITRLRD,FAR,ITRLR1(3),IFORM,ITYPE)
      T     = 0
      SIGNAB= 1
      SIGNC = 1
      PREC  = 0
      SCR   = ISCR(4)
      DBLKOR= 1 + KORBGN/2
      NZMPY = LSTZWD - 2*DBLKOR - 1
      CALL MPYAD  (DZ(DBLKOR),DZ(DBLKOR),DZ(DBLKOR))
      CALL WRTTRL (ITRLRD)
C
C     PARTITION FAR INTO BOUNDARY, INTERIOR POINTS
C
C                  **   **
C                  *     *
C        **   **   * FBR *
C        *     *   *     *
C        * FAR * = *.....*
C        *     *   *     *
C        **   **   * FIR *
C                  *     *
C                  **   **
C
      LCORE = NZMPY
      FUSET = USETMR
      CALL CALCV (PPRTN,UN,UI,UB,Z(KORBGN))
      CALL GMPRTN (FAR,FIR,0,0,0,0,PPRTN,NSUB(1),NSUB(2),Z(KORBGN),
     1             KORLEN)
C
C     CALCULATE FREEBODY TRANSFORMATION MATRIX
C
C                       T
C        **   ** **   ** **   **    **   **
C        *     * *     * *     *    *     *
C        * LII * * LII * * HIR * = -* FIR *
C        *     * *     * *     *    *     *
C        **   ** **   ** **   **    **   **
C
      IF (.NOT.BOUNDS) GO TO 20
      ITEM = ITMLST(4)
      CALL SOFTRL (OLDNAM,ITEM,JTRLRL)
      ITEST = JTRLRL(1)
      IF (ITEST .NE. 1) GO TO 20
      JTRLRL(1) = LII
      CALL SOFOPN (Z(SBUF1),Z(SBUF2),Z(SBUF3))
      CALL MTRXI (LII,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 1) GO TO 210
      CALL SOFCLS
      GO TO 30
   20 JTRLRL(1) = LII
      CALL RDTRL (JTRLRL)
   30 JTRLRB(1) = FIR
      CALL RDTRL (JTRLRB)
      IFORM = 2
      IPRC  = 1
      ITYP  = 0
      IF (JTRLRL(5).EQ.2 .OR. JTRLRL(5).EQ.4) IPRC = 2
      IF (JTRLRB(5).EQ.2 .OR. JTRLRB(5).EQ.4) IPRC = 2
      IF (JTRLRL(5) .GE. 3) ITYP = 2
      IF (JTRLRB(5) .GE. 3) ITYP = 2
      ITYPE = IPRC + ITYP
      CALL MAKMCB (JTRLRX,HIR,JTRLRB(3),IFORM,ITYPE)
      NZFBS  = NZMPY
      PRECFB = ITYPE
      SIGN   = -1
      CALL FBS (Z(KORBGN),Z(KORBGN))
      CALL WRTTRL (JTRLRX)
C
C     UNPACK HIR COLUMNS FOR SCALING
C
      TYPINU = JTRLRX(5)
      IROWU  = 1
      NROWU  = JTRLRX(3)
      INCRU  = JTRLRX(5)
      TYPINP = JTRLRX(5)
      TYPEOP = JTRLRX(5)
      IROWP  = 1
      NROWP  = JTRLRX(3)
      INCRP  = JTRLRX(5)
      CALL GOPEN (HIR,Z(GBUF1),0)
      IFORM  = JTRLRX(4)
      CALL MAKMCB (ITRLR1,HIRSCR,JTRLRX(3),IFORM,JTRLRX(5))
      CALL GOPEN (HIRSCR,Z(GBUF2),1)
      SGLKOR = 2*DBLKOR - 1
      DO 80 I = 1,FARIND
      CALL UNPACK (*60,HIR,DZ(DBLKOR))
C
C     CALCULATE MAGNITUDE OF HIR
C
      IF (JTRLRX(5) .EQ. 2) GO TO 42
      HIRMAG = RZ(SGLKOR)
      IF (NROWU .EQ. 1) GO TO 50
      DO 40 J = 2,NROWU
      IF (ABS(RZ(SGLKOR+J-1)) .GT. ABS(HIRMAG)) HIRMAG = RZ(SGLKOR+J-1)
   40 CONTINUE
      GO TO 50
   42 DHIRMG = DZ(DBLKOR)
      IF (NROWU .EQ. 1) GO TO 50
      DO 44 J = 2,NROWU
      IF (DABS(DZ(DBLKOR+J-1)) .GT. DABS(DHIRMG)) DHIRMG =DZ(DBLKOR+J-1)
   44 CONTINUE
C
C     SCALE HIR COLUMN
C
   50 IF (JTRLRX(5) .EQ. 2) GO TO 54
      DO 52 J = 1,NROWU
   52 RZ(SGLKOR+J-1) = RZ(SGLKOR+J-1)/HIRMAG
      GO TO 80
   54 DO 56 J = 1,NROWU
   56 DZ(DBLKOR+J-1) = DZ(DBLKOR+J-1)/DHIRMG
      GO TO 80
C
C     NULL COLUMN
C
   60 IF (JTRLRX(5) .EQ. 2) GO TO 74
      DO 72 J = 1,NROWU
   72 RZ(SGLKOR+J-1) = 0.0
      GO TO 80
   74 DO 76 J = 1,NROWU
   76 DZ(DBLKOR+J-1) = 0.0D0
C
C     PACK HIR COLUMN
C
   80 CALL PACK (DZ(DBLKOR),HIRSCR,ITRLR1)
      CALL CLOSE (HIRSCR,1)
      CALL CLOSE (HIR,1)
      CALL WRTTRL (ITRLR1)
      ISUB(1) = ITRLR1(2)
C
C     SET UP MERGE COLUMN PARTITION VECTOR
C
      ITRLR2(1) = HIM
      CALL RDTRL (ITRLR2)
      I = ITRLR1(2) + ITRLR2(2)
      ISUB(2) = ITRLR2(2)
      DO 100 J = 1,I
      RZ(KORBGN+J-1) = 0.0
      IF (J .GT. ISUB(1)) RZ(KORBGN+J-1) = 1.0
  100 CONTINUE
      TYPINP = 1
      TYPEOP = 1
      IROWP  = 1
      NROWP  = I
      INCRP  = 1
      IFORM  = 7
      CALL MAKMCB (ITRLR2,RPRTN,NROWP,IFORM,TYPINP)
      CALL GOPEN (RPRTN,Z(GBUF1),1)
      CALL PACK(RZ (KORBGN),RPRTN,ITRLR2)
      CALL CLOSE (RPRTN,1)
      CALL WRTTRL (ITRLR2)
C
C     MERGE FREEBODY, MODAL TRANSFORMATION MATRICES
C
C        **   **   **         **
C        *     *   *     .     *
C        * HIE * = * HIR . HIM *
C        *     *   *     .     *
C        **   **   **         **
C
      IF (HIE .NE. HIM) GO TO 105
      HIE = ISCR8
      HGH = ISCR7
  105 ITYPE = 1
      IF (I .NE. ITRLR2(3)) ITYPE = 2
      CALL GMMERG (HIE,HIRSCR,0,HIM,0,RPRTN,0,ISUB,ITYPE,Z(KORBGN),
     1             KORLEN)
      CALL SOFOPN (Z(SBUF1),Z(SBUF2),Z(SBUF3))
      GO TO 120
C
C     FREEBODY MODES NOT REQUESTED
C
  110 HIE = HIM
      IF (HIE .EQ. ISCR7) HGH = ISCR8
      IF (HIE .EQ. ISCR8) HGH = ISCR7
C
C     FORM HGH MATRIX
C
C                  **         **
C                  *     .     *
C        **   **   *  I  .  0  *
C        *     *   *     .     *
C        * HGH * = *...........*
C        *     *   *     .     *
C        **   **   * GIB . HIE *
C                  *     .     *
C                  **         **
C
  120 CALL SOFTRL (OLDNAM,ITMLST(2),ITRLR1)
      IF (ITRLR1(1) .EQ. 1) GO TO 190
C
C     GENERATE IDENTITY MATRIX
C
      CALL SOFTRL (OLDNAM,ITMLST(1),ITRLR1)
      ITEST = ITRLR1(1)
      ITEM  = ITMLST(1)
      IF (ITEST .NE. 1) GO TO 210
      TYPINP = 1
      TYPEOP = ITRLR1(5)
      IROWP  = 1
      NROWP  = ITRLR1(2)
      INCRP  = 1
      IFORM  = 8
      II = ITRLR1(2)
      CALL MAKMCB (ITRLR1,IDENT,NROWP,IFORM,TYPEOP)
      CALL GOPEN  (IDENT,Z(GBUF1),1)
      DO 140 I = 1,II
      DO 130 J = 1,II
      RZ(KORBGN+J-1) = 0.0
      IF (I .EQ. J) RZ(KORBGN+J-1) = 1.0
  130 CONTINUE
  140 CALL PACK (RZ(KORBGN),IDENT,ITRLR1)
      CALL CLOSE (IDENT,1)
      CALL WRTTRL (ITRLR1)
C
C     SET UP MERGE ROW PARTITION VECTOR
C
      ITRLR1(1) = HIE
      CALL RDTRL (ITRLR1)
      ITER  = ITRLR1(2)
      NROWP = II + ITER
      DO 170 I = 1,NROWP
      RZ(KORBGN+I-1) = 0.0
      IF (I .GT. II) RZ(KORBGN+I-1) = 1.0
  170 CONTINUE
      TYPINP = 1
      TYPEOP = 1
      INCRP  = 1
      IFORM  = 7
      CALL MAKMCB (ITRLR2,RPRTN,NROWP,IFORM,TYPINP)
      CALL GOPEN (RPRTN,Z(GBUF1),1)
      CALL PACK (RZ(KORBGN),RPRTN,ITRLR2)
      CALL CLOSE (RPRTN,1)
      CALL WRTTRL (ITRLR2)
      NROWS = NROWP
C
C     SET UP MERGE COLUMN PARTITION VECTOR
C
      ITEM = ITMLST(3)
      CALL MTRXI (CPRTN,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 1) GO TO 210
C
C     SET UP GIB MATRIX
C
      CALL MTRXI (GIB,OLDNAM,ITMLST(1),0,ITEST)
      ITEM = ITMLST(1)
      IF (ITEST .NE. 1) GO TO 210
C
C     MERGE ALL STRUCTURAL REDUCTION TRANSFORMATION MATRICES
C
      ISUB(1) = II
      ISUB(2) = ITER
      ISUB(3) = ITRLR1(3)
      ISUB(4) = II
      ITYPE   = 1
      IF (NROWS .NE. NROWP) ITYPE = 2
      CALL GMMERG (HGH,GIB,IDENT,HIE,0,RPRTN,CPRTN,ISUB,ITYPE,Z(KORBGN),
     1             KORLEN)
C
C     SAVE HGH ON SOF AS HORG MATRIX
C
      CALL MTRXO (HGH,OLDNAM,ITMLST(2),0,ITEST)
      ITEM = ITMLST(2)
      IF (ITEST .NE. 3) GO TO 210
  190 CONTINUE
      GO TO 300
C
C     PROCESS MODULE FATAL ERRORS
C
  210 GO TO (220,230,240,250,260,280), ITEST
  220 IMSG = -9
      GO TO 290
  230 IMSG = -11
      GO TO 290
  240 IMSG = -1
      GO TO 270
  250 IMSG = -2
      GO TO 270
  260 IMSG = -3
  270 CALL SMSG (IMSG,ITEM,OLDNAM)
      GO TO 300
  280 IMSG = -10
  290 DRY  = -2
      CALL SMSG1 (IMSG,ITEM,OLDNAM,MODNAM)
  300 RETURN
      END


text:
      SUBROUTINE NXTWIN(LUN,IWIN,JWIN)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    NXTWIN
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: GIVEN INDICES WITHIN THE INTERNAL JUMP/LINK TABLE WHICH
C   POINT TO THE START AND END OF AN "RPC" WINDOW (I.E. ITERATION OF
C   AN 8-BIT OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE
C   COMPUTES THE START AND END INDICES OF THE NEXT WINDOW.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C                           ROUTINE "BORT"
C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C                           BUFR FILES UNDER THE MPI)
C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C                           INCREASED FROM 15000 TO 16000 (WAS IN
C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C                           WRF; ADDED DOCUMENTATION (INCLUDING
C                           HISTORY) (INCOMPLETE); OUTPUTS MORE
C                           COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C                           TERMINATES ABNORMALLY
C 2009-03-31  J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION
C 2009-05-07  J. ATOR    -- USE LSTJPB INSTEAD OF LSTRPC
C
C USAGE:    CALL NXTWIN (LUN, IWIN, JWIN)
C   INPUT ARGUMENT LIST:
C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C     IWIN     - INTEGER: STARTING INDEX OF CURRENT WINDOW ITERATION
C     JWIN     - INTEGER: ENDING INDEX OF CURRENT WINDOW ITERATION
C
C   OUTPUT ARGUMENT LIST:
C     IWIN     - INTEGER: STARTING INDEX OF NEXT WINDOW ITERATION
C     JWIN     - INTEGER: ENDING INDEX OF NEXT WINDOW ITERATION
C
C REMARKS:
C
C    SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN
C    EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET.
C
C    THIS ROUTINE CALLS:        BORT     LSTJPB
C    THIS ROUTINE IS CALLED BY: UFBEVN   UFBIN3   UFBRW
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)

      CHARACTER*128 BORT_STR
      REAL*8        VAL

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      IF(JWIN.EQ.NVAL(LUN)) THEN
         IWIN = 0
         GOTO 100
      ENDIF

C  FIND THE NEXT SEQUENTIAL WINDOW
C  -------------------------------

      NODE = INV(IWIN,LUN)
      IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900
      IF(VAL(JWIN,LUN).EQ.0) THEN
         IWIN = 0
      ELSE
         IWIN = JWIN
         JWIN = IWIN+VAL(IWIN,LUN)
      ENDIF

C  EXITS
C  -----

100   RETURN
900   WRITE(BORT_STR,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '//
     . '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN '//
     . '=",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN
      CALL BORT(BORT_STR)
      END


text:
      subroutine writinit(logbat,loglog,ixnamxxx,mode)
C
C
C#######################################################################
C
C     PURPOSE -
C
C        THIS ROUTINE CONTROLS THE INITIALIZATION OF THE LOG FILES.
C        THERE ARE CURRENTLY 3 LOG FILES:
C
C           (1) TTY LOG FILE   --- TURNED OFF DURING PRODUCTION RUNS
C
C           (2) BATCH LOG FILE --- ALWAYS TURNED ON TO CAPTURE
C                                  MESSAGES IN A LOG FILE.
C
C           (3) ERROR LOG FILE
C
C
C     INPUT ARGUMENTS -
C
C        logbat   - NAME OF BATCH LOG FILE
C
C        loglog   - NAME OF COMMAND LOG FILE
C
C        ixnamxxx - NAME OF CODE EXECUTABLE
C
C        mode     - set to 'noisy' for tty output, set to 'silent'
C                        for no tty output
C
C     OUTPUT ARGUMENTS -
C
C        NONE
C
C
C     CHANGE HISTORY -
C
C        $Log: writinit.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.19   17 Oct 2007 15:11:44   tam
CPVCS    Version was not being written to SunOS
CPVCS
CPVCS       Rev 1.18   03 Oct 2007 11:06:54   tam
CPVCS    changed banner and dates so smaller and easier to read
CPVCS
CPVCS       Rev 1.17   03 Oct 2007 08:16:10   tam
CPVCS    removed args Version and compiled, they are now construed
CPVCS    directly from lagrit.h and allows better control of date
CPVCS    and the look of the banner. Added copyright statement.
CPVCS
CPVCS       Rev 1.16   08 Jan 2007 07:37:00   tam
CPVCS    added appropriate number of spaces to replace www
CPVCS
CPVCS       Rev 1.15   08 Jan 2007 07:29:56   tam
CPVCS    took www out of http statement so it works
CPVCS
CPVCS       Rev 1.14   05 Jan 2007 14:47:58   tam
CPVCS    added Manual web page to header
CPVCS
CPVCS       Rev 1.13   03 Jan 2007 13:49:20   tam
CPVCS    this is the automated and original version
CPVCS
CPVCS       Rev 1.11   05 Aug 2002 17:08:26   dcg
CPVCS    use 4 digit year
CPVCS
CPVCS       Rev 1.10   Wed Nov 10 15:05:12 1999   dcg
CPVCS    remove blockini.h
CPVCS
CPVCS       Rev 1.9   Tue Nov 09 16:00:34 1999   dcg
CPVCS    remove unused code
CPVCS
CPVCS       Rev 1.8   Mon Feb 22 16:08:20 1999   dcg
CPVCS    rewrite of command processing to allow for recursion
CPVCS
CPVCS       Rev 1.7   Tue Aug 19 16:34:12 1997   dcg
CPVCS    change name of code
CPVCS    check for expiration date
CPVCS
CPVCS       Rev 1.6   Mon Apr 14 17:06:00 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.5   Tue Sep 24 18:16:00 1996   jan
CPVCS    Write formats added to allow version number and
CPVCS    compile date to appear X3D header.
CPVCS
CPVCS       Rev 1.4   08/23/95 12:27:34   dcg
CPVCS    allow noisy, silent option for tty input
CPVCS
CPVCS       Rev 1.3   05/24/95 15:44:48   het
CPVCS    Change the formats in some write statements
CPVCS
CPVCS       Rev 1.2   01/26/95 08:01:22   ejl
CPVCS    Cleaned up, Fixed holes in the logic, implicit none.
CPVCS    Installed logcom1.h and blockini.h
c
c   Rev 1.0   01/26/95 07:58:08   ejl
cCleaned up, Fixed holes in the logic, implicit none
cInstaled logcom1.h and blockini.h
CPVCS
CPVCS       Rev 1.1   11/22/94 14:33:30   dcg
CPVCS      add call to fdate to get time and date stamp for output
CPVCS
CPVCS       Rev 1.0   11/10/94 12:20:28   pvcs
CPVCS    Original version.
C
C
C#######################################################################
C
      implicit none
C
      character*(*) loglog
      character*(*) logbat
      character*(*) ixnamxxx
      character*8    mode
c
      include "logcom1.h"
      include "lagrit.h"
C
C#######################################################################
C
C#######################################################################
C
C
C
C
C#######################################################################
C
      integer icharlnf
      integer jlogbat, jloglog, ierr1, ierrass, ierrdum,
     *   nyr,myr, ishow_warn
C
      character*132 interfil
      character*8 iunitc
      character*24 now
      character*22 cstring
      character*32 isubname
      character*132 tmp
C
C#######################################################################
C
C
C     *****************************************************************
C
C     INITIALIZE NUMBER OF LOG FILES.
C begin

      numlogs=0
      ishow_warn=0
      isubname="writinit"
C
C     *****************************************************************
C
C     ASSIGN BATCH LOG FILE.
C
      if(logbat.ne.' ') then
C*****         call destroy(0,logbat,0,ierr)
         jlogbat=-1
         call hassign(jlogbat,logbat,ierrass)
         if (jlogbat.lt.0 .or. ierrass.lt.0) then
           call x3d_error(isubname,'hassign bad jlogbat unit')
           print*,"jlogbat: ",logbat,jlogbat
         endif

      endif
C
      if(loglog.ne.' ') then
C*****         call destroy(0,loglog,0,ierr)
         jloglog=-1
         call hassign(jloglog,loglog,ierrass)
         if (jloglog.lt.0 .or. ierrass.lt.0) then
           call x3d_error(isubname,'hassign bad jloglog unit')
           print*,"jloglog: ",loglog,jloglog
         endif
      endif

C
C     *****************************************************************
C
C     SET TYPES OF LOG FILES.
C
      call writset('type',' ','tty',ierr1)
      call writset('type',' ','bat',ierr1)
      call writset('type',' ','log',ierr1)
C
C     *****************************************************************
C
C     SET UNIT NUMBERS OF LOG FILES.
C
      write(iunitc,'(i5)') 6
      call writset('unit','tty',iunitc,ierr1)
C
      write(iunitc,'(i5)') jlogbat
      call writset('unit','bat',iunitc,ierr1)
C
      write(iunitc,'(i5)') jloglog
      call writset('unit','log',iunitc,ierr1)
C
C     *****************************************************************
C
C     SET NAMES OF LOG FILES.
C
      call writset('name','tty','tty',ierr1)
      call writset('name','bat',logbat,ierr1)
      call writset('name','log',loglog,ierr1)
C
C     *****************************************************************
C
C     SET ON/OFF STATUS OF LOG FILES.
C
      if(mode(1:3).ne.'sil') then
         call writset('stat','tty','on',ierr1)
      else
         call writset('stat','tty','off',ierr1)
      endif
C
      call writset('stat','bat', 'on',ierr1)
      call writset('stat','log', 'on',ierr1)
C
C     *****************************************************************
C
C     WRITE CODE VERSION INFORMATION TO LOG FILES.
C     strings for Version and Compiled are passed in from
C     lagrit.h and fdate

C-----Banner Top
C
      write(interfil,9001)
 9001 format('*',15x,'* * * * * * * * * * * * * * * * * * * * * * * *')
      call writloga('default',2,interfil,0,ierrdum)
C
      write(interfil,9002)
 9002 format('*',15x,'*                                             *')
      call writloga('default',0,interfil,0,ierrdum)

C-----Banner Program, OS, and Version Number from lagrit.h
C     Version and date compile taken directly from lagrit.h
C     OS information is based on os_name and should be the
C     same tag used in Makefile

      write (tmp, '(i3,i3,i3)') v_major, v_minor, v_patch
      Version = trim(adjustl(tmp(1:3))) // '.' //
     *          trim(adjustl(tmp(4:6))) // '.' //
     *          trim(adjustl(tmp(7:9)))

C     m32 and m64 are util libs under development
c     otherwise, old util lib is used

C     TODO: add (32-bit / 64-bit) suffix
      tmp = trim(adjustl(os_name))
      write(interfil,8065) Version, tmp
 8065 format('*',15x,'*    Program:  LaGriT V',a6,2x,a15,'*')

      call writloga('default',0,interfil,0,ierrdum)

C-----Banner Compile Time and expiration check
C     now string is day 6:10   time 12:20   year 21:24
C     the front six is blank or has a year
C     Compiled string is year 1:4 followed by month and day
c     look for expiration 2 years greater than compile year

      call fdate(now)
      cstring = date_compile
      if (cstring(1:4).eq.'DATE') then
         cstring=now(21:24)//'/00/00 at 00:00:00'
      endif

      write(interfil,9004) cstring,'    *'
 9004 format('*',15x,'*    Date Compile: ',a22,a6)
      call writloga('default',0,interfil,0,ierrdum)

      nyr = (ichar(now(23:23))-ichar('0'))*10+
     *     (ichar(now(24:24))-ichar('0'))
      myr = (ichar(cstring(3:3))-ichar('0'))*10+
     *     (ichar(cstring(4:4))-ichar('0'))

c     show warning if code is older than 2 years
      if(myr.ne.nyr.and.mod(myr+1,100).ne.nyr.and.
     *   mod(myr+2,100).ne.nyr) ishow_warn = 1

C-----Banner Program run time
C
      write(interfil,9009) now(21:24),now(5:10),now(12:20)
 9009 format('*',15x,'*    Run Time: ',a4,'/',a6,'  ',a9,'         *')
      call writloga('default',0,interfil,0,ierrdum)

C-----Banner Man pages
C
      write(interfil,9007)
 9007 format('*',15x,'*    Manual:   https://lagrit.lanl.gov        *')
      call writloga('default',0,interfil,0,ierrdum)

C
C-----Banner Bottom
C
      write(interfil,9002)
      call writloga('default',0,interfil,0,ierrdum)
      write(interfil,9001)
      call writloga('default',0,interfil,0,ierrdum)

C     *****************************************************************
C     WRITE COPYRITE TEXT
C     Changed from LACC-2012-084 open distribution
C     to LACC-15-069 open source
C

      write(interfil,'(a)')
     * '                               -----oOo-----    '
      call writloga('default',1,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '             LaGriT V3 LA-CC-15-069 '
     * //' https://github.com/lanl/LaGriT'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  Copyright 2016. Triad National Security, LLC. '
     * //' All rights reserved. This'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  program was produced under '
     * //'U.S. Government contract 89233218CNA000001'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  for Los Alamos National Laboratory (LANL),'
     * //' which is operated by Triad'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  National Security, LLC for the U.S. Department of'
     * // ' Energy/National Nuclear'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  Security Administration.  All rights in the program '
     * // 'are reserved by Triad'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  National Security, LLC, and the U.S. Department'
     * // ' of Energy/National Nuclear'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '  Security Administration. The Government is granted'
     * // ' for itself and others'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     *  '  acting on its behalf a nonexclusive, paid-up,'
     * // ' irrevocable worldwide license'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     *  '  in this material to reproduce, prepare derivative'
     * // ' works, distribute copies'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     *  '  to the public, perform publicly and display publicly,'
     * // ' and to permit others to'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     *  '  do so. This software is open source and available'
     * // ' under the BSD-3 License.'
      call writloga('default',0,interfil,0,ierrdum)

      write(interfil,'(a)')
     * '                               -----oOo-----    '
      call writloga('default',0,interfil,1,ierrdum)

C     *****************************************************************
c for debugging set ishow_warn to 1
c     ishow_warn = 1

      if (ishow_warn .eq. 1) then

          write(interfil,9001)
          call writloga('default',1,interfil,0,ierrdum)
          write(interfil,9020)
          call writloga('default',0,interfil,1,ierrdum)

          write(interfil,9021)
          call writloga('default',0,interfil,0,ierrdum)

          write(interfil,9022)
          call writloga('default',0,interfil,0,ierrdum)

          write(interfil,9023)
          call writloga('default',0,interfil,0,ierrdum)

          write(interfil,9020)
          call writloga('default',1,interfil,0,ierrdum)
          write(interfil,9001)
          call writloga('default',0,interfil,1,ierrdum)

 9020   format(20x,'WARNING WARNING WARNING WARNING WARNING')
 9021   format(20x,'LaGriT code expiration date has passed.')
 9022   format(20x,'  This version is no longer supported.')
 9023   format(20x,'    Visit:  http://lagrit.lanl.gov')

c         no longer end here, just give warning
c         call termcode()
      endif

C
C     *****************************************************************
C
C     WRITE NAME OF BATCH LOG FILE TO LOG FILES.
C
      write(interfil,9100) logbat(1:icharlnf(logbat))
      call writloga('default',1,interfil,0,ierrdum)
 9100 format('Output log file: ',a)
      write(interfil,9110) loglog(1:icharlnf(loglog))
      call writloga('default',0,interfil,1,ierrdum)
 9110 format('Command log file: ',a)
C
C     *****************************************************************
C
      return
      end

max_stars_repo_name: daniellivingston/LaGriT-Windows

max_issues_repo_name: daniellivingston/LaGriT-Windows

max_forks_repo_name: daniellivingston/LaGriT


text:
! ###################################################################
! Copyright (c) 2013-2021, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMlatgeom.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMlatgeom
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief general lattice geometry computations
!
!> @details  not meant to be an all encompassing program; simply an illustration of how
!> to do crystallographic computations.
!
!> @date 01/05/99 MDG 1.0 original
!> @date 05/21/01 MDG 2.0 f90
!> @date 04/16/13 MDG 3.0 rewrite
!> @date 06/13/14 MDG 4.0 rewrite without global variables
!--------------------------------------------------------------------------
program EMlatgeom

use local
use io
use files
use HDFsupport
use crystal
use constants

integer(kind=irg)        	:: isel,another, oi_int(3)
real(kind=sgl)           	:: v1(3),v2(3),vc(3),p,q,r, oi_real(1)
character(1)             	:: sp,sp2
character(fnlen)		:: progname, progdesc, gname
type(unitcell)        		:: cell
logical				:: loadingfile

 progname = 'EMlatgeom.f90'
 progdesc = 'Simple lattice geometry program'
 call EMsoft(progname, progdesc)

! deal with the command line arguments, if any
 call Interpret_Program_Arguments(1,(/ 914 /), progname)

! load crystal structure data
 call ReadValue(' Enter xtal file name : ', gname,"(A)")
 cell%fname = trim(gname)
 call CrystalData(cell)

! set up loop
 another=1
 do while (another.eq.1)
  call PrintMenu(isel)
  sp='d'
  if (mod(isel,2).eq.0) sp='r'
  if (isel.lt.3) then
   call ReadValue('    Enter vector components : ', v1, 3)
   oi_real(1) = CalcLength(cell,v1,sp)
   if (sp.eq.'d') then
    call WriteValue(' -> Length [nm] = ', oi_real, 1, "(2x,F10.6)")
   else
    call WriteValue(' -> Length [nm-1] = ', oi_real, 1, "(2x,F10.6)")
   end if
  else
   call ReadValue('    Enter first vector components : ', v1, 3)
   call ReadValue('    Enter second vector components : ', v2, 3)
   if (isel.lt.5) then
    p = CalcLength(cell,v1,sp)
    q = CalcLength(cell,v2,sp)
    r = CalcDot(cell,v1,v2,sp)
    oi_real(1) = CalcAngle(cell,v1,v2,sp)*180.0/cPi
    call WriteValue(' -> Angle [deg] = ', oi_real, 1, "(2x,F8.4)")
   else
    if (sp.eq.'d') sp2='r'
    if (sp.eq.'r') sp2='d'
    call CalcCross(cell,v1,v2,vc,sp,sp2,0)
    oi_int(1:3)=int(vc(1:3))
    if (sp.eq.'d') then
     call WriteValue(' ', oi_int, 3, "(' -> p x q = (',2(i3,1x),i3,')')")
    else
     call WriteValue(' ', oi_int, 3, "(' -> p x q = [',2(i3,1x),i3,']')")
    end if
   end if
  end if
  call ReadValue(' Another computation? (1/0) : ', oi_int, 1)
  another = oi_int(1)
 end do

end program EMlatgeom

!--------------------------------------------------------------------------
!
! SUBROUTINE: PrintMenu
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief Print a menu and return a selection
!
!> @param isel seletion number
!
!> @date 01/05/99 MDG 1.0 original
!> @date 05/21/01 MDG 2.0 f90
!> @date 04/16/13 MDG 3.0 rewrite
!> @date 06/13/14 MDG 4.0 rewrite without global variables
!--------------------------------------------------------------------------
subroutine PrintMenu(isel)

use local
use io

integer(kind=irg),INTENT(OUT)  	:: isel	!< selection
integer(kind=irg)		:: io_int(1)

 call Message(' Select from the following options: ', frm = "(A/)")
 call Message(' [1] length of direct space vector', frm = "(A)")
 call Message(' [2] length of reciprocal space vector', frm = "(A)")
 call Message(' [3] angle between direct space vectors', frm = "(A)")
 call Message(' [4] angle between reciprocal space vectors', frm = "(A)")
 call Message(' [5] cross product, direct space vectors', frm = "(A)")
 call Message(' [6] cross product, reciprocal space vectors', frm = "(A/)")
 call ReadValue('    Enter selection: ', io_int, 1)
 isel = io_int(1)

end subroutine PrintMenu

max_stars_repo_name: josephtessmer/EMsoft

max_stars_repo_licenses: Intel Unlicense MIT-CMU BSD-3-Clause

max_issues_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense

max_forks_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense


text:
Obesity Treatment Center is a multidisciplinary weight treatment program serving obese patients in Sacramento since 1983 and Davis since 2004. They use longterm behavioral therapy combined with a medicallysupervised diet. Their team of physicians, behaviorists, dietitians, therapists and exercise physiologists work to help obese patients lose and maintain their weight, treating obesity as a chronic disease of abnormal energy storage and not a lack of willpower.

In June 2006, OTC began a weight management program for those that are overweight, but not obese (body mass index below 30), called the Quick 20 Program  it is designed for clients to lose weight conveniently and quickly under clinical supervision and using OTCs nutrition shakes. Information sessions on OTCs Davis programs are offered every Tuesday at 6:15pm; call for reservations. New patients must submit an application, available in pdf form on their website.

Dr. John D. Hernried, M.D., F.A.C.P. directs Obesity Treatment Center, is boardcertified in Internal Medicine, a member of the American Society of Bariatric Physicians, North American Association for the Study of Obesity and a Fellow of the American College of Physicians. Dr. Hernried additionally serves as Assistant Clinical Professor in the Department of Medicine, UC Davis, and did his residency in Internal Medicine at UC Davis after graduating Texas Tech. He has been Medical Director at OTC since 1999, while practicing internal medicine at Sutter West Medical Group then Kaiser Permanente. Today, he works full time for Obesity Treatment Center. Other staff include seven behavioral educators, a registered dietician, five exercise physiologists, ten medical doctors and two nurse practitioners. Background information on most staff members can be found on the http://www.keepitoff.com/about/otc_our_staff.htm OTC site.

See our Gyms & Fitness page to find out about other fitness opportunities in the Davis area.

20081021 15:43:17 nbsp I have not experienced this place, but just after looking at their website, they recommend a 1,000 calorie liquid diet plan for people who are not obese but over weight.  Its a low calorie ketogenic diet plan much like Atkins was designed for, less carbs more protein, burn ketones.

Honestly?  That sounds like the worst thing I have heard for someone who only needs to lose 1020 lbs!  I cant believe it!  Obesity Treatment Center is prehistoric when it comes to scientifically proven methodology.  If you are looking to lose weight and Keep It Off go see a real dietitian and join the gym a couple nights a week... Users/CarrieBishop

20090922 13:39:54 nbsp Ok, so the only other comment comes from someone who has NEVER used OTC. I actually have, and have a good friend who has experienced success on their program. The diet is closely supervised by DOCTORS and NURSE PRACTIONERS (not just by dieticians as rec by CarrieBishop). I have tried a LONG time to lose my extra 20 pounds and her advice blows. If you are overweight, give their program a serious shot. I am happy I did! Users/Leslie1200

20101112 00:12:03 nbsp Today obesity has become a major problem in many people around. May be due to the eating habits and the daily lifestyle changes. Some are hereditary but many are due to large consumption of junk food and low amount of physical workout. There are many treatments available for obese people. The simplest step to start lessening the obesity problem is by your own effort in loosening the extra fats in your body either by exercise or by changing your eating habits.
http://www.fightobesity.net/treatmentsforobesity.html
 Users/jadesmith

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!RUN: %flang -gdwarf-5 -S -emit-llvm %s -o - | FileCheck %s

!CHECK: !"Dwarf Version", i32 5

program main
  print *, "hello world !!"
end program main

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
These are the final results from the November 2006 Election. State returns are available http://vote.ss.ca.gov/ here. Yolo County returns are available at http://www.yoloelections.org/returns.

Voter turnout:

These are the countywide numbers with statewide percentage in parentheses, if applicable. Colors indicate the statewide result.  indicates incumbent.

 Local Measures

 Local Representatives

 Other State Offices

 Judicial Offices
 Associate Justice of the Supreme Court
 Associate Justice of the Court of Appeal (3rd District)

 State Propositions

Does anyone know what happens now since Measure H passed, but Measure I failed? Does that mean both failed? I dont know myself because they seemed like they were both needed together in order to work. Molnar

 They both need to pass or it fails.   Users/SteveOstrowski

 Even if both H and I passed, Sacramento torpedoed the whole thing by rejecting measure L.  Users/WilliamLewis

20061109 10:38:11 nbsp Sacramento rejected it because of a number of reasons, including the fact that an annexation of Yolo might increase prices in Sac, and (unfortunately), because of measures Q and R, the arena tax. Most voters were looking at that instead of anything else. Users/AngelaPourtabib


text:
! RUN: bbc -emit-fir %s -o - | FileCheck %s

! Test character scalar concatenation lowering

! CHECK-LABEL: concat_1
subroutine concat_1(a, b)
  ! CHECK-DAG: %[[a:.*]]:2 = fir.unboxchar %arg0
  ! CHECK-DAG: %[[b:.*]]:2 = fir.unboxchar %arg1
  character(*) :: a, b

  ! CHECK: call @{{.*}}BeginExternalListOutput
  print *, a // b
  ! Concatenation

  ! CHECK: %[[len:.*]] = arith.addi %[[a]]#1, %[[b]]#1
  ! CHECK: %[[temp:.*]] = fir.alloca !fir.char<1,?>(%[[len]] : index)

  ! CHECK-DAG: %[[c1:.*]] = arith.constant 1
  ! CHECK-DAG: %[[a2:.*]] = fir.convert %[[a]]#1
  ! CHECK: %[[count:.*]] = arith.muli %[[c1]], %[[a2]]
  ! CHECK-DAG: constant false
  ! CHECK-DAG: %[[to:.*]] = fir.convert %[[temp]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
  ! CHECK-DAG: %[[from:.*]] = fir.convert %[[a]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
  ! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[to]], %[[from]], %[[count]], %false) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()

  ! CHECK: %[[c1_0:.*]] = arith.constant 1
  ! CHECK: %[[count2:.*]] = arith.subi %[[len]], %[[c1_0]]
  ! CHECK: fir.do_loop %[[index2:.*]] = %[[a]]#1 to %[[count2]] step %[[c1_0]] {
    ! CHECK: %[[b_index:.*]] = arith.subi %[[index2]], %[[a]]#1
    ! CHECK: %[[b_cast:.*]] = fir.convert %[[b]]#0
    ! CHECK: %[[b_addr:.*]] = fir.coordinate_of %[[b_cast]], %[[b_index]]
    ! CHECK-DAG: %[[b_elt:.*]] = fir.load %[[b_addr]]
    ! CHECK: %[[temp_cast2:.*]] = fir.convert %[[temp]]
    ! CHECK: %[[temp_addr2:.*]] = fir.coordinate_of %[[temp_cast2]], %[[index2]]
    ! CHECK: fir.store %[[b_elt]] to %[[temp_addr2]]
  ! CHECK: }

  ! IO runtime call
  ! CHECK-DAG: %[[raddr:.*]] = fir.convert %[[temp]]
  ! CHECK-DAG: %[[rlen:.*]] = fir.convert %[[len]]
  ! CHECK: call @{{.*}}OutputAscii(%{{.*}}, %[[raddr]], %[[rlen]])
end subroutine

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


      subroutine pl_nfix

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine estimates nitrogen fixation by legumes

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    uno3d       |kg N/ha       |plant nitrogen deficiency for day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Max, Min

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : uno3d, nplnt, ihru, fixn, ipl
      use soil_module
      use plant_module
      use plant_data_module

      implicit none

      integer :: j           !none      |hru number
      integer :: l           !none      |counter (soil layer)
      integer :: idp         !none      |plant number from plants.plt
      real :: uno3l          !kg N/ha   |plant nitrogen demand
      real :: fxw            !          |
      real :: sumn           !kg N/ha   |total amount of nitrate stored in soil profile
      real :: fxn            !          |
      real :: fxg            !          |
      real :: fxr            !          |

      j = ihru
      idp = pcom(j)%plcur(ipl)%idplt

!! compute the difference between supply and demand
      if (uno3d(ipl) > nplnt(j)) then
        uno3l = uno3d(ipl) - nplnt(j)
      else
        !! if supply is being met, fixation=0 and return
        fixn = 0.
        return
      endif

!! compute fixation as a function of no3, soil water, and growth stage

      !! compute soil water factor
      fxw = soil(j)%sw / (.85 * soil(j)%sumfc)

      !! compute no3 factor
      sumn = 0.
      fxn = 0.
      do l = 1, soil(j)%nly
        sumn = sumn + soil1(j)%mn(l)%no3
      end do
      if (sumn > 300.) fxn = 0.
      if (sumn > 100. .and. sumn <= 300.) fxn = 1.5 - .0005 * sumn
      if (sumn <= 100.) fxn = 1.

      !! compute growth stage factor
      fxg = 0.
      if (pcom(j)%plcur(ipl)%phuacc > .15 .and. pcom(j)%plcur(ipl)%phuacc <= .30) then
          fxg = 6.67 * pcom(j)%plcur(ipl)%phuacc - 1.
      endif
      if(pcom(j)%plcur(ipl)%phuacc > .30 .and. pcom(j)%plcur(ipl)%phuacc <= .55) fxg = 1.
      if (pcom(j)%plcur(ipl)%phuacc > .55 .and. pcom(j)%plcur(ipl)%phuacc <= .75) then
         fxg = 3.75 - 5. * pcom(j)%plcur(ipl)%phuacc
      endif

      fxr = Min(1., fxw, fxn) * fxg
      fxr = Max(0., fxr)

      fixn = Min(6., fxr * uno3l)
      fixn = pldb(idp)%nfix_co * fixn + (1. - pldb(idp)%nfix_co) * uno3l
             !! if bsn_prm%fixco = 0 then fix the entire demand
      fixn = Min(fixn, uno3l)
      fixn = Min(bsn_prm%nfixmx, fixn)

      return
      end subroutine pl_nfix


text:
      subroutine read_env_gamess(orb_info)

      implicit none

      include 'ioparam.h'
      include 'stdunit.h'
      include 'def_filinf.h'
      include 'def_orbinf.h'
      include 'ifc_baserout.h'
      include 'par_gamess.h'
      include 'ifc_input.h'

      integer, parameter ::
     &     ntest =  00
      real(8), parameter ::
     &     thr_auto_freeze = -2.5d0

      type(orbinf) ::
     &     orb_info

      type(filinf) ::
     &     ffdict

      integer, parameter ::
     &     mxsym = 8
      integer ::
     &     ludict, iprint, ngas, idx, jdx, nspin, nsym, isym,
     &     mxirrep, lsym, nactel, ispin, nstate, igroup,
     &     nfro(mxsym), nrhf(mxsym), nash(mxsym), norb(mxsym)
      logical ::
     &     isgroup(8)
      character(3) ::
     &     groups(8), irreps(8)

      ! 64 bit version of GAMESS writes integer*8
      integer(8) ::
     &     irecst,ioda(len_da),ifilen(len_da),is,ipk,
     &     nfroz,nocct,n_act,norbs,norbt,num1
      real(8) ::
     &     potnuc,emcscf,sz,s2,etot2,eerd,e1,e2,ven,vee,epot,
     &     eelct,ekin,estate(mxrt),statn,ecore

      real(8), pointer ::
     &     orb_en(:)
      integer(8), pointer ::
     &     orb_sym(:)
      character(len=8), pointer ::
     &     orb_lab(:)

      groups(1:8) = (/'C1 ','Ci ','Cs ','C2 ','C2v','C2h','D2 ','D2h'/)

      iprint = max(iprlvl,ntest)

      ! open direct access file DICTNRY
      call file_init(ffdict,dictnry,ftyp_da_unf,irecln)
      call file_open(ffdict)

      ludict = ffdict%unit

      ! read first record: information about where to find which record
      read (ludict,rec=1) irecst,ioda,ifilen,is,ipk
c dbg
c      print *,'first record from DICTNRY. irecst,is,ipk:',irecst,is,ipk
c      print *,'          ii        ioda        nrec      ifilen'
c      print *,'------------------------------------------------'
c      do idx=1,len_da
c       if (ioda(idx).ge.0)
c     &     write(lulog,'(x,4i12)') idx, ioda(idx),
c     &                             ifilen(idx)/irecln+1, ifilen(idx)
c      end do
c dbgend

      ! read energy quantities
      read (ludict,rec=ioda(6)) potnuc,eelct,etot2,sz,s2,ecore,emcscf,
     &                          eerd,e1,e2,ven,vee,epot,ekin,
     &                          estate,statn
      ispin = nint(2d0*s2)+1
      nstate = nint(statn)

      ! read number of orbital parameters
      read (ludict,rec=ioda(5)) nfroz,nocct,n_act,norbs,norbt,num1
      ! unpack number of electrons and irrep
      lsym = mod(num1,1000)
      nactel = num1/1000 - 2*nocct !what if nfroz>0 ???

      ! read orbital energies and set up proposal for frozen core
      allocate(orb_en(norbt),orb_sym(norbt),orb_lab(norbt))
      read (ludict,rec=ioda(17)) orb_en(1:norbt)
      read (ludict,rec=ioda(262)) orb_sym(1:norbt)
      read (ludict,rec=ioda(324)) orb_lab(1:norbt)
c      ! now get nsym (lowest possible 2^n number):
c      mxirrep = maxval(orb_sym(1:norbt))
c      nsym = mxsym
c      do while (nsym/2.ge.mxirrep)
c        nsym = nsym/2
c      end do

      ! For a strange (?) reason, GAMESS may mess up the irrep numbers
      ! for the orbitals. So let's restore them by help of the labels.
      ! First try to recognize point group
      isgroup(1:8) = .true. ! stands for: C1,Ci,Cs,C2,C2v,C2h,D2,D2h
      do idx = 1, norbt
        select case(trim(orb_lab(idx)))
        case('A') ! not Ci,Cs,C2v,C2h,D2h
          isgroup(2:3) = .false.
          isgroup(5:6) = .false.
          isgroup(8) = .false.
        case('AG','AU') ! not C1,Cs,C2,C2v,D2
          isgroup(1) = .false.
          isgroup(3:5) = .false.
          isgroup(7) = .false.
        case('A''','A''''') ! only Cs
          isgroup(1:2) = .false.
          isgroup(4:8) = .false.
        case('B') ! only C2
          isgroup(1:3) = .false.
          isgroup(5:8) = .false.
        case('A1','A2') ! only C2v
          isgroup(1:4) = .false.
          isgroup(6:8) = .false.
        case('B1','B2') ! only C2v or D2
          isgroup(1:4) = .false.
          isgroup(6) = .false.
          isgroup(8) = .false.
        case('BU','BG') ! only C2h
          isgroup(1:5) = .false.
          isgroup(7:8) = .false.
        case('B3') ! only D2
          isgroup(1:6) = .false.
          isgroup(8) = .false.
        case('B1G','B2G','B3G','B1U','B2U','B3U') ! only D2h
          isgroup(1:7) = .false.
        case default
          call quit(1,'read_env_gamess',
     &              'unknown irrep label: '//trim(orb_lab(idx)))
        end select
      end do
      isym = 0
      do idx = 1, 8
        if (isgroup(idx)) then
          isym = isym + 1
          if (isym.eq.1) igroup = idx !try first possibility
        end if
      end do
      if (isym.ne.1.and.igroup.ne.1) call warn('read_env_gamess',
     &       'Could not unambiguously identify point group!')

      ! irrep numbers as in GAMESS manual (for $DET):
      irreps(1:8) = '   '
      select case(igroup)
      case(1)
        nsym = 1
        irreps = (/'A  ','   ','   ','   ','   ','   ','   ','   '/)
      case(2)
        nsym = 2
        irreps = (/'AG ','AU ','   ','   ','   ','   ','   ','   '/)
      case(3)
        nsym = 2
        irreps = (/"A' ","A''",'   ','   ','   ','   ','   ','   '/)
      case(4)
        nsym = 2
        irreps = (/'A  ','B  ','   ','   ','   ','   ','   ','   '/)
      case(5)
        nsym = 4
        irreps = (/'A1 ','A2 ','B1 ','B2 ','   ','   ','   ','   '/)
      case(6)
        nsym = 4
        irreps = (/'AG ','BU ','BG ','AU ','   ','   ','   ','   '/)
      case(7)
        nsym = 4
        irreps = (/'A  ','B1 ','B2 ','B3 ','   ','   ','   ','   '/)
      case(8)
        nsym = 8
        irreps = (/'AG ','B1G','B2G','B3G','AU ','B1U','B2U','B3U'/)
      case default
        call quit(1,'read_env_gamess','impossible.')
      end select

      do idx = 1, norbt
        do isym = 1, nsym
          if (trim(orb_lab(idx)).eq.trim(irreps(isym))) then
            orb_sym(idx) = isym
            exit
            if (isym.eq.nsym) call quit(1,'read_env_gamess',
     &               'There must be an error in this routine')
          end if
        end do
      end do
      deallocate(orb_lab)
c dbg
c      print *,'   orbital  symmetry    energy'
c      print *,'------------------------------'
c      do idx = 1, norbt
c        write(lulog,'(x,2i10,f10.6)') idx,orb_sym(idx),orb_en(idx)
c      end do
c dbgend

      ! though irrep indices may differ from other codes
      ! (e.g. for C2v irrep order is A1 A2 B1 B2)
      ! the multiplication table should be the same as in multd2h.h.

      nfro = 0
      nrhf = 0
      nash = 0
      norb = 0
      do idx = 1, norbt
        isym = orb_sym(idx)
        norb(isym) = norb(isym) + 1
        if (idx.le.nfroz) nfro(isym) = nfro(isym) + 1
        if (idx.le.nocct) nrhf(isym) = nrhf(isym) + 1
        if (idx.gt.nocct.and.idx.le.nocct+n_act)
     &             nash(isym) = nash(isym) + 1
      end do

      ! GAMESS sorts orbitals according to energy so it's easy
      ! to set up irrep array for orbitals.
      ! we set it up for all orbitals since we need this information
      ! in set_orbinf
      ! find bound orbitals:
      orb_info%n_bound_orbs = norbt
      do idx = 1, norbt
        if (orb_en(idx).ge.thr_auto_freeze) exit
        orb_info%n_freeze_rcmd = orb_info%n_freeze_rcmd+1
      end do

      ! just copy from orb_sym:
      allocate(orb_info%isym_bound_orbs(orb_info%n_bound_orbs))
      orb_info%isym_bound_orbs(1:orb_info%n_bound_orbs)
     &      = orb_sym(1:orb_info%n_bound_orbs)

      deallocate(orb_en,orb_sym)

      if (iprint.ge.50) then
        write(lulog,*) 'data from DICTNRY:'
        write(lulog,*) 'potnuc= ',potnuc
        write(lulog,*) 'eelct = ',eelct
        write(lulog,*) 'etot2 = ',etot2
        write(lulog,*) 'emcscf= ',emcscf
        write(lulog,*) 'ecore = ',ecore
        write(lulog,*) 'estate= ',estate(1:nstate)
        write(lulog,*) 'nstate= ',nstate
        write(lulog,*) 'mult  = ',ispin
        write(lulog,*) 'Ms    = ',sz
        write(lulog,*) 'nactel= ',nactel
        write(lulog,*) 'lsym  = ',lsym
        write(lulog,*) 'symm. = ',groups(igroup)
        write(lulog,*) 'nsym  = ',nsym
        write(lulog,*) 'nfroz = ',nfroz
        write(lulog,*) 'nocct = ',nocct
        write(lulog,*) 'n_act = ',n_act
        write(lulog,*) 'norbs = ',norbs
        write(lulog,*) 'norbt = ',norbt
        write(lulog,'(x,a,8i4)') 'nfro   = ',nfro(1:8)
        write(lulog,'(x,a,8i4)') 'nrhf   = ',nrhf(1:8)
        write(lulog,'(x,a,8i4)') 'nash   = ',nash(1:8)
        write(lulog,'(x,a,8i4)') 'norb   = ',norb(1:8)
        write(lulog,'(x,a)') 'sym_bound_orbs:'
        write(lulog,'(x,10i4)') orb_info%isym_bound_orbs
        write(lulog,'(x,a,i4)')  'n_freeze_rcmd: ',
     &       orb_info%n_freeze_rcmd
      end if

      call file_close_keep(ffdict)

      nspin = 1
      ngas = 2
      if (nfroz.gt.0) ngas = ngas+1
      orb_info%nactel = nactel
      orb_info%nactorb = n_act
      orb_info%lsym = lsym
      orb_info%imult = ispin
      orb_info%ims = nint(2*sz)
      if (n_act.gt.0) then
        ! test whether this can be treated as a simple
        ! high spin open shell case:
        if (.false..and.nactel.eq.n_act.and.ispin.eq.nactel+1) then
          ! we should check the symmetry here ...
          write(lulog,*) 'high-spin valence shell detected'
          ngas = ngas+1
          nspin = 2
        else
          write(lulog,*) 'valence shell is not high-spin ...'
c let pass to enable CAS calculations
          ngas = ngas+1
        end if
      end if

      orb_info%nspin = nspin
      orb_info%nsym = nsym
      orb_info%ngas = ngas
      orb_info%ntoob = norbt
      orb_info%nbast = norbt ! number of BF = number of orbs (correct?)
      orb_info%nxbast = 0
      orb_info%caborb = 0

      ! use the data to initialize orb_info structure
      allocate(orb_info%nbas(nsym),
     &     orb_info%ntoobs(nsym),orb_info%igassh(nsym,ngas),
     &     orb_info%iad_gas(ngas),orb_info%ihpvgas(ngas,nspin))
      allocate(orb_info%cab_orb(nsym),
     &              orb_info%nxbas(nsym) )

      orb_info%nbas(1:nsym) = norb(1:nsym) ! sym of BF = sym of orbs (?)
      orb_info%ntoobs(1:nsym) = norb(1:nsym)
      if (nfroz.gt.0) then
        ! not sure whether GAMESS' frozen orbitals are what we want
        call quit(1,'read_env_gamess',
     &       'check first what GAMESS means by freezing orbitals!')
        orb_info%iad_gas(1:ngas) = (/1,2,2/)
        orb_info%ihpvgas(1:ngas,1) = (/1,1,2/)
        orb_info%igassh(1:nsym,1) = nfro(1:nsym)
        orb_info%igassh(1:nsym,2) = nrhf(1:nsym)-nfro(1:nsym)
        orb_info%igassh(1:nsym,3) = norb(1:nsym)-nrhf(1:nsym)
      else
        if (nspin.eq.1.and.n_act.eq.0) then
          orb_info%iad_gas(1:ngas) = (/2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = norb(1:nsym)-nrhf(1:nsym)
        else if (nspin.eq.1) then
          orb_info%iad_gas(1:ngas) = (/2,2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,3,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = nash(1:nsym)
          orb_info%igassh(1:nsym,3)
     &                  = norb(1:nsym)-nrhf(1:nsym)-nash(1:nsym)
        else
          orb_info%iad_gas(1:ngas) = (/2,2/)
          orb_info%ihpvgas(1:ngas,1) = (/1,1,2/)
          orb_info%ihpvgas(1:ngas,2) = (/1,2,2/)
          orb_info%igassh(1:nsym,1) = nrhf(1:nsym)
          orb_info%igassh(1:nsym,2) = nash(1:nsym)
          orb_info%igassh(1:nsym,3) =
     &         norb(1:nsym)-nrhf(1:nsym)-nash(1:nsym)
        end if
      end if
      orb_info%cab_orb(1:nsym)=0
      orb_info%nxbas(1:nsym)=0

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
subroutine oceflx(pmidm1, ubot, vbot, tbot, qbot, thbot, zbot, ts, &
                  shf, lhf, taux, tauy, ssq, lhf_coef, ustar, u10n )

use params, only: salt_factor
implicit none

!
! Compute ocean to atmosphere surface fluxes of sensible, latent heat
! and stress components:
!
! Assume:
!   1) Neutral 10m drag coeff:
!         cdn = .0027/U10N + .000142 + .0000764 U10N
!   2) Neutral 10m stanton number:
!         ctn = .0327 sqrt(cdn), unstable
!         ctn = .0180 sqrt(cdn), stable
!   3) Neutral 10m dalton number:
!         cen = .0346 sqrt(cdn)
!
! Note:
!   1) here, tstar = <WT>/U*, and qstar = <WQ>/U*.
!   2) wind speeds should all be above a minimum speed (umin)
!
!--------------------------Code History---------------------------------
!
! Original:      Bill Large/M.Vertenstein, Sep. 1995 for CCM3.5
! Standardized:  L. Buja,     Feb 1996
! Reviewed:      B. Briegleb, March 1996
! Adopted for LES by Marat Khairoutdinov, July 1998
!
! P. Blossey, 2015,2018: Added outputs for lhf_coef, ustar and u10n.
!    Useful for computing surface fluxes of water isotopes, aerosols.
!
!------------------------------Arguments--------------------------------
!
! Input arguments
!
!
      real pmidm1  ! Bottom level pressure, mb
      real ubot    ! Bottom level u wind
      real vbot    ! Bottom level v wind
      real tbot    ! Bottom level temperature
      real qbot    ! Bottom level specific humidity
      real thbot   ! Bottom level potential temperature ---> SEE NOTE BELOW.
      real zbot    ! Bottom level height above surface
      real ts      ! Surface temperature
!
!bloss(2015-01-09): !!NOTE!! that liquid-ice static energy at the surface
!   is input into this routine in SAM rather than potential temperature.
!   As written, the potential temperature would only work if the surface
!   pressure were used as the reference pressure in place of the usual
!   1000 hPa.
!
! Output arguments
!
      real shf     ! Initial sensible heat flux (Km/s)
      real lhf     ! Initial latent heat flux (m/s)
      real taux    ! X surface stress (N/m2)
      real tauy    ! Y surface stress (N/m2)
      real ssq     ! Surface saturation specific humidity
      real lhf_coef ! coefficient of delq in lhf (useful for isotope fluxes)
      real ustar          ! ustar
      real u10n           ! neutral 10 m wind speed over ocean !bloss(2018-02): Added to outputs
!
!---------------------------Local variables-----------------------------
!
      real tref    	  ! 2m reference temperature
      real tstar          ! tstar
      real qstar          ! qstar
      real vmag           ! Surface wind magnitude
      real thvbot         ! Bottom lev virtual potential temp
      real delt           ! potential T difference (K)
      real delq           ! specific humidity difference (kg/kg)
      real rdn            ! sqrt of neutral exchange coeff (momentum)
      real rhn            ! sqrt of neutral exchange coeff (heat)
      real ren            ! sqrt of neutral exchange coeff (tracers)
      real rd             ! sqrt of exchange coeff (momentum)
      real rh             ! sqrt of exchange coeff (heat)
      real re             ! sqrt of exchange coeff (tracers)
      real hol            ! Ref hgt (10m) / monin-obukhov length
      real xsq            ! Temporary variable
      real xqq            ! Temporary variable
      real alz            ! ln(zbot/z10)
      real cp             ! Specific heat of moist air
      real tau     ! Reference height stress
      real psimh          ! Stability funct at ref lev (momentum)
      real psixh          ! Stability funct at ref lev (heat & tracers)
      real stable         ! Stability factor
      real rbot    	  ! Density at bottom model level
      real bn             ! exchange coef funct for interpolation
      real bh             ! exchange coef funct for interpolation
      real fac            ! interpolation factor
      real ln0            ! log factor for interpolation
      real ln3            ! log factor for interpolation
      real ztref          ! reference height for air temperature
      real gravit	  ! =9.81 m/s2
      real ltheat  	  ! Latent heat for given srf conditions

      real xkar     ! Von Karman constant
      real zref     ! 10m reference height
      real umin     ! Minimum wind speed at bottom level

      parameter  (xkar = 0.4 , &
            zref =   10.0      , &
            umin =    1.0, &
            ztref=2.0 )

      real qsatw, qsati
      external qsatw

!--------------------------Statement functions--------------------------

      real psimhu         ! Unstable part of psimh
      real psixhu         ! Unstable part of psixh
      real cdn            ! Neutral drag coeff at bottom model level
      real xd             ! Dummy argument
      real Umps           ! Wind velocity (m/sec)

      cdn(Umps)  = 0.0027 / Umps + .000142 + .0000764 * Umps
      psimhu(xd) = log((1.+xd*(2.+xd))*(1.+xd*xd)/8.) - 2.*atan(xd) + 1.571
      psixhu(xd) = 2. * log((1. + xd*xd)/2.)

!---------------------------------------------------------------
! Set up necessary variables
!---------------------------------------------------------------

         rbot = pmidm1*100.  / (287.*tbot )
         vmag   = max(umin, sqrt(ubot **2+vbot **2))
         thvbot = thbot  * (1.0 + 0.606*qbot )
         delt   = thbot  - ts
         if(ts.gt.271.) then
	   ssq = salt_factor*qsatw(ts,pmidm1)
         else
	   ssq = qsati(ts,pmidm1)
         end if
         delq   = qbot  - ssq
         alz    = log(zbot /zref)
         cp     = 1005.
	 gravit = 9.81
	 ltheat = 2.51e6
!---------------------------------------------------------------
! First iteration to converge on Z/L and hence the fluxes
!---------------------------------------------------------------

! Initial guess for roots of neutral exchange coefficients,
! assume z/L=0. and u10n is approximated by vmag.
! Stable if (thbot > ts ).

         stable = 0.5 + sign(0.5 , delt)
         rdn  = sqrt(cdn(vmag))
         rhn  = (1.-stable) * 0.0327 + stable * 0.018
         ren  = 0.0346

! Initial guess of ustar,tstar and qstar

         ustar = rdn*vmag
         tstar = rhn*delt
         qstar = ren*delq

! Compute stability and evaluate all stability functions
! Stable if (thbot > ts or hol > 0 )

         hol = xkar*gravit*zbot*(tstar/thvbot+qstar/(1./0.606+qbot))/ustar**2
         hol = sign( min(abs(hol),10.), hol )
         stable = 0.5 + sign(0.5 , hol)
         xsq   = max(sqrt(abs(1. - 16.*hol)) , 1.)
         xqq   = sqrt(xsq)
         psimh = -5. * hol * stable + (1.-stable)*psimhu(xqq)
         psixh = -5. * hol * stable + (1.-stable)*psixhu(xqq)

! Shift 10m neutral wind speed using old rdn coefficient

         rd   = rdn / (1.+rdn/xkar*(alz-psimh))
         u10n = vmag * rd / rdn

! Update the neutral transfer coefficients at 10m and neutral stability

         rdn = sqrt(cdn(u10n))
         ren = 0.0346
         rhn = (1.-stable) * 0.0327 + stable * 0.018

! Shift all coeffs to measurement height and stability

         rd = rdn / (1.+rdn/xkar*(alz-psimh))
         rh = rhn / (1.+rhn/xkar*(alz-psixh))
         re = ren / (1.+ren/xkar*(alz-psixh))

! Update ustar, tstar, qstar using updated, shifted coeffs

         ustar = rd * vmag
         tstar = rh * delt
         qstar = re * delq

!---------------------------------------------------------------
! Second iteration to converge on Z/L and hence the fluxes
!---------------------------------------------------------------

! Recompute stability & evaluate all stability functions
! Stable if (thbot > ts or hol > 0 )

         hol = xkar*gravit*zbot*(tstar/thvbot+qstar/(1./0.606+qbot))/ustar**2
         hol = sign( min(abs(hol),10.), hol )
         stable = 0.5 + sign(0.5 , hol)
         xsq   = max(sqrt(abs(1. - 16.*hol)) , 1.)
         xqq   = sqrt(xsq)
         psimh = -5. * hol * stable + (1.-stable)*psimhu(xqq)
         psixh = -5. * hol * stable + (1.-stable)*psixhu(xqq)

! Shift 10m neutral wind speed using old rdn coefficient

         rd   = rdn / (1.+rdn/xkar*(alz-psimh))
         u10n = vmag * rd / rdn

! Update the neutral transfer coefficients at 10m and neutral stability

         rdn = sqrt(cdn(u10n))
         ren = 0.0346
         rhn = (1.-stable) * 0.0327 + stable * 0.018

! Shift all coeffs to measurement height and stability

         rd = rdn / (1.+rdn/xkar*(alz-psimh))
         rh = rhn / (1.+rhn/xkar*(alz-psixh))
         re = ren / (1.+ren/xkar*(alz-psixh))

!---------------------------------------------------------------
! Compute the fluxes
!---------------------------------------------------------------

! Update ustar, tstar, qstar using updated, shifted coeffs

         ustar = rd * vmag
         tstar = rh * delt
         qstar = re * delq

! Compute surface stress components

         tau   =  rbot  * ustar * ustar
         taux  = -tau * ubot  / vmag
         tauy  = -tau * vbot  / vmag

! Compute heat flux components at current surface temperature
! (Define positive latent and sensible heat as upwards into the atm)

         shf  = -tau * tstar / ustar / rbot
         lhf  = -tau * qstar / ustar / rbot

         !bloss: coefficient of delq in heat flux.
         lhf_coef = -tau * re / ustar / rbot

!---------------------------------------------------------------
! Following Geleyn(1988), interpolate ts to fixed height zref
!---------------------------------------------------------------

! Compute function of exchange coefficients. Assume that
! cn = rdn*rdn, cm=rd*rd and ch=rh*rd, and therefore
! 1/sqrt(cn )=1/rdn and sqrt(cm )/ch =1/rh

         bn = xkar/rdn
         bh = xkar/rh

! Interpolation factor for stable and unstable cases

         ln0 = log(1.0 + (ztref/zbot )*(exp(bn) - 1.0))
         ln3 = log(1.0 + (ztref/zbot )*(exp(bn - bh) - 1.0))
         fac = (ln0 - ztref/zbot *(bn - bh))/bh * stable &
             + (ln0 - ln3)/bh * (1.-stable)
         fac = min(max(fac,0.),1.)

! Actual interpolation

         tref  = ts  + (tbot  - ts )*fac

end subroutine oceflx

max_stars_repo_name: kbren/uwnet

max_issues_repo_name: kbren/uwnet

max_forks_repo_name: kbren/uwnet


text:
      subroutine linemo(x,y,n,nm,js)
C...subroutine	 linemo	  01/09/78
      common /gftab/irdb(5),rdb(17)
      dimension	x(n),y(n)
      if(irdb(2).lt.2) go to 26
      if(irdb(3).le.0) go to 26
      j	= 0
      xor=rdb(7)
      yor=rdb(8)
      xr=xor+rdb(9)
      yr=yor+rdb(10)
      m=iabs(n)
      k=0
      is=1
      if(js.ge.0) k=1
      ist=iabs(js)
      call where(fx,fy,f)
      call tmf(x(1),y(1),fx1,fy1)
      df=amax1(abs(fx1-fx),abs(fy1-fy))
      call tmf(x(m),y(m),fx1,fy1)
      dl=amax1(abs(fx1-fx),abs(fy1-fy))
      l=1
      inc=1
      if(df.le.dl) go to 7
      l	= m
       inc=-1
   7  do 25  i=1,m
      call tmf(x(l),y(l),fx,fy)
       l=l+inc
      if(n.le.0) go to 18
      fx=amin1(xr,amax1(xor,fx))
      fy=amin1(yr,amax1(yor,fy))
  18  call move(fx,fy,j)
      is=is-1
      if(is.gt.0) go to	25
      call marker(nm)
      is=ist
  25  j=k
      call marker(nm)
  26  return
      end

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


text:
subroutine FormJARFRisotopicTable
    use CommonModJARFR
    allocate(NuclDataCommon(1:99))
    !JUST NUMBER OF ORDER
    do i=1,99
      NuclDataCommon(i)%nucl_order_num = i
    end do
    !INNER ID (FROM AN INPUT FILE)
    NuclDataCommon(1)%nucl_numberID = 1
    NuclDataCommon(2)%nucl_numberID = 2
    NuclDataCommon(3)%nucl_numberID = 18
    NuclDataCommon(4)%nucl_numberID = 5
    NuclDataCommon(5)%nucl_numberID = 4
    NuclDataCommon(6)%nucl_numberID = 6
    NuclDataCommon(7)%nucl_numberID = 7
    NuclDataCommon(8)%nucl_numberID = 9
    NuclDataCommon(9)%nucl_numberID = 10
    NuclDataCommon(10)%nucl_numberID = 11
    NuclDataCommon(11)%nucl_numberID = 12
    NuclDataCommon(12)%nucl_numberID = 14
    NuclDataCommon(13)%nucl_numberID = 15
    NuclDataCommon(14)%nucl_numberID = 16
    NuclDataCommon(15)%nucl_numberID = 19
    NuclDataCommon(16)%nucl_numberID = 23
    NuclDataCommon(17)%nucl_numberID = 24
    NuclDataCommon(18)%nucl_numberID = 27
    NuclDataCommon(19)%nucl_numberID = 28
    NuclDataCommon(20)%nucl_numberID = 31
    NuclDataCommon(21)%nucl_numberID = 32
    NuclDataCommon(22)%nucl_numberID = 35
    NuclDataCommon(23)%nucl_numberID = 39
    NuclDataCommon(24)%nucl_numberID = 40
    NuclDataCommon(25)%nucl_numberID = 48
    NuclDataCommon(26)%nucl_numberID = 51
    NuclDataCommon(27)%nucl_numberID = 52
    NuclDataCommon(28)%nucl_numberID = 55
    NuclDataCommon(29)%nucl_numberID = 56
    NuclDataCommon(30)%nucl_numberID = 57
    NuclDataCommon(31)%nucl_numberID = 59
    NuclDataCommon(32)%nucl_numberID = 64
    NuclDataCommon(33)%nucl_numberID = 70
    NuclDataCommon(34)%nucl_numberID = 89
    NuclDataCommon(35)%nucl_numberID = 91
    NuclDataCommon(36)%nucl_numberID = 93
    NuclDataCommon(37)%nucl_numberID = 96
    NuclDataCommon(38)%nucl_numberID = 99
    NuclDataCommon(39)%nucl_numberID = 103
    NuclDataCommon(40)%nucl_numberID = 108
    NuclDataCommon(41)%nucl_numberID = 109
    NuclDataCommon(42)%nucl_numberID = 112
    NuclDataCommon(43)%nucl_numberID = 113
    NuclDataCommon(44)%nucl_numberID = 122
    NuclDataCommon(45)%nucl_numberID = 131
    NuclDataCommon(46)%nucl_numberID = 135
    NuclDataCommon(47)%nucl_numberID = 133
    NuclDataCommon(48)%nucl_numberID = 143
    NuclDataCommon(49)%nucl_numberID = 145
    NuclDataCommon(50)%nucl_numberID = 147
    NuclDataCommon(51)%nucl_numberID = 149
    NuclDataCommon(52)%nucl_numberID = 151
    NuclDataCommon(53)%nucl_numberID = 150
    NuclDataCommon(54)%nucl_numberID = 152
    NuclDataCommon(55)%nucl_numberID = 155
    NuclDataCommon(56)%nucl_numberID = 157
    NuclDataCommon(57)%nucl_numberID = 156
    NuclDataCommon(58)%nucl_numberID = 158
    NuclDataCommon(59)%nucl_numberID = 162
    NuclDataCommon(60)%nucl_numberID = 163
    NuclDataCommon(61)%nucl_numberID = 179
    NuclDataCommon(62)%nucl_numberID = 171
    NuclDataCommon(63)%nucl_numberID = 181
    NuclDataCommon(64)%nucl_numberID = 176
    NuclDataCommon(65)%nucl_numberID = 197
    NuclDataCommon(66)%nucl_numberID = 207
    NuclDataCommon(67)%nucl_numberID = 209
    NuclDataCommon(68)%nucl_numberID = 232
    NuclDataCommon(69)%nucl_numberID = 211
    NuclDataCommon(70)%nucl_numberID = 213
    NuclDataCommon(71)%nucl_numberID = 233
    NuclDataCommon(72)%nucl_numberID = 234
    NuclDataCommon(73)%nucl_numberID = 235
    NuclDataCommon(74)%nucl_numberID = 236
    NuclDataCommon(75)%nucl_numberID = 238
    NuclDataCommon(76)%nucl_numberID = 227
    NuclDataCommon(77)%nucl_numberID = 229
    NuclDataCommon(78)%nucl_numberID = 246
    NuclDataCommon(79)%nucl_numberID = 248
    NuclDataCommon(80)%nucl_numberID = 239
    NuclDataCommon(81)%nucl_numberID = 240
    NuclDataCommon(82)%nucl_numberID = 241
    NuclDataCommon(83)%nucl_numberID = 242
    NuclDataCommon(84)%nucl_numberID = 201
    NuclDataCommon(85)%nucl_numberID = 202
    NuclDataCommon(86)%nucl_numberID = 203
    NuclDataCommon(87)%nucl_numberID = 222
    NuclDataCommon(88)%nucl_numberID = 223
    NuclDataCommon(89)%nucl_numberID = 224
    NuclDataCommon(90)%nucl_numberID = 225
    NuclDataCommon(91)%nucl_numberID = 226
    NuclDataCommon(92)%nucl_numberID = 228
    NuclDataCommon(93)%nucl_numberID = 214
    NuclDataCommon(94)%nucl_numberID = 215
    NuclDataCommon(95)%nucl_numberID = 218
    NuclDataCommon(96)%nucl_numberID = 301
    NuclDataCommon(97)%nucl_numberID = 302
    NuclDataCommon(98)%nucl_numberID = 303
    NuclDataCommon(99)%nucl_numberID = 304

    !CAPTION
    NuclDataCommon(1)%nucl_Caption = 'H'
    NuclDataCommon(2)%nucl_Caption = 'D'
    NuclDataCommon(3)%nucl_Caption = 'AR'
    NuclDataCommon(4)%nucl_Caption = 'HE-3'
    NuclDataCommon(5)%nucl_Caption = 'HE'
    NuclDataCommon(6)%nucl_Caption = 'LI-6'
    NuclDataCommon(7)%nucl_Caption = 'LI-7'
    NuclDataCommon(8)%nucl_Caption = 'BE'
    NuclDataCommon(9)%nucl_Caption = 'B-10'
    NuclDataCommon(10)%nucl_Caption = 'B-11'
    NuclDataCommon(11)%nucl_Caption = 'C'
    NuclDataCommon(12)%nucl_Caption = 'N'
    NuclDataCommon(13)%nucl_Caption = 'N-15'
    NuclDataCommon(14)%nucl_Caption = 'O'
    NuclDataCommon(15)%nucl_Caption = 'F'
    NuclDataCommon(16)%nucl_Caption = 'NA'
    NuclDataCommon(17)%nucl_Caption = 'MG'
    NuclDataCommon(18)%nucl_Caption = 'AL'
    NuclDataCommon(19)%nucl_Caption = 'SI'
    NuclDataCommon(20)%nucl_Caption = 'P'
    NuclDataCommon(21)%nucl_Caption = 'S'
    NuclDataCommon(22)%nucl_Caption = 'CL'
    NuclDataCommon(23)%nucl_Caption = 'K'
    NuclDataCommon(24)%nucl_Caption = 'CA'
    NuclDataCommon(25)%nucl_Caption = 'TI'
    NuclDataCommon(26)%nucl_Caption = 'V'
    NuclDataCommon(27)%nucl_Caption = 'CR'
    NuclDataCommon(28)%nucl_Caption = 'MN'
    NuclDataCommon(29)%nucl_Caption = 'FE'
    NuclDataCommon(30)%nucl_Caption = 'CO'
    NuclDataCommon(31)%nucl_Caption = 'NI'
    NuclDataCommon(32)%nucl_Caption = 'CU'
    NuclDataCommon(33)%nucl_Caption = 'GA'
    NuclDataCommon(34)%nucl_Caption = 'Y'
    NuclDataCommon(35)%nucl_Caption = 'ZR'
    NuclDataCommon(36)%nucl_Caption = 'NB'
    NuclDataCommon(37)%nucl_Caption = 'MO'
    NuclDataCommon(38)%nucl_Caption = 'TC99'
    NuclDataCommon(39)%nucl_Caption = 'RH'
    NuclDataCommon(40)%nucl_Caption = 'AG'
    NuclDataCommon(41)%nucl_Caption = 'AG09'
    NuclDataCommon(42)%nucl_Caption = 'CD'
    NuclDataCommon(43)%nucl_Caption = 'CD13'
    NuclDataCommon(44)%nucl_Caption = 'SB'
    NuclDataCommon(45)%nucl_Caption = 'XE31'
    NuclDataCommon(46)%nucl_Caption = 'XE35'
    NuclDataCommon(47)%nucl_Caption = 'CS'
    NuclDataCommon(48)%nucl_Caption = 'ND43'
    NuclDataCommon(49)%nucl_Caption = 'ND45'
    NuclDataCommon(50)%nucl_Caption = 'PM47'
    NuclDataCommon(51)%nucl_Caption = 'SM49'
    NuclDataCommon(52)%nucl_Caption = 'SM51'
    NuclDataCommon(53)%nucl_Caption = 'SM52'
    NuclDataCommon(54)%nucl_Caption = 'EU'
    NuclDataCommon(55)%nucl_Caption = 'EU55'
    NuclDataCommon(56)%nucl_Caption = 'GD'
    NuclDataCommon(57)%nucl_Caption = 'GD55'
    NuclDataCommon(58)%nucl_Caption = 'GD57'
    NuclDataCommon(59)%nucl_Caption = 'DY'
    NuclDataCommon(60)%nucl_Caption = 'ER'
    NuclDataCommon(61)%nucl_Caption = 'HF'
    NuclDataCommon(62)%nucl_Caption = 'TA'
    NuclDataCommon(63)%nucl_Caption = 'W'
    NuclDataCommon(64)%nucl_Caption = 'RE'
    NuclDataCommon(65)%nucl_Caption = 'AU'
    NuclDataCommon(66)%nucl_Caption = 'PB'
    NuclDataCommon(67)%nucl_Caption = 'BI'
    NuclDataCommon(68)%nucl_Caption = 'TH32'
    NuclDataCommon(69)%nucl_Caption = 'PA31'
    NuclDataCommon(70)%nucl_Caption = 'PA33'
    NuclDataCommon(71)%nucl_Caption = 'U233'
    NuclDataCommon(72)%nucl_Caption = 'U234'
    NuclDataCommon(73)%nucl_Caption = 'U235'
    NuclDataCommon(74)%nucl_Caption = 'U236'
    NuclDataCommon(75)%nucl_Caption = 'U238'
    NuclDataCommon(76)%nucl_Caption = 'NP37'
    NuclDataCommon(77)%nucl_Caption = 'NP39'
    NuclDataCommon(78)%nucl_Caption = 'PU36'
    NuclDataCommon(79)%nucl_Caption = 'PU38'
    NuclDataCommon(80)%nucl_Caption = 'PU39'
    NuclDataCommon(81)%nucl_Caption = 'PU40'
    NuclDataCommon(82)%nucl_Caption = 'PU41'
    NuclDataCommon(83)%nucl_Caption = 'PU42'
    NuclDataCommon(84)%nucl_Caption = 'AM41'
    NuclDataCommon(85)%nucl_Caption = 'AM2M'
    NuclDataCommon(86)%nucl_Caption = 'AM43'
    NuclDataCommon(87)%nucl_Caption = 'CM42'
    NuclDataCommon(88)%nucl_Caption = 'CM43'
    NuclDataCommon(89)%nucl_Caption = 'CM44'
    NuclDataCommon(90)%nucl_Caption = 'CM45'
    NuclDataCommon(91)%nucl_Caption = 'CM46'
    NuclDataCommon(92)%nucl_Caption = 'CM48'
    NuclDataCommon(93)%nucl_Caption = 'FP35'
    NuclDataCommon(94)%nucl_Caption = 'FP39'
    NuclDataCommon(95)%nucl_Caption = 'SLAG'
    NuclDataCommon(96)%nucl_Caption = 'CAPT'
    NuclDataCommon(97)%nucl_Caption = 'SCAT'
    NuclDataCommon(98)%nucl_Caption = 'D-SC'
    NuclDataCommon(99)%nucl_Caption = 'HYDR'

    !ATOMIC MASS
    NuclDataCommon(1)%nucl_atomic_mass = 1.0079
    NuclDataCommon(2)%nucl_atomic_mass = 2.01410
    NuclDataCommon(3)%nucl_atomic_mass = 39.94800
    NuclDataCommon(4)%nucl_atomic_mass = 3.01603
    NuclDataCommon(5)%nucl_atomic_mass = 4.00260
    NuclDataCommon(6)%nucl_atomic_mass = 6.01510
    NuclDataCommon(7)%nucl_atomic_mass = 7.01600
    NuclDataCommon(8)%nucl_atomic_mass = 9.01220
    NuclDataCommon(9)%nucl_atomic_mass = 10.01290
    NuclDataCommon(10)%nucl_atomic_mass = 11.00930
    NuclDataCommon(11)%nucl_atomic_mass = 12.011
    NuclDataCommon(12)%nucl_atomic_mass = 14.00670
    NuclDataCommon(13)%nucl_atomic_mass = 15.00011
    NuclDataCommon(14)%nucl_atomic_mass = 15.99940
    NuclDataCommon(15)%nucl_atomic_mass = 18.99840
    NuclDataCommon(16)%nucl_atomic_mass = 22.98980
    NuclDataCommon(17)%nucl_atomic_mass = 24.30500
    NuclDataCommon(18)%nucl_atomic_mass = 26.98150
    NuclDataCommon(19)%nucl_atomic_mass = 28.08550
    NuclDataCommon(20)%nucl_atomic_mass = 30.97380
    NuclDataCommon(21)%nucl_atomic_mass = 32.07000
    NuclDataCommon(22)%nucl_atomic_mass = 35.45300
    NuclDataCommon(23)%nucl_atomic_mass = 39.09830
    NuclDataCommon(24)%nucl_atomic_mass = 40.07800
    NuclDataCommon(25)%nucl_atomic_mass = 47.88000
    NuclDataCommon(26)%nucl_atomic_mass = 50.94150
    NuclDataCommon(27)%nucl_atomic_mass = 51.99600
    NuclDataCommon(28)%nucl_atomic_mass = 54.93800
    NuclDataCommon(29)%nucl_atomic_mass = 55.84700
    NuclDataCommon(30)%nucl_atomic_mass = 58.93320
    NuclDataCommon(31)%nucl_atomic_mass = 58.69000
    NuclDataCommon(32)%nucl_atomic_mass = 63.54600
    NuclDataCommon(33)%nucl_atomic_mass = 69.72300
    NuclDataCommon(34)%nucl_atomic_mass = 88.90585
    NuclDataCommon(35)%nucl_atomic_mass = 91.22400
    NuclDataCommon(36)%nucl_atomic_mass = 92.90640
    NuclDataCommon(37)%nucl_atomic_mass = 95.94000
    NuclDataCommon(38)%nucl_atomic_mass = 98.90625
    NuclDataCommon(39)%nucl_atomic_mass = 102.90550
    NuclDataCommon(40)%nucl_atomic_mass = 107.86820
    NuclDataCommon(41)%nucl_atomic_mass = 108.90480
    NuclDataCommon(42)%nucl_atomic_mass = 112.41000
    NuclDataCommon(43)%nucl_atomic_mass = 112.90440
    NuclDataCommon(44)%nucl_atomic_mass = 121.76000
    NuclDataCommon(45)%nucl_atomic_mass = 130.90508
    NuclDataCommon(46)%nucl_atomic_mass = 134.90721
    NuclDataCommon(47)%nucl_atomic_mass = 132.90540
    NuclDataCommon(48)%nucl_atomic_mass = 142.90981
    NuclDataCommon(49)%nucl_atomic_mass = 144.91257
    NuclDataCommon(50)%nucl_atomic_mass = 146.91513
    NuclDataCommon(51)%nucl_atomic_mass = 148.91718
    NuclDataCommon(52)%nucl_atomic_mass = 150.91994
    NuclDataCommon(53)%nucl_atomic_mass = 151.91972
    NuclDataCommon(54)%nucl_atomic_mass = 151.96500
    NuclDataCommon(55)%nucl_atomic_mass = 154.92290
    NuclDataCommon(56)%nucl_atomic_mass = 157.25000
    NuclDataCommon(57)%nucl_atomic_mass = 154.92262
    NuclDataCommon(58)%nucl_atomic_mass = 156.92397
    NuclDataCommon(59)%nucl_atomic_mass = 162.50000
    NuclDataCommon(60)%nucl_atomic_mass = 167.25999
    NuclDataCommon(61)%nucl_atomic_mass = 178.49001
    NuclDataCommon(62)%nucl_atomic_mass = 180.94791
    NuclDataCommon(63)%nucl_atomic_mass = 183.85001
    NuclDataCommon(64)%nucl_atomic_mass = 186.20700
    NuclDataCommon(65)%nucl_atomic_mass = 196.96651
    NuclDataCommon(66)%nucl_atomic_mass = 207.20000
    NuclDataCommon(67)%nucl_atomic_mass = 208.98038
    NuclDataCommon(68)%nucl_atomic_mass = 232.03810
    NuclDataCommon(69)%nucl_atomic_mass = 231.03587
    NuclDataCommon(70)%nucl_atomic_mass = 233.04024
    NuclDataCommon(71)%nucl_atomic_mass = 233.03960
    NuclDataCommon(72)%nucl_atomic_mass = 234.04089
    NuclDataCommon(73)%nucl_atomic_mass = 235.04390
    NuclDataCommon(74)%nucl_atomic_mass = 236.04559
    NuclDataCommon(75)%nucl_atomic_mass = 238.05080
    NuclDataCommon(76)%nucl_atomic_mass = 237.04817
    NuclDataCommon(77)%nucl_atomic_mass = 239.05293
    NuclDataCommon(78)%nucl_atomic_mass = 236.04605
    NuclDataCommon(79)%nucl_atomic_mass = 238.04961
    NuclDataCommon(80)%nucl_atomic_mass = 239.05220
    NuclDataCommon(81)%nucl_atomic_mass = 240.05380
    NuclDataCommon(82)%nucl_atomic_mass = 241.05679
    NuclDataCommon(83)%nucl_atomic_mass = 242.05870
    NuclDataCommon(84)%nucl_atomic_mass = 241.05679
    NuclDataCommon(85)%nucl_atomic_mass = 242.05954
    NuclDataCommon(86)%nucl_atomic_mass = 243.06137
    NuclDataCommon(87)%nucl_atomic_mass = 242.05882
    NuclDataCommon(88)%nucl_atomic_mass = 243.06139
    NuclDataCommon(89)%nucl_atomic_mass = 244.06274
    NuclDataCommon(90)%nucl_atomic_mass = 245.06548
    NuclDataCommon(91)%nucl_atomic_mass = 246.06721
    NuclDataCommon(92)%nucl_atomic_mass = 248.07234
    NuclDataCommon(93)%nucl_atomic_mass = 234.00999
    NuclDataCommon(94)%nucl_atomic_mass = 238.03999
    NuclDataCommon(95)%nucl_atomic_mass = 234.00999
    NuclDataCommon(96)%nucl_atomic_mass = 0.00000
    NuclDataCommon(97)%nucl_atomic_mass = 0.00000
    NuclDataCommon(98)%nucl_atomic_mass = 0.00000
    NuclDataCommon(99)%nucl_atomic_mass = 1.00797
end subroutine FormJARFRisotopicTable

max_stars_repo_name: IvanSaldoZ/REPRORYV

max_issues_repo_name: IvanSaldoZ/REPRORYV

max_forks_repo_name: IvanSaldoZ/REPRORYV


text:
C
C**************************  FHUDDS ************************************
C
C  calculate second derivative of effective saturation with respect to
C  pressure head using Huyakorn characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FHUDDS(PSI)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      REAL*8   PAP,PAPR,LAMBDA,LAMR
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. HUPSIA) THEN
         PAP=HUPSIA - PSI
         PAPR=1.0D0/PAP
         LAMBDA=HUALB*(PAP**HUBETA)
         LAMR=1.0D0/(1.0D0 + LAMBDA)
         FHUDDS=HUGB*LAMBDA*PAPR*PAPR*(HU1BET + HUGB1*LAMBDA)*
     1                                (LAMR**HUGAM2)
      ELSE
         FHUDDS=0.0D0
      END IF
C
      RETURN
      END


text:
!************************************************************
!
!  This example shows how to read and write data to a dataset
!  using the Scale-Offset filter.  The program first checks
!  if the Scale-Offset filter is available, then if it is it
!  writes integers to a dataset using Scale-Offset, then
!  closes the file Next, it reopens the file, reads back the
!  data, and outputs the type of filter and the maximum value
!  in the dataset to the screen.
!
!  This file is intended for use with HDF5 Library verion 1.8
!
!************************************************************
PROGRAM main

  USE HDF5

  IMPLICIT NONE

  CHARACTER(LEN=15), PARAMETER :: filename = "h5ex_d_soint.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset  = "DS1"
  INTEGER          , PARAMETER :: dim0     = 32
  INTEGER          , PARAMETER :: dim1     = 64
  INTEGER          , PARAMETER :: chunk0   = 4
  INTEGER          , PARAMETER :: chunk1   = 8

  INTEGER :: hdferr
  LOGICAL :: avail
  INTEGER(HID_T)  :: file, space, dset, dtype, dcpl ! Handles

  INTEGER, DIMENSION(1:1) :: cd_values
  INTEGER :: filter_id
  INTEGER :: filter_info_both
  INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/dim0, dim1/), chunk =(/chunk0,chunk1/)
  INTEGER(SIZE_T) :: nelmts
  INTEGER :: flags, filter_info
  INTEGER, DIMENSION(1:dim0, 1:dim1) :: wdata, & ! Write buffer
                                                 rdata    ! Read buffer
  INTEGER :: max, min
  INTEGER :: i, j
  INTEGER, PARAMETER :: MaxChrLen = 80
  CHARACTER(LEN=MaxChrLen) :: name
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! Check if Scale-Offset compression is available and can be used
  ! for both compression and decompression.  Normally we do not
  ! perform error checking in these examples for the sake of
  ! clarity, but in this case we will make an exception because this
  ! filter is an optional part of the hdf5 library.
  !
  CALL h5zfilter_avail_f(H5Z_FILTER_SCALEOFFSET_F, avail, hdferr)

  IF (.NOT.avail) THEN
     WRITE(*,'("Scale-Offset filter not available.",/)')
     STOP
  ENDIF

  CALL h5zget_filter_info_f(H5Z_FILTER_SCALEOFFSET_F, filter_info, hdferr)

  filter_info_both=IOR(H5Z_FILTER_ENCODE_ENABLED_F,H5Z_FILTER_DECODE_ENABLED_F)
  IF (filter_info .NE. filter_info_both) THEN
     WRITE(*,'("Scale-Offset filter not available for encoding and decoding.",/)')
     STOP
  ENDIF
  !
  ! Initialize data.
  !
  DO i = 1, dim0
     DO j = 1, dim1
        wdata(i,j) = (i-1)*(j-1)-(j-1)
     ENDDO
  ENDDO

  !
  ! Find the maximum value in the dataset, to verify that it was
  ! read correctly.
  !
  max = MAXVAL(wdata)
  min = MINVAL(wdata)
  !
  ! Print the maximum value.
  !
  WRITE(*,'("Maximum value in write buffer is: ",i4)') max
  WRITE(*,'("Minimum value in write buffer is: ",i4)') min
  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create dataspace.  Setting size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the dataset creation property list, add the Scale-Offset
  ! filter and set the chunk size.
  !
  CALL h5pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr)
  CALL h5pset_scaleoffset_f(dcpl, H5Z_SO_INT_F, H5Z_SO_INT_MINBITS_DEFAULT_F, hdferr)
  CALL h5pset_chunk_f(dcpl, 2, chunk, hdferr)
  !
  ! Create the dataset.
  !
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr, dcpl)
  !
  ! Write the data to the dataset.
  !
  CALL h5dwrite_f(dset, H5T_NATIVE_INTEGER, wdata, dims, hdferr)
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
  !
  ! Now we begin the read section of this example.
  !
  !
  ! Open file and dataset using the default properties.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f (file, dataset, dset, hdferr)
  !
  ! Retrieve dataset creation property list.
  !
  CALL h5dget_create_plist_f(dset, dcpl, hdferr)
  !
  ! Retrieve and print the filter type.  Here we only retrieve the
  ! first filter because we know that we only added one filter.
  !
  nelmts = 1
  CALL H5Pget_filter_f(dcpl, 0, flags, nelmts, cd_values, MaxChrLen, name, filter_id, hdferr)
  WRITE(*,'("Filter type is: ")', ADVANCE='NO')
  IF(filter_id.EQ.H5Z_FILTER_DEFLATE_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_DEFLATE_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_SHUFFLE_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_SHUFFLE_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_FLETCHER32_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_FLETCHER32_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_SZIP_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_SZIP_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_NBIT_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_NBIT_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_SCALEOFFSET_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_SCALEOFFSET_F")')
  ENDIF
  !
  ! Read the data using the default properties.
  !
  CALL h5dread_f(dset, H5T_NATIVE_INTEGER, rdata, dims, hdferr)
  !
  !
  ! Find the maximum and minimum value in the dataset, to verify that it was
  ! read correctly.
  !
  max = MAXVAL(rdata)
  min = MINVAL(rdata)
  !
  ! Print the maximum value.
  !
  WRITE(*,'("Maximum value in ",A," is: ",i4)') dataset,max
  WRITE(*,'("Minimum value in ",A," is: ",i4)') dataset,min
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5fclose_f(file , hdferr)

END PROGRAM main

max_stars_repo_name: utdsimmons/ohpc

max_issues_repo_name: utdsimmons/ohpc

max_forks_repo_name: utdsimmons/ohpc