text:
C=======================================================================
C  PT_GROSUB, Subroutine
C
C  Potato growth routine
C-----------------------------------------------------------------------
C  Revision history
C
C  02/07/1993 PWW Header revision and minor changes
C  02/07/1993 PWW Switch block added, etc
C  12/13/1994 WTB Restructured N routines
C  08/27/2001 CHP Modified for modular structure.
C                 Changed LAI to XLAI to match CROPGRO variable.
C  06/11/2002 GH  Modified for Y2K
C  10/02/2002 CHP/WM Added bedwidth correction when PLME = 'B'
C  03/12/2003 CHP Changed senescence variable to composite (SENESCE)
C                   as defined in ModuleDefs.for
C  08/12/2003 CHP Added Walter Bowen's changes to GROLF from 1/2000
C  08/23/2011 GH/JIL Added CO2 response to tuber growth
!  04/01/2012 CHP Added two RUE parameters to new ecotype file
C=======================================================================

      SUBROUTINE PT_GROSUB (DYNAMIC,
     &    CO2, CUMDTT, DLAYR, DTT, DUL, FILEIO,           !Input
     &    ISTAGE, ISWNIT, KG2PPM, LL, NH4, NLAYR, NO3,    !Input
     &    RLV, RTF, SAT, SLPF, SRAD, STGDOY, STT, SW,     !Input
!     &    SWFAC, TGROAV,TMAX, TMIN, TURFAC, XSTAGE, YRDOY,!Input
     &    SWFAC, TMAX, TMIN, TURFAC, XSTAGE, YRDOY,!Input

     &    GRORT, SEEDRV,                                  !I/O

     &    AGEFAC, BIOMAS, CANNAA, CANWAA, CNSD1, CNSD2,   !Output
     &    DEADLF, GRAINN, LFWT, NSTRES, PLTPOP, ROOTN,    !Output
     &    RTWT, SDWTPL, SEEDNI, SENESCE, STMWT, STOVN,    !Output
     &    STOVWT, TOPSN, TOPWT, TRNU, TUBN, TUBWT,        !Output
     &    UNH4, UNO3, WTNCAN, WTNLO, WTNUP, XLAI)         !Output

C-----------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
      IMPLICIT  NONE
      SAVE

      LOGICAL FIRST

      CHARACTER*1  ISWNIT, PLME
      CHARACTER*30 FILEIO

      INTEGER DYNAMIC, ISTAGE
      INTEGER NLAYR, YRDOY
      INTEGER STGDOY(20)

      REAL AGEFAC, ARVCHO, BIOMAS, CANNAA, CANWAA
      REAL BWRATIO, RUE1, RUE2
      REAL CARBO, CNSD1, CNSD2, CO2
      REAL CUMDTT, DEVEFF, DDEADLF, DEADLF, DEADLN, DTT, ETGT
      REAL G2, G3, GRAINN, GRF, GROLF, GROPLNT, GRORT
      REAL GROSTM, GROTOP, GROTUB
      REAL LALWR, LFWT, NFAC, NSTRES, PT_PAR, PCARB
      REAL PCO2, PD, PGRTUB, PLA, PLAG
      REAL PLAS, PLTPOP, PRFT, PTF, PTUBGR
      REAL RANC, RCNP, RLGR, ROOTN, RTF, RTPAR, RTWT
      REAL RVCAV, RVCHO, RVCMAX, RVCUSD
      REAL SDWTPL, SEEDAV, SEEDN, SEEDNI, SEEDRV
      REAL SLAN, SLFC, SLFN, SLFT, SLFW, SLPF, SRAD, STMWT
      REAL STOVN, STOVWT, STT, SWFAC
      REAL TABEX, TANC, TCNP, TEMPM, TIND, TMAX, TMIN
      REAL TMNC, TOPSN, TOPWT, TRNU, TUBANC, TUBCNP, TUBN
      REAL TUBWT, TURFAC, WTNCAN, WTNLO, WTNUP, XLAI, XSTAGE
      !REAL SLFT_TMAX, SLFT_TMIN, TGROAV, ALIN, MIN
      REAL SLFT_TMAX, SLFT_TMIN, ALIN, MIN

      REAL DTII(3)
      TYPE (ResidueType) SENESCE

      REAL, DIMENSION(4)  :: SENST, SENSF
      REAL, DIMENSION(10) :: CO2X, CO2Y
      REAL, DIMENSION(NL) :: DLAYR, DUL, KG2PPM, LL,
     &    NH4, NO3, RLV, SAT, SW, UNO3, UNH4

!      DATA  LALWR, SLAN /270.,0./
      DATA  LALWR /270./      !leaf area:leaf wt. ratio (cm2/g)

!***********************************************************************
!***********************************************************************
!     Seasonal Initialization - Called once per season
!***********************************************************************
      IF (DYNAMIC .EQ. SEASINIT) THEN
!-----------------------------------------------------------------------
      CALL PT_IPGRO(
     &    FILEIO,                                                 !Input
     &    CO2X, CO2Y, G2, G3, PD, PLME, PLTPOP,                   !Output
     &    SDWTPL, RUE1, RUE2, SENSF, SENST)                       !Output

      IF (PLME .EQ. 'B') THEN
        !Bed width ratio = Bed width / Row Spacing
        !For now, this ratio will be coded in (could use the ROWSPC
        !  variable in FILEX in the future). CHP
        BWRATIO = 0.5
      ELSE
        BWRATIO = 1.0
      ENDIF

      FIRST = .TRUE.

!     From INPLNT
      AGEFAC = 1.0
      BIOMAS = 0.0
      CANNAA = 0.0
      CANWAA = 0.0
      DEADLF = 0.0
      DEADLN = 0.0
      GRAINN = 0.0
      XLAI   = 0.0
      LFWT   = 0.0
      NFAC   = 1.0
      NSTRES = 1.0
      PTF    = 0.0
      RANC   = 0.0215 !set to zero in PHASEI - see below
      RCNP   = 0.0
      ROOTN  = 0.0
      RTWT   = 0.0
      SEEDNI = 0.0
      STMWT  = 0.0
      STOVN  = 0.0
      STOVWT = 0.0
      TANC   = 0.045  !set to zero in PHASEI - see below
      TCNP   = 0.0
      TMNC   = 0.0
      TOPSN  = 0.0
      TOPWT  = 0.0
      TUBANC = 0.014  !set to zero in PHASEI - see below
      TUBWT  = 0.0

!     This initialization was in INPHEN
      IF (ISWNIT .NE. 'Y') THEN
         TANC = 0.0
      ENDIF

!-----------------------------------------------------------------------
!     These stmts from main program
      !
      ! Only 80% of the CHO in the seed piece is assumed to be available
      ! for growth.
      !
      SEEDRV = SDWTPL/(PLTPOP * 10.0)          ! convert kg/ha to g/plt
      SEEDRV = SEEDRV*0.8

!-----------------------------------------------------------------------
!These initializations were done in PHASEI, cases 1, 2, 5 and 7
      BIOMAS  = 0.0
      CNSD1   = 0.0
      CNSD2   = 0.0
      DDEADLF = 0.0
      DTII    = 0.0   !array
      XLAI    = 0.0
      LFWT    = 0.0
      GRORT   = 0.0
      GROTOP  = 0.0
      PLA     = 0.0
      RANC    = 0.0  !Note conflict with IPLNT initialization (above)
      RTWT    = 0.0
      SEEDN   = 0.0
      SEEDNI  = 0.0
      STMWT   = 0.0
      TANC    = 0.0
      TIND    = 0.0
      TOPWT   = 0.0
      TUBANC  = 0.0  !Note conflict with IPLNT initialization (above)
      TUBN    = 0.0
      TUBWT   = 0.0

      CALL PT_NUPTAK (SEASINIT,
     &    ISTAGE, DLAYR, DUL, KG2PPM, LL, NH4, NLAYR, NO3,!Input
     &    PLTPOP, RCNP, RLV, RTWT, SAT, SW, TCNP, TMNC,   !Input
     &    TOPWT, TUBCNP, TUBWT,                           !Input
     &    GRORT, GROTOP, GROTUB, ROOTN, TOPSN, TUBANC,    !I/O
     &    ARVCHO, RANC, TANC, TRNU, TUBN, UNH4, UNO3,     !Output
     &    WTNUP)                                          !Output

      CARBO  = 0.0
      PCARB  = 0.0
      STT    = 0.0
      TRNU   = 0.0
      UNH4   = 0.0
      UNO3   = 0.0
      WTNLO  = 0.0
      WTNCAN = 0.0

!***********************************************************************
!***********************************************************************
!     Daily rate calculations
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. RATE) THEN
!-----------------------------------------------------------------------

      IF (FIRST) THEN     !Initializations from PHASEI, all Case(7),
                          ! except where noted.
        FIRST   = .FALSE.
!        XLAI    = PLA * PLANTS * 0.0001
        XLAI    = PLA * PLTPOP * 0.0001       !CHP
        IF (PLME .EQ. 'B') THEN               !WM
          XLAI    = XLAI * BWRATIO            !WM
        ENDIF                                 !WM
        LFWT    = 0.093
        PLA     = 25.0        !cm2/plant
        STMWT   = LFWT
        TOPWT   = 0.186
        IF (ISWNIT .EQ. 'Y') THEN
          RANC  = 0.015
          TANC  = 0.045
          TUBN  = 0.0
          ROOTN = RANC * RTWT
          TOPSN = TOPWT * TANC
          SEEDN = (RANC * RTWT) + (TOPWT * TANC)
          SEEDNI = SEEDN * PLTPOP
          TUBANC = 0.014              !from PHASEI, Case(1)
          TUBWT = 0.010               !from PHASEI, Case(1)
          TUBN = TUBANC * TUBWT       !from PHASEI, Case(1)
          SEEDN  = SEEDN + TUBN       !from PHASEI, Case(1)
        ENDIF
      ENDIF

      IF (ISWNIT .NE. 'N') THEN
         CALL PT_NFACTO (
     &    ISTAGE, TANC, XSTAGE,                           !Input
     &    AGEFAC, CNSD1, CNSD2, NFAC, NSTRES,             !Output
     &    RCNP, TCNP, TMNC)                               !Output

         TUBCNP = 0.014
!         TUBMNC = 0.007      !moved to PT_NUPTAK
       ELSE
         NSTRES = 1.0
         AGEFAC = 1.0
         NFAC   = 1.0
      END IF

      TEMPM = (TMAX + TMIN)/2.0         ! Mean temp. calculation
      !PRFT  = 1.2 - 0.0035*(TEMPM - 22.5)**2 !original funtion
      !--------Beggin----effect of Tmean on PRFT, modified by RR 02/15/2016
      IF (TEMPM .LE. 14) THEN
          PRFT  = 1.2 - 0.0035*(TEMPM - 22.5)**2
      ! The next 2 lines set the bounds of PRFT at 0.0 and 1.0
      !
          PRFT  = AMAX1 (PRFT,0.0)
          PRFT  = AMIN1 (PRFT,1.0)

      ELSEIF (TEMPM .GT. 14 .AND. TEMPM .LE. 24) THEN
          PRFT = 1.0
      ELSEIF (TEMPM .GT. 24 .AND. TEMPM .LE. 35) THEN
          PRFT = -0.0909*(TEMPM) + 3.1818 !RR linear function from 24 to 40  y = -0.0909x + 3.1818
      ELSE
          PRFT = 0
      END IF
      !--------End-----effect of Tmean on PRFT, modified by RR 02/15/2016
      !

      ! Calculation of daily leaf senescence, begin
      !
      SELECT CASE (ISTAGE)
        CASE (1)                        ! Natural senescence, SLAN
          SLAN = CUMDTT*PLA/10000.
        CASE (2)
          SLAN = (CUMDTT*PLA/10000.)*EXP(-1.60 + XSTAGE)*(PD**0.5)
     &           *(1./NFAC)
      END SELECT

      IF (ISTAGE .EQ. 2) THEN              ! Senescence from stress
         SLFW = 0.95 + 0.05*TURFAC         ! ...Water stress
C        SLFN = 0.95 + 0.05*AGEFAC         ! ...Nitrogen stress
         SLFN = 1.0
         SLFC = 1.0                        ! ...Competition
         IF (XLAI .GT. 4.) THEN
            SLFC = 1. - 0.008*(XLAI - 4.)
         ENDIF

!         SLFT = 1.0                        ! ...Temperature
!         IF (TMIN .LE. 0.0) THEN
!             SLFT = 0
         !ENDIF
         !
         ! The following was causing the plant to die; modified
         ! temporarily, so that T factor SLFT will be very small
         ! but at least not ZERO.
         ! This NEEDS to be FIXED!!!  WTB, Lima, 28/06/96
         !
         ! With SLFT = 0, means all leaf area senesced!
         ! SLFT = 1.0 - 0.02*TMIN**2 was taken from SIMPOTATO V1.53
         !
!        SA/CHP 9/2/2015. Introduce a high temperature function
!          based on that in NWheat model.
!         IF (TMIN .LE. 0.0) THEN
!           SLFT = 1.0 - (6.0 - TEMPM)/6.0
!         ENDIF
         SLFT_TMIN = 1.0 - (6.0 - TEMPM)/6.0

         SLFT_TMAX = (ALIN(SENST,SENSF,4,TMAX)) ! RR 01/14/2016

!        Use the maximum here, but in the next equation, it's minimum!
         SLFT = MAX(SLFT_TMIN, SLFT_TMAX) !changed to MIN RR
         SLFT = MIN(SLFT_TMIN, SLFT_TMAX)
         SLFT = MAX (SLFT, 0.0)
         IF (TMIN <= 0.0) SLFT = 0.0

         PLAS = PLA*(1.0 - AMIN1(SLFW,SLFC,SLFT,SLFN))
       ELSE
         PLAS = 0.0
       END IF

      DDEADLF = AMAX1(SLAN,PLAS)/LALWR               ! Daily leaf loss

      IF (DDEADLF .GE. LFWT) THEN
          DDEADLF = LFWT
      END IF

!     Senesced matter to surface residue
      SENESCE % ResWt(0) = DDEADLF * PLTPOP * 10. !/ 0.40
!                kg/ha   = g/plant * pl/m2 * (kg/ha)/(g/m2)
      SENESCE % ResE(0,1) = SENESCE % ResWt(0) * TMNC
!               kg[N]/ha  =            kg/ha   * g[N]/g[plant]

      ! Senescence calculation, end
      !
      ! Update of haulm after senescence

      LFWT   = LFWT   - DDEADLF
      PLA    = LFWT   * LALWR
!      XLAI   = PLA    * PLANTS * 0.0001
      XLAI   = PLA    * PLTPOP * 0.0001       !CHP
      IF (PLME .EQ. 'B') THEN                 !WM
        XLAI   = XLAI * BWRATIO               !WM
      ENDIF                                   !WM
      TOPWT  = LFWT   + STMWT
      DEADLF = DEADLF + DDEADLF
      IF (ISWNIT .NE. 'N') THEN
         TOPSN  = TOPSN  - (DDEADLF*TMNC)
         DEADLN = DEADLN + (DDEADLF*TMNC)
      ENDIF

      !This unction was merged with PRFT
      !--------beggin----RR effect of Tmean on RUE 02/15/2016
      !IF (TEMPM .LE. 24) THEN
      !    TX_RUE = 1.0
      !ELSEIF (TEMPM .GT. 24 .AND. TEMPM .LE. 35) THEN
      !    TX_RUE = -0.0909*(TEMPM) + 3.1818 !RR linear function from 24 to 40  y = -0.0909x + 3.1818
      !ELSE
      !   TX_RUE = 0
      !END IF
      !--------end----------

      ! Potential carbon fixation
      !
      PT_PAR = SRAD*0.5               ! PAR = SRAD*.02092
      IF (ISTAGE .LT. 2) THEN
         !PCARB = 3.5*PT_PAR/PLTPOP*(1.0 - EXP(-0.55*XLAI))    !CHP
         PCARB = RUE1*PT_PAR/PLTPOP*(1.0 - EXP(-0.55*XLAI))    !CHP
       ELSE
         !PCARB = 4.0*PT_PAR/PLTPOP*(1.0 - EXP(-0.55*XLAI))    !CHP
         PCARB = RUE2*PT_PAR/PLTPOP*(1.0 - EXP(-0.55*XLAI))    !CHP
         !PCARB = RUE2*TX_RUE*PT_PAR/PLTPOP*(1.0 - EXP(-0.55*XLAI))    !CHP
      END IF

      IF (PLME .EQ. 'B') THEN                 !WM
        PCARB = PCARB / BWRATIO               !WM
      ENDIF                                   !WM
      !
      ! Calculate Photosynthetic Response to CO2
      !
      PCO2   = TABEX (CO2Y,CO2X,CO2,10)
      !PCARB  = PCARB*PCO2 ! original function 02/15/2016
      PCARB  = PCARB*PCO2*PRFT
      !CARBO  = PCARB*AMIN1(PRFT, SWFAC, NSTRES)*SLPF + 0.5*DDEADLF ! original function 02/15/2016
      CARBO  = PCARB*AMIN1(SWFAC, NSTRES)*SLPF + 0.5*DDEADLF ! Modified by RR 02/15/2016

      RVCUSD = 0.0                                   ! Reserve C used

      SWFAC  = AMAX1 (SWFAC, 0.1)
      TURFAC = AMAX1 (TURFAC,0.1)

      SELECT CASE (ISTAGE)
        CASE (1)
          !
          ! Vegetative Growth
          !
          ! Potential growth as function of temperature
          ! Primary varaible is leaf expansion; other growth
          ! parameters calculated from PLAG
          !
          GROTUB = 0.0
          PGRTUB = 0.0
          RLGR   = 0.50*DTT             ! From Ingram & McCloud (1984)
          PLAG   = EXP(RLGR)*PLA - PLA
          PLAG   = PLAG*AMIN1 (TURFAC, AGEFAC, 1.0)
          GROLF  = PLAG/LALWR
          GROSTM = GROLF*0.75
          !
          ! Following is a temporary fix to assure adequate
          ! root growth after emergence
          !
          IF (XSTAGE .LT. 1.5) THEN      ! RTPAR: proportion to roots
             RTPAR = 0.5 - 0.5*(XSTAGE - 1.0)
           ELSE
             RTPAR = 0.25
          END IF

          GRORT   = (GROLF + GROSTM)* RTPAR
          GROPLNT =  GROLF + GROSTM + GRORT
          !
          ! Use of seed piece carbon between emergence and
          ! PLA=400, as in Ng and Loomis
          !
          IF (PLA .LT. 100.0) THEN
             SEEDAV = 1.5*STT
             RVCHO  = 0.0
           ELSEIF (PLA .GE. 100.0 .AND. PLA .LE. 400.0) THEN
             SEEDAV = (1.5 - 0.005*(PLA - 100.0))*STT
             RVCHO  = 0.0
           ELSE
             SEEDAV = 0.0
             SEEDRV = 0.0
          END IF

          SEEDAV = AMIN1 (SEEDAV,SEEDRV)
          RVCAV  = SEEDAV + RVCHO

          IF (CARBO .LT. GROPLNT) THEN
              CARBO = CARBO + RVCAV
              IF (CARBO .LT. GROPLNT) THEN
                  GRF    = CARBO  / GROPLNT
                  GROLF  = GROLF  * GRF
                  PLAG   = GROLF  * LALWR
                  GROSTM = GROSTM * GRF
                  GRORT  = GRORT  * GRF
                  RVCUSD = RVCAV
                  RVCHO  = 0.0
               ELSE
                  RVCHO  = CARBO  - GROPLNT
                  RVCUSD = RVCAV  - RVCHO
              END IF

              IF (PLA .LE. 400.) THEN
                 SEEDRV = AMAX1 (SEEDRV - RVCUSD,0.0)
                 RVCHO  = 0.0
              END IF
              !
              ! A reserve carbohydrate pool, limited to 10 %
              !       of haulm weight
           ELSE
              RVCUSD = 0.0
              IF (PLA .GT. 400.0) THEN
                  RVCMAX = 0.1*(LFWT+GROLF+STMWT+GROSTM)
                  RVCHO  = RVCHO + CARBO - GROPLNT
                  RVCHO  = AMIN1 (RVCHO,RVCMAX)
               ELSE
                  RVCHO = 0.0
              END IF
          END IF
        CASE (2)
          !
          ! Tuber Growth
          !
          ! Calculation of TIND: proportion of tuber demand
          ! to be filled under prevailing temperature
          !
          DTII(1) = DTII(2)
          DTII(2) = DTII(3)
          DTII(3) = RTF + 0.5 * (1.0 - AMIN1(SWFAC, NSTRES,1.0))
          !DTII(3) = RTF + 0.5 * (1.0 - AMIN1(SWFAC, NSTRES, LFT,1.0)) !added tmax stress
          DTII(3) = AMIN1 (DTII(3),1.0)
          !
          ! DEVEFF is used to limit carbon demand of tubers
          ! immediately after initiation; eg. if PD=1.0,
          ! DEVEFF defaults to 1.0 at XSTAGE=2.1
          !
          DEVEFF = AMIN1 ((XSTAGE - 2.0) * 10. * PD, 1.0)
          IF (NFAC .GT. 1.0) THEN
             TIND = (DTII(1)+DTII(2)+DTII(3)/3.0)*(1./NFAC)*DEVEFF
           ELSE
             TIND = (DTII(1)+DTII(2)+DTII(3)/3.0)*DEVEFF
          END IF

          TIND = AMAX1 (TIND,0.0)
          TIND = AMIN1 (TIND,1.0)

          IF (TEMPM .GT. 2.0 .AND. TEMPM .LT. 15.0) THEN
             ETGT = 0.0769*(TEMPM-2.0)
           ELSEIF (TEMPM .GE. 15.0 .AND. TEMPM .LE. 23.0) THEN
             ETGT = 1.0
           ELSEIF (TEMPM .GT. 23.0 .AND. TEMPM .LT. 33.0) THEN
             ETGT = 1.0 - 0.1*(TEMPM-23.0)
           ELSE
             ETGT = 0.0
           ENDIF

          ! Calculation of potential growth .. Set priorities for carbon
          !
!          PTUBGR  = G3*ETGT/PLTPOP    !CHP
           PTUBGR  = G3 * PCO2 * ETGT/PLTPOP          !JIL   (Modified)

          IF (PLME .EQ. 'B') THEN                     !WM
            PTUBGR  = PTUBGR / BWRATIO                !WM
          ENDIF                                       !WM
!          SLFT = (ALIN(SENST,SENSF,4,TMAX))
          GROTUB  = PTUBGR*AMIN1 (TURFAC, AGEFAC, 1.0)*TIND
!          PLAG    = G2*DTT/PLANTS
          PLAG    = G2*DTT/PLTPOP     !CHP
          IF (PLME .EQ. 'B') THEN                     !WM
            PLAG    = PLAG / BWRATIO                  !WM
          ENDIF                                       !WM
          PLAG    = PLAG  *AMIN1 (TURFAC, AGEFAC, 1.0)
          GROLF   = PLAG/LALWR
          GROSTM  = GROLF*0.75
          RTPAR   = 0.2
          GRORT   = (GROLF + GROSTM)* RTPAR
          GROPLNT =  GROLF + GROSTM + GRORT
          RVCAV   = RVCHO
          CARBO   = CARBO + RVCAV
          !
          ! Partitions C based on tuber being first priority;
          ! C becomes progressively more limiting in this routine,
          ! and growth reduction factor (GRF) is implemented to
          ! reduce potential growth
          !
          IF (CARBO .GE. GROTUB) THEN
              CARBO = CARBO - GROTUB
              IF (CARBO .LT. GROPLNT) THEN
                  GRF    = CARBO  / GROPLNT
                  GROLF  = GROLF  * GRF
                  PLAG   = GROLF  * LALWR
                  GROSTM = GROSTM * GRF
                  GRORT  = GRORT  * GRF
                  RVCUSD = RVCAV
                  RVCHO  = RVCHO  - RVCUSD
               ELSE
                  RVCHO  = CARBO  - GROPLNT
                  IF (RVCHO .GT. RVCAV) THEN
                     RVCUSD = 0.0
                     RVCMAX = 0.1*(LFWT+GROLF+STMWT+GROSTM)
                     RVCHO  = AMIN1 (RVCHO,RVCMAX)
                   ELSE
                     RVCUSD = RVCAV - RVCHO
                  END IF
              END IF
           ELSE
              GROTUB = CARBO
              GROLF  = 0.0
              GROSTM = 0.0
              GRORT  = 0.0
              RVCUSD = RVCAV
              RVCHO  = RVCHO - RVCUSD
          END IF

          PGRTUB = GROTUB
        CASE DEFAULT
          STOP 'Illegal ISTAGE in GROSUB module'
      END SELECT

      GROTOP = GROLF + GROSTM
      CARBO  = AMAX1 (CARBO, 0.0001)
      !
      ! N subroutines are called;  compare potential
      ! growth (carbon-driven) with available N and
      ! adjusts growth if necessary
      !
      IF (ISWNIT .NE. 'N') THEN
          ! IF (SEEDAV .GT. 0.0) THEN
          !    SRVNU = RVCUSD*0.014       ! Seed reserve N used
          ! END IF
          ! SRVNU  = AMAX1 (SRVNU, 0.0)
          ! AVAILN = (SRVNU)+(0.5*DDEADLF*TMNC)

        CALL PT_NUPTAK (RATE,
     &    ISTAGE, DLAYR, DUL, KG2PPM, LL, NH4, NLAYR, NO3,!Input
     &    PLTPOP, RCNP, RLV, RTWT, SAT, SW, TCNP, TMNC,   !Input
     &    TOPWT, TUBCNP, TUBWT,                           !Input
     &    GRORT, GROTOP, GROTUB, ROOTN, TOPSN, TUBANC,    !I/O
     &    ARVCHO, RANC, TANC, TRNU, TUBN, UNH4, UNO3,     !Output
     &    WTNUP)                                          !Output

!-----------------------------------------------------------------------
! Jan 2000, Walter Bowen
! Before going into NUPTAK, GROTOP was set equal to GROLF+GROSTM,
! with GROSTM = GROLF * 0.75. As shown below, after coming out of
! NUPTAK, GROLF was then set to GROTOP*0.5, which always results
! in a loss of C. The equation was corrected as shown:
! GROTOP = GROLF + GROSTM
!       = GROLF + (GROLF*0.75)
!       = GROLF*(1 + (1*0.75))
!       = GROLF * 1.75
! thus, GROLF = GROTOP * (1/1.75)
! was...   GROLF   = GROTOP * 0.50
! should be:
          GROLF   = GROTOP * (1/1.75)
          GROSTM  = GROLF  * 0.75                    ! Added 0.75 (WTB)
          GROPLNT = GROLF  + GROSTM + GRORT
!-----------------------------------------------------------------------

          IF (ARVCHO .GT. 0.) THEN
             IF (PLA .LE. 400.) THEN
                SEEDRV = SEEDRV + AMIN1(ARVCHO,RVCUSD)
              ELSE
                RVCMAX = 0.1*(LFWT+GROLF+STMWT+GROSTM)
                RVCHO = RVCHO + ARVCHO
                RVCHO = AMIN1 (RVCHO,RVCMAX)
             END IF
          END IF
       ELSE
         NFAC = 1.0
      END IF
      !
      ! Daily Summary of Plant Parts
      !
      LFWT   = LFWT  + GROLF
      STMWT  = STMWT + GROSTM
      RTWT   = RTWT  + 0.8*GRORT
      TOPWT  = LFWT  + STMWT
      TUBWT  = TUBWT + GROTUB
      STOVWT = LFWT  + STMWT
      !
      ! Equivalancies for reporting
      !
      GRAINN = TUBN
      STOVN  = TOPSN

      IF (GROTOP .LT. 0.0) THEN
         DEADLF = DEADLF - GROTOP*0.5
      END IF

      PLAG = GROLF * LALWR
      PLA  = PLA   + PLAG
!      XLAI = PLA   * PLANTS * 0.0001
      XLAI = PLA   * PLTPOP * 0.0001  !CHP
      IF (PLME .EQ. 'B') THEN                 !WM
        XLAI = XLAI * BWRATIO                 !WM
      ENDIF                                   !WM

      IF (TOPWT .LE. 0.0) THEN
         TOPWT = 0.0
         XLAI  = 0.0
         TANC  = 0.0
       ELSE
         TANC  = TOPSN/TOPWT
      END IF

!      BIOMAS = (LFWT + STMWT + TUBWT)*PLANTS
      BIOMAS = (LFWT + STMWT + TUBWT)*PLTPOP  !CHP
      !IF (PLME .EQ. 'B') THEN                 !WM
      !  BIOMAS = BIOMAS / BWRATIO             !WM
      !ENDIF                                   !WM

      IF (GROTUB + GROPLNT .GT. 0.0) THEN
          PTF = GROTUB/(GROTUB + GROPLNT)  ! Proportion of daily growth
       ELSE                                ! due to tuber growth
          PTF = 0.0
      END IF

!     Moved from main program
      WTNLO  = DEADLN * PLTPOP

!     Moved from main program
      IF (YRDOY .EQ. STGDOY(3)) THEN
        CANNAA = STOVN * PLTPOP
        CANWAA = BIOMAS
      ENDIF

!     Moved from OPGROW
      WTNCAN = (STOVN + GRAINN) * PLTPOP

!***********************************************************************
!***********************************************************************
!     END OF DYNAMIC IF CONSTRUCT
!***********************************************************************
      ENDIF
!***********************************************************************
      RETURN
      END SUBROUTINE PT_GROSUB
C=======================================================================

C=======================================================================
C  PT_IPGRO, Subroutine
C
C  Data input for potato growth module
C-----------------------------------------------------------------------
C  Revision history
C
C  08/27/2001 CHP Written
C  08/12/2003 CHP Added I/O error checking
C=======================================================================
      SUBROUTINE PT_IPGRO(
     &    FILEIO,                                                 !Input
     &    CO2X, CO2Y, G2, G3, PD, PLME, PLTPOP,                   !Output
     &    SDWTPL, RUE1, RUE2, SENSF, SENST)                       !Output

!     ------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
                         ! which contain control information, soil
                         ! parameters, hourly weather data.
      IMPLICIT NONE

      INTEGER LUNIO, LUNCRP, LUNECO
      CHARACTER*1 PLME
      CHARACTER*1, PARAMETER :: BLANK = ' '
      CHARACTER*6, PARAMETER :: ERRKEY = 'GROSUB'

      CHARACTER*2   CROP
      CHARACTER*5   ACRO(4)
      CHARACTER*6   SECTION, ECONO, ECOTYP
      CHARACTER*12  FILEC, FILEE
      CHARACTER*16  ECONAM
      CHARACTER*30  FILEIO
      CHARACTER*80  PATHCR, PATHEC
      CHARACTER*92  FILECC, FILEGC
      CHARACTER*180 CHAR
      CHARACTER*255 C255

      INTEGER ERR, FOUND, I, J, LINC, LNUM, PATHL, ISECT

      REAL G2, G3, PD, PLTPOP, SDWTPL, RUE1, RUE2
      REAL, DIMENSION(4) :: SENST, SENSF
      REAL CO2X(10), CO2Y(10)

!      LOGICAL EOF
!-----------------------------------------------------------------------
!     Read data from FILEIO for use in GROSUB module
      CALL GETLUN('FILEIO', LUNIO)
      OPEN (LUNIO, FILE = FILEIO, STATUS = 'OLD', IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,0)

!     Read file and path name for species file
      READ(LUNIO,'(6(/),15X,A12,1X,A80)', IOSTAT=ERR) FILEC, PATHCR
      LNUM = 7
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
      READ (LUNIO,105,IOSTAT=ERR) FILEE, PATHEC; LNUM = LNUM + 1
  105 FORMAT(15X,A12,1X,A80)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)

C    Read Crop Code from Cultivars Section
      SECTION = '*CULTI'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ELSE
        READ (LUNIO,'(3X,A2)', IOSTAT=ERR) CROP ; LNUM = LNUM + 1
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
      ENDIF

C    Read Planting Details Section
      SECTION = '*PLANT'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ELSE
        READ (LUNIO,'(25X,F5.1,5X,A1,25X,F5.0)', IOSTAT=ERR)
     &        PLTPOP, PLME, SDWTPL ; LNUM = LNUM + 1
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
      ENDIF

C     Read crop genetic information
      SECTION = '*CULTI'
      CALL FIND(LUNIO, SECTION, LINC, FOUND) ; LNUM = LNUM + LINC
      IF (FOUND .EQ. 0) THEN
        CALL ERROR(SECTION, 42, FILEIO, LNUM)
      ELSE
        IF (INDEX ('PT',CROP) .GT. 0) THEN
          READ (LUNIO,'(24X,A6,1X,3F6.0)',IOSTAT=ERR)
     &          ECONO, G2, G3, PD
          LNUM = LNUM + 1
          IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEIO,LNUM)
        ENDIF
      ENDIF

      CLOSE (LUNIO)

C-----------------------------------------------------------------------
C     Read Crop Parameters from FILEC
      LNUM   = 0
      PATHL  = INDEX (PATHCR,BLANK)
      IF (PATHL .LE. 1) THEN
         FILECC = FILEC
       ELSE
         FILECC = PATHCR(1:(PATHL-1)) // FILEC
      ENDIF
      CALL GETLUN('FILEC', LUNCRP)
      OPEN (LUNCRP,FILE = FILECC, STATUS = 'OLD',IOSTAT=ERR)
      IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEC,0)

      ACRO(1) = 'CO2X'
      ACRO(2) = 'CO2Y'
      ACRO(3) = 'SENST'
      ACRO(4) = 'SENSF'
      LNUM = 0

      DO WHILE (ERR == 0)
!       READ (LUNCRP,'(A180)',IOSTAT=ERR, END=200) CHAR
        CALL IGNORE(LUNCRP,LNUM,ISECT,CHAR)
        IF (ISECT == 0) EXIT
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEC,LNUM)
        DO J = 1, 4
          IF (INDEX(CHAR(1:15),ACRO(J)) > 0) THEN
            SELECT CASE (J)
              CASE (1)
                READ (CHAR(16:66),'(10F5.0)',IOSTAT=ERR)(CO2X(I),I=1,10)
              CASE (2)
                READ (CHAR(16:66),'(10F5.2)',IOSTAT=ERR)(CO2Y(I),I=1,10)
              CASE (3)
                READ (CHAR(16:39),'(10F6.0)',IOSTAT=ERR)(SENST(I),I=1,4)
              CASE (4)
                READ (CHAR(16:39),'(10F6.0)',IOSTAT=ERR)(SENSF(I),I=1,4)
            END SELECT
            IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEC,LNUM)
          ENDIF
        END DO
      END DO

  200 CLOSE (LUNCRP)
C-----------------------------------------------------------------------
C     Read ECO Parameters from FILEE
C-----------------------------------------------------------------------
C     Open FILEE Ecotype coefficients (.ECO File)
C-----------------------------------------------------------------------
        LNUM = 0
        PATHL  = INDEX(PATHEC,BLANK)
        IF (PATHL .LE. 1) THEN
          FILEGC = FILEE
        ELSE
          FILEGC = PATHEC(1:(PATHL-1)) // FILEE
        ENDIF

C-----------------------------------------------------------------------
C    Read Ecotype Parameter File
C-----------------------------------------------------------------------
!RUE1 - Radiation use efficiency, ISTAGE=1, g plant dry matter/MJ PAR
!RUE2 - Radiation use efficiency, ISTAGE>1, g plant dry matter/MJ PAR
C-----------------------------------------------------------------------
        CALL GETLUN('FILEE', LUNECO)
        OPEN (LUNECO,FILE = FILEGC,STATUS = 'OLD',IOSTAT=ERR)
        IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEE,0)
        ECOTYP = '      '
        LNUM = 0
        DO WHILE (ECOTYP .NE. ECONO)
          CALL IGNORE(LUNECO, LNUM, ISECT, C255)
          IF (ISECT .EQ. 1 .AND. C255(1:1) .NE. ' ' .AND.
     &          C255(1:1) .NE. '*') THEN
            READ(C255,3100,IOSTAT=ERR) ECOTYP, ECONAM
3100        FORMAT (A6,1X,A16)
            IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEE,LNUM)
            IF (ECOTYP .EQ. ECONO) THEN
              READ(C255(26:37),'(F5.0, 1X, F5.0)',IOSTAT=ERR) RUE1, RUE2
              IF (ERR .NE. 0) CALL ERROR(ERRKEY,ERR,FILEE,LNUM)
              EXIT
            ENDIF
          ELSEIF (ISECT .EQ. 0) THEN
            CALL ERROR(ERRKEY,7,FILEE,LNUM)
          ENDIF
        ENDDO

        CLOSE (LUNECO)

C-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PT_IPGRO
C=======================================================================

ext: for

max_stars_repo_name: vstocca/dssat-csm-os

max_issues_repo_name: vstocca/dssat-csm-os

max_forks_repo_name: vstocca/dssat-csm-os


text: Address(Hidden Circle) is part of the Rancho Yolo Mobile Home Parks mobile home park. It is at the north east corner of the park and branches off from Quarter Circle.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!>  @file  comm.f90
!!  @brief Wrapper functions for inter-process communications for Cartesian grid data structure
!<

subroutine comm_sum(total, a)
  implicit none
  include 'mpif.h'
  real                    :: total, a
  integer                  :: ierror
  total = 0.0
#ifdef _REAL_IS_DOUBLE_
  call mpi_allreduce(a, total, 1, mpi_double_precision, mpi_sum, mpi_comm_world, ierror)
#else
  call mpi_allreduce(a, total, 1, mpi_real, mpi_sum, mpi_comm_world, ierror)
#endif
end subroutine comm_sum

subroutine comm_max(total, a)
  implicit none
  include 'mpif.h'
  real                    :: total, a
  integer                  :: ierror
  total = 0.0
#ifdef _REAL_IS_DOUBLE_
  call mpi_allreduce(a, total, 1, mpi_double_precision, mpi_max, mpi_comm_world, ierror)
#else
  call mpi_allreduce(a, total, 1, mpi_real, mpi_max, mpi_comm_world, ierror)
#endif
end subroutine comm_max

subroutine comm_min(total, a)
  implicit none
  include 'mpif.h'
  real                    :: total, a
  integer                  :: ierror
  total = 0.0
#ifdef _REAL_IS_DOUBLE_
  call mpi_allreduce(a, total, 1, mpi_double_precision, mpi_min, mpi_comm_world, ierror)
#else
  call mpi_allreduce(a, total, 1, mpi_real, mpi_min, mpi_comm_world, ierror)
#endif
end subroutine comm_min

subroutine comm_dot(xy, x, y, sz, g)
  implicit none
  include 'mpif.h'
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real                    :: xy
  integer                  :: ierror
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: y
  real                    :: xy_
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
  xy_ = 0.0
!$omp parallel private(i, j, k)
!$omp do reduction(+:xy_)
  do k=1, kx
  do j=1, jx
  do i=1, ix
    xy_ = xy_ + x(i, j, k)*y(i, j, k)
  end do
  end do
  end do
!$omp end do
!$omp end parallel
  xy = 0.0
#ifdef _REAL_IS_DOUBLE_
  call mpi_allreduce(xy_, xy, 1, mpi_double_precision, mpi_sum, mpi_comm_world, ierror)
#else
  call mpi_allreduce(xy_, xy, 1, mpi_real, mpi_sum, mpi_comm_world, ierror)
#endif
end subroutine comm_dot

subroutine comm_band_cells(x, &
                          sz, g, &
                          mx, &
                          sx1, sx3, sx2, sx4, sx5, sx6, &
                          rx1, rx3, rx2, rx4, rx5, rx6, &
                          node)
  implicit none
  include 'mpif.h'
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  integer                  :: m
  integer                  :: mx
  real, dimension(1:mx, 1-g:sz(2)+g, 1-g:sz(3)+g) :: sx1, sx3, rx1, rx3
  real, dimension(1:mx, 1-g:sz(1)+g, 1-g:sz(3)+g) :: sx2, sx4, rx2, rx4
  real, dimension(1:mx, 1-g:sz(1)+g, 1-g:sz(2)+g) :: sx5, sx6, rx5, rx6
  integer, dimension(0:6)  :: node
  integer                  :: ierror
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
!$omp parallel private(i, j, k)
!$omp do
  do k=1-g, kx+g
  do j=1-g, jx+g
  do m=1, mx
    sx1(m, j, k) = x(ix-mx+m, j, k)
    sx3(m, j, k) = x(m      , j, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do k=1-g, kx+g
  do i=1-g, ix+g
  do m=1, mx
    sx2(m, i, k) = x(i, jx-mx+m, k)
    sx4(m, i, k) = x(i, m      , k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do j=1-g, jx+g
  do i=1-g, ix+g
  do m=1, mx
    sx5(m, i, j) = x(i, j, kx-mx+m)
    sx6(m, i, j) = x(i, j, m      )
  end do
  end do
  end do
!$omp end do
!$omp end parallel
#ifdef _REAL_IS_DOUBLE_
    call mpi_sendrecv(sx1, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(1), 1, &
                      rx3, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(3), 1, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx3, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(3), 3, &
                      rx1, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(1), 3, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx2, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(2), 2, &
                      rx4, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(4), 2, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx4, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(4), 4, &
                      rx2, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(2), 4, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx5, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(5), 5, &
                      rx6, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(6), 5, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx6, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(6), 6, &
                      rx5, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(5), 6, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)
#else
    call mpi_sendrecv(sx1, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(1), 1, &
                      rx3, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(3), 1, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx3, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(3), 3, &
                      rx1, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(1), 3, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx2, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(2), 2, &
                      rx4, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(4), 2, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx4, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(4), 4, &
                      rx2, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(2), 4, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx5, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(5), 5, &
                      rx6, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(6), 5, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)

    call mpi_sendrecv(sx6, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(6), 6, &
                      rx5, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(5), 6, &
                      mpi_comm_world, mpi_statuses_ignore, ierror)
#endif
!$omp parallel private(i, j, k)
!$omp do
  do k=1-g, kx+g
  do j=1-g, jx+g
  do m=1, mx
    x( ix+m, j, k) = rx1(m, j, k)
    x(-mx+m, j, k) = rx3(m, j, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do k=1-g, kx+g
  do i=1-g, ix+g
  do m=1, mx
    x(i,  jx+m, k) = rx2(m, i, k)
    x(i, -mx+m, k) = rx4(m, i, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do j=1-g, jx+g
  do i=1-g, ix+g
  do m=1, mx
    x(i, j,  kx+m) = rx5(m, i, j)
    x(i, j, -mx+m) = rx6(m, i, j)
  end do
  end do
  end do
!$omp end do
!$omp end parallel
end subroutine comm_band_cells

subroutine comm_band_cells_nb(x, &
                          sz, g, &
                          mx, &
                          sx1, sx3, sx2, sx4, sx5, sx6, &
                          rx1, rx3, rx2, rx4, rx5, rx6, &
                          node)
  implicit none
  include 'mpif.h'
  integer                  :: i, j, k
  integer                  :: ix, jx, kx
  integer                  :: g
  integer, dimension(3)    :: sz
  real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)  :: x
  integer                  :: m
  integer                  :: mx
  real, dimension(1:mx, 1-g:sz(2)+g, 1-g:sz(3)+g) :: sx1, sx3, rx1, rx3
  real, dimension(1:mx, 1-g:sz(1)+g, 1-g:sz(3)+g) :: sx2, sx4, rx2, rx4
  real, dimension(1:mx, 1-g:sz(1)+g, 1-g:sz(2)+g) :: sx5, sx6, rx5, rx6
  integer, dimension(0:6)  :: node
  integer                  :: ierror
  integer, dimension(4)    :: req
  ix = sz(1)
  jx = sz(2)
  kx = sz(3)
!$omp parallel private(i, j, k)
!$omp do
  do k=1-g, kx+g
  do j=1-g, jx+g
  do m=1, mx
    sx1(m, j, k) = x(ix-mx+m, j, k)
    sx3(m, j, k) = x(m      , j, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do k=1-g, kx+g
  do i=1-g, ix+g
  do m=1, mx
    sx2(m, i, k) = x(i, jx-mx+m, k)
    sx4(m, i, k) = x(i, m      , k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do j=1-g, jx+g
  do i=1-g, ix+g
  do m=1, mx
    sx5(m, i, j) = x(i, j, kx-mx+m)
    sx6(m, i, j) = x(i, j, m      )
  end do
  end do
  end do
!$omp end do
!$omp end parallel
#ifdef _REAL_IS_DOUBLE_
    call mpi_irecv(rx1, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(1), 3, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx3, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(3), 1, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx1, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(1), 1, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx3, (jx+2*g)*(kx+2*g)*mx, mpi_double_precision, node(3), 3, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)

    call mpi_irecv(rx2, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(2), 4, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx4, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(4), 2, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx2, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(2), 2, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx4, (ix+2*g)*(kx+2*g)*mx, mpi_double_precision, node(4), 4, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)

    call mpi_irecv(rx5, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(5), 6, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx6, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(6), 5, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx5, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(5), 5, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx6, (ix+2*g)*(jx+2*g)*mx, mpi_double_precision, node(6), 6, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)
#else
    call mpi_irecv(rx1, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(1), 3, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx3, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(3), 1, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx1, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(1), 1, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx3, (jx+2*g)*(kx+2*g)*mx, mpi_real, node(3), 3, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)

    call mpi_irecv(rx2, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(2), 4, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx4, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(4), 2, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx2, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(2), 2, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx4, (ix+2*g)*(kx+2*g)*mx, mpi_real, node(4), 4, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)

    call mpi_irecv(rx5, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(5), 6, &
                   mpi_comm_world, req(4), ierror)
    call mpi_irecv(rx6, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(6), 5, &
                   mpi_comm_world, req(2), ierror)
    call mpi_isend(sx5, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(5), 5, &
                   mpi_comm_world, req(1), ierror)
    call mpi_isend(sx6, (ix+2*g)*(jx+2*g)*mx, mpi_real, node(6), 6, &
                   mpi_comm_world, req(3), ierror)
    call mpi_waitall(4, req, mpi_statuses_ignore, ierror)
#endif
!$omp parallel private(i, j, k)
!$omp do
  do k=1-g, kx+g
  do j=1-g, jx+g
  do m=1, mx
    x( ix+m, j, k) = rx1(m, j, k)
    x(-mx+m, j, k) = rx3(m, j, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do k=1-g, kx+g
  do i=1-g, ix+g
  do m=1, mx
    x(i,  jx+m, k) = rx2(m, i, k)
    x(i, -mx+m, k) = rx4(m, i, k)
  end do
  end do
  end do
!$omp end do
!$omp do
  do j=1-g, jx+g
  do i=1-g, ix+g
  do m=1, mx
    x(i, j,  kx+m) = rx5(m, i, j)
    x(i, j, -mx+m) = rx6(m, i, j)
  end do
  end do
  end do
!$omp end do
!$omp end parallel
end subroutine comm_band_cells_nb

max_stars_repo_name: avr-aics-riken/FFV-HC

max_issues_repo_name: avr-aics-riken/FFV-HC

max_forks_repo_name: avr-aics-riken/FFV-HC


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! PR fortran/71902 - make sure that component references are followed
! for dependency analysis.
program main
  type foo
     character(len=:), allocatable :: x
  end type foo
  type(foo) :: a
  a%x = 'asdf'
  a%x = a%x(2:3)
  print *,a%x
end program main
! { dg-final { scan-tree-dump-times "__var_1" 4 "original" } }


Module sub_flatlens
  USE healpix_types
!USE flatlens_types

Implicit None

type grid

integer(i4b) :: nx,ny
logical isT,isPhi

end type grid

Contains

subroutine getcenter(mygrid,centercoord)
	type (grid), intent(in) :: mygrid
		integer(i8b), intent(out),dimension(0:1) :: centercoord
		if ( (mod(mygrid%nx,2).ne.0) .or. (mod(mygrid%ny,2) .ne. 0) ) then
			stop "only implemented for even grid dimensions"
		end if
		centercoord(0)=mygrid%nx/2
		centercoord(1)=mygrid%ny/2

end subroutine getcenter

subroutine real2matcoord(mygrid,realcoor,mat)
	type (grid), intent(in) :: mygrid

	integer(i8b), intent(in),dimension(0:1) :: realcoor

	integer(i8b), intent(out),dimension(0:1) :: mat
	integer(i8b), dimension(0:1) :: center
	call getcenter(mygrid,center)
	mat(0)=2*center(0)+realcoor(0)
	mat(1)=2*center(1)-realcoor(1)

end subroutine real2matcoord

subroutine mat2realcoord(mygrid,realcoor,mat)
	type (grid), intent(in) :: mygrid

	integer(i8b), intent(in),dimension(0:1) :: realcoor

	integer(i8b), intent(out),dimension(0:1) :: mat
	integer(i8b), dimension(0:1) :: center
	call getcenter(mygrid,center)
	mat(0)=2*center(0)-realcoor(0)
	mat(1)=2*center(1)-realcoor(1)

end subroutine mat2realcoord

!subroutine grid2cl(mygrid,Cl)
!	complex(DPC), intent(in), dimension(:,:) :: mygrid
!	real(DP),intent(out),dimension(:,:)::Cl
!end subroutine grid2cl

!------------------------------------------------------------------------

! subroutine to compute the ps1d(l) by azimuthal averaging the power in each fourier mode

        SUBROUTINE ps_azim(nx,ny,map,icentre,jcentre,lmax,uvcell,ps1d)
        	USE healpix_types

          Implicit None

        Integer(i4b), Intent(In) :: nx, ny, icentre,jcentre,lmax

        Complex(DPC), Intent(In) ::  map(0:nx-1,0:ny-1)
        real(DP), Intent(Out)   :: ps1d(0:lmax)

        Real(DP)  :: uvdist,sumps,uvcell
        Integer :: i,j,k,l, count(0:lmax)
       write(*,*) lmax
        write(*,*) 'center',icentre,jcentre
! initialize variables

        count = 0
        ps1d = 0d0

! Work out which value of l each pixel corresponds to and add up
! the power for each l

!write(*,*) size(map)

     Do i = 0,nx-1
        Do j = 0,ny-1
           uvdist = uvcell * Sqrt(real(i-nx/2)**2+real(j-ny/2)**2)

           l = uvdist

           If((l .le. lmax)) Then
           	  !write(*,*)'l',l,i,j

              ps1d(l) = ps1d(l)+Abs(map(i,j))**2
              count(l) = count(l) + 1
             ! write(*,*)'count(l)', count(l)
          End if
         End Do
      End Do

! the azimuthal average is scaled by uvcell**2

      !ps1d = ps1d * (2.0*pi*uvcell)**2

      !sumps=0.
      !Do k=lmin,lmax
      !   If(ps1d(k).ne.0) Then
       !     sumps = sumps+ps1d(k)
       do l = 1, lmax, 1

           	if ( count(l)/=0 ) then !! prevent by 0 division

            ps1d(l) = ps1d(l)/count(l)

           ! write(*,*) l,'  ',ps1d(l)

        end if

        end do

       !  Endif
     ! End Do

      ! Normalise sumps by map size
      !sumps = sumps * uvcell**2

     ! Write(*,*) 'Sqrt(total power) = ', sqrt(sumps)

        END SUBROUTINE ps_azim

 Subroutine read_camb(infile, cl_array, lmax)

    Use healpix_types

    Implicit none

    Character (len = *), intent(IN) :: infile
    Integer(I4B), intent(INOUT) :: lmax
    Real(DP), Intent(OUT), Dimension(0:lmax,1:2) :: cl_array

    Real(DP) :: clT,clE,clET,clphi
    Integer :: lval = 0
    Real(DP) :: cmbT = 2.726d0
    cl_array(0:1,:)=0
    ! Read in the cl values and convert to units of uK^2
    Open (Unit = 23, file = infile, status = 'old', action = 'read', err = 9980)
    Do while (lval .LT. lmax)
       Read (23, *, end = 800) lval, clT,clE,clET,clphi
       cl_array(lval,1) = clT!/(lval*(lval+1))*cmbT*cmbT*1.d12*TWOPI
       cl_array(lval,2) = clphi!/(lval**4)*cmbT*cmbT*1.d12*TWOPI

    End Do
800 lmax = lval

    Close (23)
    Return

9980 Stop 'Error opening cl file to read'

  End Subroutine read_camb

end module sub_flatlens


text:
module sources

  use core_lib
  use mpi_core
  use mpi_hdf5_io

  use type_source
  use type_photon
  use dust_main
  use type_vector3d
  use settings

  use grid_geometry, only : place_in_cell

  implicit none
  save

  private
  public :: setup_sources
  public :: add_source
  public :: find_nearest_source
  public :: emit
  public :: emit_peeloff

  integer,public :: n_sources = 0
  ! number of sources

  type(source),allocatable,dimension(:),public :: s
  ! the sources

  type(pdf_discrete_dp),public :: luminosity
  ! relative luminosity of all the sources

  real(dp),public :: energy_total   = 0._dp
  real(dp),public :: energy_current = 0._dp

  integer :: is
  ! loop variable

  integer(idp) :: photon_counter = 0

  logical :: any_intersect = .false.

  logical, public :: sample_sources_evenly = .false.

contains

  subroutine setup_sources(group)

    implicit none

    integer(hid_t),intent(in) :: group
    character(len=30),allocatable :: source_names(:)
    integer(hid_t) :: g_source

    if(main_process()) write(*,'(" [sources] setting up sources")')

    call mp_list_groups(group, '.', source_names)

    n_sources = size(source_names)
    allocate(s(n_sources))

    do is=1,n_sources
       g_source = mp_open_group(group, source_names(is))
       call source_read(g_source, s(is))
       call mp_close_group(g_source)
       if(s(is)%intersect) any_intersect = .true.
    end do

    ! flux = flux / nu
    ! energy = h*nu
    ! flux should represent number of photons or at least the relative number. Normalise such that integral = number of photons
    ! then flux * h*nu gives total energy without normalisation, luminosity over that gives normalization factor.

    if(n_sources > 0) then
       call set_pdf(luminosity,s(:)%luminosity)
       energy_total = sum(s(:)%luminosity)
    else
       energy_total = 0._dp
    end if

  end subroutine setup_sources

  subroutine add_source(new_source)
    implicit none
    type(source),intent(in) :: new_source
    type(source),allocatable :: tmp_s(:)
    allocate(tmp_s(n_sources))
    tmp_s = s
    deallocate(s)
    allocate(s(n_sources + 1))
    s(1:n_sources) = tmp_s(1:n_sources)
    s(n_sources+1) = new_source
    n_sources = n_sources + 1
    if(new_source%intersect) any_intersect = .true.
    call set_pdf(luminosity,s(:)%luminosity)
    energy_total = sum(s(:)%luminosity)
  end subroutine add_source

  subroutine emit(p,reemit,reemit_id,reemit_energy,inu)

    implicit none

    type(photon),intent(out) :: p
    ! the emitted photon

    logical,intent(in),optional :: reemit
    integer,intent(in),optional :: reemit_id
    real(dp),intent(in),optional :: reemit_energy
    integer,intent(in),optional :: inu
    logical :: do_reemit
    real(dp) :: xi

    if(n_sources==0) call error("emit", "no sources to emit from")

    ! --- First, decide which source to sample from --- !

    if(n_sources > 1) then
       if(sample_sources_evenly) then
          call random(xi)
          p%source_id = int(xi*n_sources) + 1
       else
          p%source_id = sample_pdf(luminosity)
       end if
    else
       p%source_id = 1
    end if

    if(present(reemit)) then
       do_reemit = reemit
    else
       do_reemit = .false.
    end if

    if(do_reemit) then
       if(present(reemit_id)) then
          p%source_id = reemit_id
       else
          call error("emit", "reemit_id is missing")
       end if
    end if

    ! --- Then emit the photon --- !

    if(present(inu)) then
       call source_emit(s(p%source_id),p,nu=frequencies(inu))
       p%inu = inu
    else
       call source_emit(s(p%source_id),p)
    end if

    call angle3d_to_vector3d(p%a,p%v)

    if(do_reemit) then
       if(present(reemit_energy)) then
          p%energy = reemit_energy
       else
          call error("emit", "reemit_energy is missing")
       end if
    else
       if(present(inu)) p%energy = p%energy * energy_total
       if(sample_sources_evenly) p%energy = p%energy * luminosity%pdf(p%source_id) * n_sources
       energy_current = energy_current + p%energy
    end if

    call prepare_photon(p)
    call update_optconsts(p)

    p%emiss_type = s(p%source_id)%freq_type

    photon_counter = photon_counter + 1
    p%id = photon_counter

    p%last = 'sr'

    call place_in_cell(p)
    if(p%killed) call error("emit", "photon was not emitted inside a cell - this usually indicates that a source is not inside the grid")

  end subroutine emit

  subroutine emit_peeloff(p,a_req)
    implicit none
    type(photon),intent(inout) :: p ! the photon to peeloff
    type(angle3d_dp),intent(in) :: a_req ! requested angle
    call source_emit_peeloff(s(p%source_id),p,a_req)
    call angle3d_to_vector3d(p%a,p%v)
  end subroutine emit_peeloff

  logical function intersects_sources(r1,r2)

    type(vector3d_dp),intent(in) :: r1,r2
    integer :: is

    do is=1,n_sources
       if(source_intersect(s(is),r1,r2)) then
          intersects_sources = .true.
          return
       end if
    end do

    intersects_sources = .false.
    return

  end function intersects_sources

  subroutine find_nearest_source(r,v,nearest_distance,nearest_id)

    type(vector3d_dp),intent(in) :: r,v
    integer :: is
    real(dp),intent(out) :: nearest_distance
    integer,intent(out) :: nearest_id

    nearest_id = 0
    nearest_distance = infinity_dp()

    if(.not.any_intersect) return

    do is=1,n_sources
       if(s(is)%intersect) then
          if(source_distance(s(is),r,v) < nearest_distance) then
             nearest_distance = source_distance(s(is),r,v)
             nearest_id = is
          end if
       end if
    end do

  end subroutine find_nearest_source

end module sources

max_stars_repo_name: christopherlovell/hyperion

max_issues_repo_name: christopherlovell/hyperion

max_forks_repo_name: christopherlovell/hyperion


text:
Andre Lee is a fourthyear student at UC Davis majoring in Political Science and Sociology. He is a second term ASUCD senate ASUCD senator (one of the few in modern ASUCD history). He initially ran in the Fall 2009 ASUCD Election under the LEAD slate, and was reelected for a second term in the Fall 2010 ASUCD election as a candidate on the BOLD slate. He is currently the Senate ProTempore.

Candidate Statement Fall 2010 Election

Hi Everyone! My name is Andre Lee and I’m running for REELECTION to ASUCD Senate. As a candidate running for reelection, I can bring what no other candidate can bring to the table: no learning curve, experience, and a record of proven effectiveness in student government.

I love UC Davis and I love ASUCD: as a sitting senator, I’ve served twice as President Pro Tempore of the Senate, and I’ve written more legislation and invested more money into the association than any other Senator, working to obtain nearly $30,000 of new equipment and technology for all of ASUCD’s services. I helped make Greek philanthropy events zerowaste, worked to make the Quad on Picnic Day use only compostable dining ware, produced a bike safety video and brochure hundreds of freshmen saw during Welcome Week, and advocated for ASUCD’s quarterly blood drives. I’ve never missed a Senate meeting and I have one of the best attendance records of any sitting Senator.

2010 PLATFORM ISSUES: I want one more year serving as your Senator because I want to continue bringing smart investments, sustainable practices, and good management to the association.

FIRST, I want TO EXPAND AND IMPROVE TIPSY TAXI SERVICES. With my fellow runningmate Matt Provencher, I want to make sure you can use your credit card and student ID on Tipsy Taxi buses, call to reserve a pickup as much as 2 hours ahead, and use your online browser, text, or smartphone applications to call the service and GPSlocate the buses.

SECOND, I want to RENOVATE THE BIKE BARN. ASUCD needs to take better care of its units, and we need to give the Bike Barn some major structural improvements so that we have a building for student services we can be proud of.

THIRD, I want to establish a ZEROWASTE COMPOSTABLES PROGRAM FOR UC DAVIS STUDENT ORGANIZATIONS. If your organization does a food event, I want to offer ASUCD sponsorship to make your event zerowaste. You’ll be able to buy any compostable product you need right here at the Memorial Union at a competitive price. It’s a great way for student organizations and ASUCD to partner in helping reduce waste.

I’m a fourth year political science, sociology and philosophy triple major and Regents Scholar with a 3.9 GPA. I’ve worked on the ASUCD External Affairs Commission, as a reporter California Aggie, and as a tour guide for Undergraduate Admissions. I’m a proud brother of the Delta Chi Fraternity. I’m Korean by blood, Brazilian by birth, and American by heart. As a zerogeneration immigrant, I’ve grown up believing that in America, success means work and work means success. As a sitting ASUCD Senator, I’ve worked hard to represent students and provide them with effective student government. And with your vote, I promise you that I can do it again.

VOTE ANDRE LEE #1 FOR ASUCD SENATE, BOLD #25!

Candidate Statement Fall 2009 Election

A SHORT INTRODUCTION...
Hey everyone! My name is Andre Lee and I’m a thirdyear political science and sociology double major. I’m running as a L.E.A.D. candidate for ASUCD Senate because I believe UC Davis is a community filled with students who care about policies that work, and work to make Davis better—that’s why I’m pushing for the three S’s: safety, sustainability, and student health.

I encourage you to read the web links below. They’ll provide you with real examples of how my proposals will flesh out once I’m elected. What sets me apart from other candidates? My platform issues are based on examples that work. I’m here to deliver, and I know I have the experience it takes to work with Davis students in turning those goals into reality.

Like many of you and your families, I came here as an immigrant. I’m Korean by blood, Brazilian by birth, and American by heart. If there’s anything I learned from my background, it’s that the American Dream means working hard to make things happen. I want to work hard to put ASUCD’s $10 million dollar budget to good use.

But to do it, I need your help! Read about my experience and my proposals. Check out the links. Tell your friends! And finally, if you have any ideas, questions, or concerns (or you just want to get to know me better) don’t hesitate to contact me: (424) 2418739 or akblee@ucdavis.edu.

EXPERIENCE AND QUALIFICATIONS:
I’ve had a depth of experience inside and outside campus, all while managing two majors, taking an average of 20 units a quarter, with a 3.9 GPA. I plan declare a third major in Philosophy by the end of the school year.

University of California Regents Scholar
Integrated Studies Honors Program
Sociology Honors Program
Delta Chi Fraternity: Kappa Class President and Scholarship Chair
ASUCD External Affairs Commission: Vice Chair
California Aggie Newspaper: Features Section Writer and Staff Writer
Campus tour guide
Partners in Acquiring Language (PAL) volunteer

Executive Intern for Susan Kennedy, Chief of Staff to Governor Arnold Schwarzenegger
Intern for Caritas Internationalis in Brazil
Intern for CALPIRG, Hunger and Homelessness Campaign

PLATFORM: Safety, Sustainability, and Student Health

SAFETY
DECREASE BIKE THEFT ON CAMPUS: Chances are that you’ve had your bike stolen or know someone who has. Students are fed up paying benjamins for bikes, only to have their property stolen on campus. I promise to work with TAPS, Campus Unions, the Bookstore and other campus organizations to create programs targeted at reducing bike theft. To decrease bike theft, I pledge to:
1) Start a campuswide campaign aimed at informing students on the best types of locks, how to lock their bikes, what to lock them to, where to buy supplies, and plenty of tips on safety, maintenance, and city and campus regulations. The best way to combat bike theft is to keep the public informed.
2) Work with Student Housing and Admissions to create a video for Freshman Orientation geared towards educating freshmen on simple and proven tips for bike safety and maintenance. I want to make sure every freshman comes to school knowing how to navigate Davis by bike.
3) Fight to make Davis the first university nationwide with a public bikesharing system. Students, especially commuters by car or by Unitrans, need a green way to get around UC Davis’ 3,000 acre campus and the surrounding city. UC Davis students decades ago pushed for city policies that encouraged bikefriendly infrastructure. Now, students should be leading the next push for bikefriendly initiatives.

Check out how Chicago’s St. Xavier University did it using the university’s ID system:
1.http://www.chitowndailynews.org/Chicago_news/Bike_rentals_are_newest_green_initiative_at_St_Xavier,24189
2.http://www.chitowndailynews.org/Chicago_news/Bike_rentals_start_this_week_at_St_Xavier,25645#

Here’s an editorial in the Iowa City newspaper (a city with similar demographics to Davis) regarding the benefits of public bikes:
“Public bike system would unclutter downtown and be ecofriendly”
http://www.dailyiowan.com/2009/05/14/Opinions/11505.html

SUSTAINABILITY
EXPANSION OF RECYCLING AND ZEROWASTE EFFORTS: Anything funded by ASUCD should have policies that minimize impact to the environment. Printing doublesided is a great start, but we can do better. To greenup Davis, I will:
1) Make Picnic Day 2010 the first zerowaste Picnic Day in UC Davis history. By using Whole Earth Festival’s zerowaste program and Relay for Life’s excellent recycling program as templates—and working with Campus Center for the Environment, Project Compost, the Environmental Policy and Planning Commission (EPPC) and R4 Recycling—we can make Davis’ annual open house a model for environmental sustainability.
2) By using the successful zerowaste program set up for Whole Earth Festival, and Relay for Life’s excellent recycling program, as templates—and working with Campus Center for the Environment, Project Compost, the Environmental Policy and Planning Commission (EPPC) and R4 Recycling—we can make Davis’ annual open house a model for environmental sustainability.
3) Make the ASUCD offices in the Memorial Union zerowaste by June 2010. Student government must lead by setting an example.
4) Create a “Green the Greeks” program designed to encourage sustainability in the Greek community: Our Greek community is responsible for a wide range of social and philanthropy events that include many students and, consequently, produce a lot of waste. ASUCD and fraternities and sororities can work to make sure that all Greek events are models for sustainability.

Check out the article I wrote in the California Aggie about Whole Earth Festival’s ZeroWaste program:
http://theaggie.org/article/fortiethannualwholeearthfestivaltakesplacethisweekend

A 10/13 New York times on the zerowaste movement:
http://www.nytimes.com/2009/10/20/science/earth/20trash.html?_r1&scp1&sqzero%20waste&stcse

Links to “Green Greeks” programs nationwide:
UCLA: http://greenthegreeks.org/
University of Michigan: http://www.umich.edu/~grngrks/mission.html
University of Florida: http://ufgreeksgoinggreen.wordpress.com/

STUDENT HEALTH
CREATE A STUDENT REST CENTER IN THE MEMORIAL UNION: Students are tired of being tired. Our friends at Cowell and Health Education and Promotion (HEP) constantly remind us that college students are sleepdeprived, a condition that can make us irritable, unfocused, and unhealthy. Most students don’t have the luxury of going back home for some naptime before their next class. So instead, we’re getting our 20minute nap in lectures and on benches.
It’s time for ASUCD to step up and provide students with a rest center dedicated to the forgotten art form of R&R. This lounge would provide eye masks, ear plugs, and a thorough choice of bean bags, couches and mats for students’ power naps or just some simple rest and relaxation. A single staffer can take your ID card, the time you want to be woken up, and place your possessions securely behind the desk. Throw in some tea and candles, and you have an oasis in the desert of your hectic life, right here in the Memorial Union. Sound farfetched? It’s already been done, at the University of Colorado Boulder, where students can rest and nap for free at “Siesta”, located at their own student union. Click the links below to learn more:

A 10/20 California Aggie on sleep deprivation:
http://theaggie.org/article/2009/10/20/studyexaminesacademicsocialcausesofsleepdeprivation

How they did it in Boulder, Colorado:
http://www.innovations.harvard.edu/news/152301.html

20101022 22:36:36 nbsp Out of curiosity, are you just running on the same things as last time or coming up with new things? Users/EliYani


text: x <= a or  not a;


text:
      recursive function evapol(tu,nu,tv,nv,c,rad,x,y) result(e_res)
      implicit none
      real*8 :: e_res
c  function program evacir evaluates the function f(x,y) = s(u,v),
c  defined through the transformation
c      x = u*rad(v)*cos(v)    y = u*rad(v)*sin(v)
c  and where s(u,v) is a bicubic spline ( 0<=u<=1 , -pi<=v<=pi ), given
c  in its standard b-spline representation.
c
c  calling sequence:
c     f = evapol(tu,nu,tv,nv,c,rad,x,y)
c
c  input parameters:
c   tu    : real array, length nu, which contains the position of the
c           knots in the u-direction.
c   nu    : integer, giving the total number of knots in the u-direction
c   tv    : real array, length nv, which contains the position of the
c           knots in the v-direction.
c   nv    : integer, giving the total number of knots in the v-direction
c   c     : real array, length (nu-4)*(nv-4), which contains the
c           b-spline coefficients.
c   rad   : real function subprogram, defining the boundary of the
c           approximation domain. must be declared external in the
c           calling (sub)-program
c   x,y   : real values.
c           before entry x and y must be set to the co-ordinates of
c           the point where f(x,y) must be evaluated.
c
c  output parameter:
c   f     : real
c           on exit f contains the value of f(x,y)
c
c  other subroutines required:
c    bispev,fpbisp,fpbspl
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1989
c
c  ..scalar arguments..
      integer nu,nv
      real*8 x,y
c  ..array arguments..
      real*8 tu(nu),tv(nv),c((nu-4)*(nv-4))
c  ..user specified function
      real*8 rad
c  ..local scalars..
      integer ier
      real*8 u,v,r,f,one,dist
c  ..local arrays
      real*8 wrk(8)
      integer iwrk(2)
c  ..function references
      real*8 atan2,sqrt
c  ..
c  calculate the (u,v)-coordinates of the given point.
      one = 1
      u = 0.
      v = 0.
      dist = x**2+y**2
      if(dist.le.0.) go to 10
      v = atan2(y,x)
      r = rad(v)
      if(r.le.0.) go to 10
      u = sqrt(dist)/r
      if(u.gt.one) u = one
c  evaluate s(u,v)
  10  call bispev(tu,nu,tv,nv,c,3,3,u,1,v,1,f,wrk,8,iwrk,2,ier)
      e_res = f
      return
      end

max_stars_repo_name: jcampbell/scipy

max_issues_repo_name: jcampbell/scipy

max_forks_repo_name: jcampbell/scipy


text:
         OPEN(NEWUNIT=u,FILE=TRIM(filename),STATUS='OLD',ACTION='READ')
         READ(u,*) nrows, ncols, header
         ALLOCATE(res(nrows,ncols))
         IF (header) THEN
            READ(u,*)
         END IF
         DO r= 1, nrows
            READ(u,*) (res(r,c),c = 1, ncols)
         END DO
         CLOSE(u)

max_stars_repo_name: ecasglez/FortranUtilities

max_issues_repo_name: ecasglez/FortranUtilities

max_forks_repo_name: ecasglez/FortranUtilities


text:
      subroutine dt3q(d1,q2,t3,edt3q)

      implicit double precision(a-h,o-z)

      dimension d1(3),q2(3,3),t3(3,3,3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dimension a(10),b(10)

      a(1)=t3(1,1,1)
      a(2)=t3(1,1,2)
      a(3)=t3(1,1,3)
      a(4)=t3(1,2,2)
      a(5)=t3(1,2,3)
      a(6)=t3(1,3,3)
      a(7)=t3(2,2,2)
      a(8)=t3(2,2,3)
      a(9)=t3(2,3,3)
      a(10)=t3(3,3,3)

      b(1)=d1(1)*q2(1,1)
      b(2)=2.d0*d1(1)*q2(1,2)+d1(2)*q2(1,1)
      b(3)=2.d0*d1(1)*q2(1,3)+d1(3)*q2(1,1)
      b(4)=2.d0*d1(2)*q2(1,2)+d1(1)*q2(2,2)
      b(5)=2.d0*(d1(1)*q2(2,3)+d1(2)*q2(1,3)+d1(3)*q2(1,2))
      b(6)=2.d0*d1(3)*q2(1,3)+d1(1)*q2(3,3)
      b(7)=d1(2)*q2(2,2)
      b(8)=2.d0*d1(2)*q2(2,3)+d1(3)*q2(2,2)
      b(9)=2.d0*d1(3)*q2(2,3)+d1(2)*q2(3,3)
      b(10)=d1(3)*q2(3,3)

      edt3q=a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+a(4)*b(4)+
     .      a(5)*b(5)+a(6)*b(6)+a(7)*b(7)+a(8)*b(8)+a(9)*b(9)+
     .      a(10)*b(10)

      return
      end

max_stars_repo_name: mickcollins/SMFA

max_issues_repo_name: mickcollins/SMFA

max_forks_repo_name: mickcollins/SMFAPAC


text:
Linda Duval and Cathy Speck are a folkpop duo who perform occasionally around Davis coffee houses, the Farmers Market, and The Coop. They often collaborate with other musicians in groups such as The Essentials and She 3.

Duval Speck have two albums, Green Eye, Blue Eye, released in 1998, and Thanks For Waiting, released in 2008. You can buy both at Davis Food Coop The Coop or contact them. They used to host the annual Womens Music Nite, where female singer/songwriters from all over come to showcase their talents. However, most of their activities have been greatly curtailed as http://www.cathydyingasliving.com/about/ Cathy has been battling http://en.wikipedia.org/wiki/Amyotrophic_lateral_sclerosis ALS, otherwise known as Lou Gehrig’s Disease. She blogs and sings about this (blog+songblong) at her http://www.cathydyingasliving.com/ blong.

Linda and Cathy were featured in the http://www.californiaaggie.com/media/storage/paper981/news/2004/03/01/FrontPage/Local.Gay.Couple.Ties.The.Knot.In.San.Francisco1316719.shtml?norewrite200606081653&sourcedomainwww.californiaaggie.com California Aggie after they were married in San Francisco.

In November 2013, Duval Speck received the Harmony in Our Lives Award.

http://www.duvalspeck.com

 Discography

 Greeneye Blueeye (1998)
Released on Surreymoon Music (BMI). Guest musicians include Karen Almquist (slide guitar), Rick Zamora (electric guitar), Carla Campbell (Percussion), Andrew Enberg (drums), Joey Wisgirda (trumpet), Marty OHara (bass), Mary Madison (harmony vocals), Dave Rosenfeld (violin & mandolin).

 1. White Dog
 2. Lights Out!
 3. Only Love
 4. Dont Fall Asleep
 5. Ashes
 6. Sweet Beyond
 7. Skinny
 8. Secret Meadow
 9. Greeneye Blueeye
 10. Kiss Me In Public
 11. Misty Rain
 12. Goodbye

Words and music by Linda Duval & Cathy Speck except for the music for #6, which was adapted from a Polish folk melody by M. Dutkiewicz, and the music for #8, which was cowritten with Paul Robins.


text:
      Program ratios_of_loop_program_output

!!Control file for program RATIOS_OF_LOOP_PROGRAM_OUTPUT
!! As many comment lines as desired, each starting with "!"
!! The string "pp:" indicates a new set of processing parameters
!! to be applied to the following smc files.  The parameters are given on the
!! following lines.
!! Revision of program involving a change in the control file on this date:
!! This version of the program assumes that the format of the two files to be used in computing
!! ratios is the same.  Look at the program ratios_from_rv_td_loop_drvr when that might not
!! be the case.
!   03/03/16
!!Name of summary file:
!  ratios_of_loop_program_output.sum
!!Name of output file:
!  ratios_of_loop_program_output.out
!!Relative accuracy of period to be equal (dPer/Per):
! 0.001
!!Output from which program?
!! 1 = tmrsk_loop_rv_drvr
!! 2 = tmrsk_loop_td_drvr
!! 3 = fmrsk_loop_fas_drvr
! 1
!!Lines to skip in files 1 and 2 to reach simulation values (for tmrsk_loop_rv_drvr output
!! this is 3).  Enter values for file 1, then file 2
! 3
! 3
!!ncols2read and ncol4gmim for files 1 and 2.
!! For tmrsk_loop_rv_drvr or tmrsk_loop_td_drvr output with the option for less output:
!!   ncols2read=14, and ncol4gmim = 13 or 14 for units of g or cgs, respectively.
!! For fmrsk_loop_fas_drvr:
!!   ncols2read=13, and ncol4gmim = 12 or 13 for D or A FS respectively.
!!Note that this version of the program assumes the less output option
!! for the tmrsk_loop_rv_drvr or tmrsk_loop_td_drvr programs
!! Enter values for file 1, then file 2
! 14 13
! 14 13
!!List of smsim files,  The ratios will be both file1/file2 and file2/file1
!! NOTE: This version is not completely general, as it assumes that the
!! first file was made using the RV program (this assumption is needed
!! in order to extract the various durations).
!!
!tmrsk_loop_rv_drvr.ena.scf.bt15scr_fff.bs11_atten.bt15_dp.dmb_3kps_amps_aoi_00.bt15e_drms.col
!tmrsk_loop_rv_drvr.ena.scf.bt15scr_fff.bs11_atten.bt15_dp.dmb_avg_bc_amps.bt15e_drms.col

! Dates: 03/03/16 - Written by D. Boore, based on ratios_from_rv_td_loop_drvr.for

      real dum(60)
      real per_f2, per_f1
      real m_f2, m_f1
      real rjb_f1, rjb_f2, h_f1, h_f2, rrup_f1, rrup_f2, fff_f1, fff_f2
      real stress_f1, stress_f2
      integer numsrc_f1, numsrc_f2, which_program
      real sd_f2_am, sd_f2_gm, sd_f1
      real durex_f1, trms_f1
      real k0_f1, k0_f2

      character f_f2*200, f_f1*200, f_out*200
      character cmnts2skip(50)*80, buf*200, buf4*4

      integer, parameter :: ncol2read_f1 = 16, ncol2read_f2 = 16

      integer status

      character date_ctl_correct*8, date_ctl_in*30

      character f_ctl*200, f_sum*200
      logical f_exist, skip_pga, skip_pgv

      f_exist = .false.
      do while (.not. f_exist)
        f_ctl = ' '
        write(*, '(a\)')
     :    ' Enter name of control file '//
     :    '(cr=ratios_of_loop_program_output.ctl;'//
     :    ' ctl-brk to quit): '
        read(*, '(a)') f_ctl
        if (f_ctl(1:4) .eq. '    ')
     :               f_ctl = 'ratios_of_loop_program_output.ctl'
        call trim_c(f_ctl, nc_f_ctl)
        inquire(file=f_ctl(1:nc_f_ctl), exist=f_exist)
        if (.not. f_exist) then
          write(*,'(a)') ' ******* FILE DOES NOT EXIST ******* '
        end if
      end do

      call get_lun(nu_ctl)
      open(unit=nu_ctl,file=f_ctl(1:nc_f_ctl),status='unknown')

      call skipcmnt(nu_ctl, cmnts2skip,nc_cmnts2skip)
      date_ctl_in = ' '
      read(nu_ctl,'(a)') date_ctl_in
      call trim_c(date_ctl_in,nc_date_ctl_in)

      date_ctl_correct = ' '
      date_ctl_correct = '03/03/16'
      call trim_c(date_ctl_correct,nc_date_ctl_correct)

      if (date_ctl_correct(1:nc_date_ctl_correct) .ne.
     :    date_ctl_in(1:nc_date_ctl_in)) then
        write(*,'(a)')
     :     ' The control file has the wrong date; update your '//
     :       'control file and rerun the program!'
        close(nu_ctl)
        stop
      end if

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      f_sum = ' '
      read(nu_ctl,'(a)') f_sum
      call trim_c(f_sum,nc_f_sum)
      call get_lun(nu_sum)
      open(unit=nu_sum,file=f_sum(1:nc_f_sum),status='unknown')

      write(nu_sum,'(a)')
     :          ' Output of program ratios_from_rv_td_loop_drvr:'
      write(nu_sum,'(2a)') '   Control file = ', f_ctl(1:nc_f_ctl)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      f_out = ' '
      read(nu_ctl,'(a)') f_out
      call trim_c(f_out,nc_f_out)
      call get_lun(nu_out)
      open(unit=nu_out,file=f_out(1:nc_f_out),status='unknown')
      write(nu_sum,'(2a)') '   Output file = ', f_out(1:nc_f_out)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read(nu_ctl,*) per_epsilon
      write(nu_sum,'(a, 1x,es10.3)')
     :          ' Relative accuracy of periods for equality = ',
     :            per_epsilon

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read(nu_ctl,*) which_program
! 1 = tmrsk_loop_rv_drvr
! 2 = tmrsk_loop_td_drvr
! 3 = fmrsk_loop_fas_drvr

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read(nu_ctl,*) nskip_f1, nskip_f2

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read(nu_ctl,*) ncols2read_f1, ncol4gmim_f1,
     :               ncols2read_f2, ncol4gmim_f2

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)

      f_f1 = ' '
      read(nu_ctl,'(a)') f_f1
      call trim_c(f_f1,nc_f_f1)
      call get_lun(nu_f1)
      open(unit=nu_f1,file=f_f1(1:nc_f_f1),status='unknown')
      write(nu_sum,'(a)') '   Input file 1 = '//f_f1(1:nc_f_f1)
      write(nu_out,'(a)') '   Input file 1 = '//f_f1(1:nc_f_f1)

      f_f2 = ' '
      read(nu_ctl,'(a)') f_f2
      call trim_c(f_f2,nc_f_f2)
      call get_lun(nu_f2)
      open(unit=nu_f2,file=f_f2(1:nc_f_f2),status='unknown')
      write(nu_sum,'(a)') '   Input file 2 = '//f_f2(1:nc_f_f2)
      write(nu_out,'(a)') '   Input file 2 = '//f_f2(1:nc_f_f2)

      close(nu_ctl)

      if (which_program == 1 .or. which_program == 2) then
        write(nu_out,'(
     :     2x,a,
     :     10x,a, 9x,a,
     :     4x,a,
     :     2x,a, 2x,a,
     :     4x,a, 4x,a,
     :     1x,a, 1x,a,
     :     2x,a, 2x,a,
     A     2x,a, 2x,a,
     :     1x,a, 1x,a,
     :     1x,a, 1x,a,
     :     2x,a, 2x,a,
     :     9x,a, 9x,a,
     :     6x,a, 6x,a,
     :     2x,a, 2x,a
     :                     )')
     :    'damp',
     :    'per', 'freq',
     :    'm',
     :    'Rjb_f1', 'Rjb_f2',
     :    'h_f1', 'h_f2',
     :    'Rrup_f1', 'Rrup_f2',
     :    'FFF_f1', 'FFF_f2',
     A    'Rps_f1', 'Rps_f2',
     :    'k0_f1', 'k0_f2',
     :    'numsrc_f1', 'numsrc_f2',
     :    'stress_f1', 'stress_f2',
     :    'y_f1', 'y_f2',
     :    'f1/f2', 'f2/f1',
     :    '(f1/f2)^2', '(f2/f1)^2'
      else if (which_program == 3) then   ! only difference is damp, so for simplicity do not change this
        write(nu_out,'(
     :     2x,a,
     :     10x,a, 9x,a,
     :     4x,a,
     :     2x,a, 2x,a,
     :     4x,a, 4x,a,
     :     1x,a, 1x,a,
     :     2x,a, 2x,a,
     A     2x,a, 2x,a,
     :     1x,a, 1x,a,
     :     1x,a, 1x,a,
     :     2x,a, 2x,a,
     :     9x,a, 9x,a,
     :     6x,a, 6x,a,
     :     2x,a, 2x,a
     :                     )')
     :    'damp',
     :    'per', 'freq',
     :    'm',
     :    'Rjb_f1', 'Rjb_f2',
     :    'h_f1', 'h_f2',
     :    'Rrup_f1', 'Rrup_f2',
     :    'FFF_f1', 'FFF_f2',
     A    'Rps_f1', 'Rps_f2',
     :    'k0_f1', 'k0_f2',
     :    'numsrc_f1', 'numsrc_f2',
     :    'stress_f1', 'stress_f2',
     :    'y_f1', 'y_f2',
     :    'f1/f2', 'f2/f1',
     :    '(f1/f2)^2', '(f2/f1)^2'
      else
        write(*,'(a, 1x,i3)')
     :     ' Incorrect value of which_program; QUITTING; '//
     :     'which_program = ', which_program
        STOP
      end if

      call skip(nu_f1, nskip_f1)
      call skip(nu_f2, nskip_f2)

      n_tmrs = 0

      loop over tmrsk values: DO

!output from tmrsk_loop_rv_drvr
!   1	        2	    3	   4	   5	6	7	 8	 9     10        11       12           13             14
!damp      T:tmrs      F:tmrs      M     Rjb    h    Rrup     F_FF     Rps     k0 numsource   S:tmrs gmim_dk80(g) gmim_dk80(cgs)

!output from tmrsk_loop_td_drvr
!   1	        2	    3	   4	   5	6	7	8	9     10        11       12           13             14
!damp      T:tmrs      F:tmrs      M     Rjb    h    Rrup    F_FF     Rps     k0 numsource   S:tmrs gmim_dk80(g) gmim_dk80(cgs)

!output from fmrsk_loop_fas_drvr
!      1	   2	  3	  4    5       6       7       8      9        10           11            12            13
! f:fmrs      T:fmrs      M     Rjb    h    Rrup    F_FF     Rps     k0 numsource       S:fmrs fds(cgs):fmrs fas(cgs):fmrs

          dum = 0.0
          read(nu_f1,*,iostat=status) (dum(i), i=1,ncols2read_f1)
          if (status /= 0) then
            close(nu_f1)
            EXIT loop over tmrsk values
          end if
          if (which_program == 1 .or. which_program == 2) then
            damp_f1 = dum(1)
            per_f1 = dum(2)
            freq_f1 = dum(3)
            m_f1   = dum(4)
            rjb_f1    = dum(5)
            h_f1      = dum(6)
            rrup_f1   = dum(7)
            fff_f1    = dum(8)
            rps_f1    = dum(9)
            k0_f1     = dum(10)
            numsrc_f1 = int(dum(11))
            stress_f1 = dum(12)
            y_f1 = dum(ncol4gmim_f1)
          else                           ! fmrsk_loop_fas_drvr
            damp_f1 = 9.999
            freq_f1 = dum(1)
            per_f1 = dum(2)
            m_f1   = dum(3)
            rjb_f1    = dum(4)
            h_f1      = dum(5)
            rrup_f1   = dum(6)
            fff_f1    = dum(7)
            rps_f1    = dum(8)
            k0_f1     = dum(9)
            numsrc_f1 = int(dum(10))
            stress_f1 = dum(11)
            y_f1 = dum(ncol4gmim_f1)
          end if

          dum = 0.0
          read(nu_f2,*,iostat=status) (dum(i), i=1,ncols2read_f2)
          if (status /= 0) then
            close(nu_f2)
            EXIT loop over tmrsk values
          end if
          if (which_program == 1 .or. which_program == 2) then
            damp_f2 = dum(1)
            per_f2 = dum(2)
            freq_f2 = dum(3)
            m_f2   = dum(4)
            rjb_f2    = dum(5)
            h_f2      = dum(6)
            rrup_f2   = dum(7)
            fff_f2    = dum(8)
            rps_f2    = dum(9)
            k0_f2     = dum(10)
            numsrc_f2 = int(dum(11))
            stress_f2 = dum(12)
            y_f2 = dum(ncol4gmim_f2)
          else                           ! fmrsk_loop_fas_drvr
            damp_f2 = 9.999
            freq_f2 = dum(1)
            per_f2 = dum(2)
            m_f2   = dum(3)
            rjb_f2    = dum(4)
            h_f2      = dum(5)
            rrup_f2   = dum(6)
            fff_f2    = dum(7)
            rps_f2    = dum(8)
            k0_f2     = dum(9)
            numsrc_f2 = int(dum(10))
            stress_f2 = dum(11)
            y_f2 = dum(ncol4gmim_f2)
          end if

        n_tmrs = n_tmrs + 1

        if (per_f1 <= 0.0 .or. per_f2 <= 0.0) then
          if (per_f1 /= per_f2) then
            write(*,*)
     :       ' ERROR:  per_f2, per_f1 not equal; QUIT'
            write(nu_sum,*)
     :       ' ERROR:  per_f2, per_f1 not equal; QUIT'
            write(nu_sum,*)
     :       ' n_tmrs, per_f2, per_f1 = ', n_tmrs, per_f2, per_f1
            EXIT loop over tmrsk values
          end if
        else
          if ( abs(per_f2 - per_f1)/per_f2 > per_epsilon) then
            write(*,*)
     :       ' ERROR:  per_f2, per_f1 not equal; QUIT'
            write(nu_sum,*)
     :       ' ERROR:  per_f2, per_f1 not equal; QUIT'
            write(nu_sum,*)
     :       ' n_tmrs, per_f2, per_f1 = ', n_tmrs, per_f2, per_f1
            EXIT loop over tmrsk values
          end if
        end if

        if ( m_f2 /= m_f1 ) then
          print *,
     :       ' ERROR:  m_f2, m_f1  not equal; QUIT'
          print *,
     :       ' n_tmrs, m_f2, m_f1 = ', n_tmrs, m_f2, m_f1
          EXIT loop over tmrsk values
        end if

        if ( abs(rjb_f2 - rjb_f1)/rjb_f2 > per_epsilon ) then  ! use per_epsilon for distance
          print *,
     :       ' ERROR:  rjb_f2, rjb_f1  not epsilon; QUIT'
          print *,
     :       ' n_tmrs, rjb_f2, rjb_f1 = ', n_tmrs, rjb_f2, rjb_f1
            EXIT loop over tmrsk values
        end if

        if ( abs(rps_f2 - rps_f1)/rjb_f2 > per_epsilon ) then  ! use per_epsilon for distance
          print *,
     :       ' ERROR:  rps_f2, rps_f1  not within epsilon; QUIT'
          print *,
     :       ' n_tmrs, rps_f2, rps_f1 = ', n_tmrs, rps_f2, rps_f1
            EXIT loop over tmrsk values
        end if

        if (y_f1 < 0) then
          f1_div_f2 = -999.0
          f1_div_f2_sq = -999.0
          f2_div_f1 = -999.0
          f2_div_f1_sq = -999.0
        else
          f1_div_f2 = y_f1/y_f2
          f1_div_f2_sq = (y_f1/y_f2)**2
          f2_div_f1 = y_f2/y_f1
          f2_div_f1_sq = (y_f2/y_f1)**2
        end if

        write(nu_out,'(
     :    1x,f5.3,
     :    1x,es12.5, 1x,es12.5,
     :    1x,f4.2,
     :    1x,f7.2, 1x,f7.2,
     :    1x,f7.2, 1x,f7.2,
     :    1x,f7.2, 1x,f7.2,
     :    1x,f7.2, 1x,f7.2,
     A    1x,f7.2, 1x,f7.2,
     :    1x,f5.3, 1x,f5.3,
     :    8x,i2,   8x,i2,
     :    4x,f7.2, 4x,f7.2,
     :    1x,es12.5, 1x,es12.5,
     :    2x,f9.4, 2x,f9.4,
     :    2x,f9.4, 2x,f9.4
     :                             )')
     :    damp_f1,
     :    per_f1, freq_f1,
     :    m_f1,
     :    rjb_f1, rjb_f2,
     :    h_f1, h_f2,
     :    rrup_f1, rrup_f2,
     :    fff_f1, fff_f2,
     A    rps_f1, rps_f2,
     :    k0_f1, k0_f2,
     :    numsrc_f1, numsrc_f2,
     :    stress_f1, stress_f2,
     :    y_f1, y_f2,
     :    f1_div_f2, f2_div_f1,
     :    f1_div_f2_sq, f2_div_f1_sq

      END DO loop over tmrsk values

      close(nu_out)
      close(nu_f1)
      close(nu_f2)

      close(nu_sum)

      END

      include '\forprogs\upstr.for'
      include '\forprogs\skipcmnt.for'
      include '\forprogs\trim_c.for'
      include '\forprogs\get_lun.for'
      include '\forprogs\skip.for'

max_stars_repo_name: cliftbar/FlaPyDisaster

max_issues_repo_name: cliftbar/FlaPyDisaster

max_forks_repo_name: cliftbar/FlaPyDisaster


text:
*
*     ------------------------------------------------------------------
*	C F G O 1
*     ------------------------------------------------------------------
*
*	Read configurations for one state, assuming orthogonality of
*       the orbitals
*
      SUBROUTINE CFGO1(NCFG,MAXORB,IAJCMP,LJCOMP,NJCOMP,NOCCSH,
     :                  NELCSH,NOCORB,J1QNRD,NCD,INPUT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NWD=30)
*
      CHARACTER BUFFER(NWD)*3, HEADER*72, INPUT*24
      CHARACTER*1 JAJCLD(NWD,3),JAJCMP(NWD,3),JCQN(9)
      COMMON/INFORM/IREAD,IWRITE,IOUT,ISC0,ISC1,ISC2,ISC3,JSC0,JSC(3)
      COMMON /CLOSED/B1ELC(4),NCLOSD,IAJCLD(NWD),LJCLSD(NWD),IBK
*
      DIMENSION IAJCMP(NWD),LJCOMP(NWD),NJCOMP(NWD),NOCCSH(NCD),
     :          NELCSH(5,NCD),NOCORB(5,NCD),J1QNRD(9,NCD),
     :          J3QN(9),J2QN(9),J1QN(9)
*
    3 FORMAT(18(1X,A3))
    4 FORMAT(3A1)
    5 FORMAT(9(1X,A3,1H(,I2,1H)))
    6 FORMAT(9(1X,4X,I1,A1,I1))
    7 FORMAT(A72)
    8 FORMAT(A3)
   22 FORMAT(// 7H STATE ,' (WITH',I3,' CONFIGURATIONS):'/1H ,31(1H-)/)
   23 FORMAT(/10H THERE ARE,I3,21H ORBITALS AS FOLLOWS://
     : 5X,21(1X,A3):/5X,21(1X,A3))
   25 FORMAT(/14H CONFIGURATION,I3,' ( OCCUPIED ORBITALS=',I2,' ):'
     : ,5(1X,A3,1H(,I2,1H)))
   26 FORMAT(26X,17H COUPLING SCHEME:,5(1X,4X,I1,A1,I1))
   27 FORMAT(54X,4(1X,4X,I1,A1,I1))
   28 FORMAT(/10H THERE ARE ,I3,31H CLOSED SUBSHELLS COMMON TO ALL ,
     :  27H CONFIGURATIONS AS FOLLOWS: //
     :  5X, 21(1X,A3))
*
* --- ANALYZE INPUT DATA
*
      OPEN(UNIT=4,FILE=INPUT,STATUS='OLD')
      CALL ANALY1(IREAD,IWRITE,NCLOSD,MAXORB,0,NCFG,NOCCSH,BUFFER,NCD)
      REWIND(UNIT=IREAD)
*
* ---  Process the configuration data
*
      READ(BUFFER,8) (IAJCMP(I),I=1,MAXORB)
      WRITE(IWRITE,22) NCFG
      WRITE(IWRITE,23) MAXORB,(IAJCMP(I),I=1,MAXORB)
      READ(BUFFER,4)((JAJCMP(I,J),J=1,3),I=1,MAXORB)
      DO 60 I=1,MAXORB
      IF (JAJCMP(I,1) .EQ. ' ') THEN
         JAJCMP(I,1) = JAJCMP(I,2)
         JAJCMP(I,2) = JAJCMP(I,3)
         JAJCMP(I,3) = ' '
      ENDIF
      LJCOMP(I) = LVAL(JAJCMP(I,2))
      NJCOMP(I) = ICHAR(JAJCMP(I,1)) - ICHAR('1') + 1
   60 CONTINUE
*
* --- READ HEADER CARD FOR THE CASE
*
      READ(IREAD,7) HEADER
      WRITE(IOUT,7) HEADER
*
* --- READ IN THE COMMON SET OF CLOSED SUBSHELLS
*
      READ(IREAD,3) (BUFFER(I),I=1,NCLOSD)
      IF (NCLOSD .EQ. 0) GO TO 70
      READ(BUFFER,8) (IAJCLD(I),I=1,NCLOSD)
      WRITE(IWRITE,28) NCLOSD,(IAJCLD(I),I=1,NCLOSD)
      READ(BUFFER,4) ((JAJCLD(I,J),J=1,3),I=1,NCLOSD)
      DO 71 I=1,NCLOSD
      J = 3
      IF (JAJCLD(I,1) .NE. ' ') J = 2
      LJCLSD(I) = LVAL(JAJCLD(I,J))
71    CONTINUE
 70   CONTINUE
*
* --- READ IN (AND PRINT OUT) CONFIGURATIONS ETC. FOR THE STATE UNDER
* --- CONSIDERATION
*
      DO 63 I=1,NCFG
      N=NOCCSH(I)
      READ(IREAD,5)        (NOCORB(J,I),NELCSH(J,I),J=1,N)
      WRITE(IWRITE,25) I,N,(NOCORB(J,I),NELCSH(J,I),J=1,N)
      DO 61 J=1,N
      DO 61 JJ=1,MAXORB
   61 IF(NOCORB(J,I).EQ.IAJCMP(JJ)) NOCORB(J,I)=JJ
      M=2*N-1
      N1=N+1
      READ(IREAD,6)    (J3QN(J),JCQN(J),J1QN(J),J=1,M)
      WRITE(IWRITE,26) (J3QN(J),JCQN(J),J1QN(J),J=1,N)
      IF(N.GT.1) WRITE(IWRITE,27) (J3QN(J),JCQN(J),J1QN(J),J=N1,M)
      DO 62 J=1,M
      J2QN(J) = 2*LVAL(JCQN(J)) + 1
      J1QNRD(J,I) = (J3QN(J)*64 + J2QN(J))*64 + J1QN(J)
   62 CONTINUE
   63 CONTINUE
      CALL CFGTST(NCFG,LJCOMP,NOCCSH,NELCSH,NOCORB,J1QNRD,NCD)
      RETURN
      END


text:
C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE XAXGEN
      IMPLICIT NONE
C
C Purpose: Generate an x-axis
C
      INCLUDE 'COMMON.FOR'
C
C Calls   5: APLOT  , DAWRT  , ERRMSG , GETCHN , GETVAL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    VALUE(10),RMIN,RMAX,XMIN
      INTEGER NCHAN,JCH1,JCH2,IMEM,IFRAME,KREC,JOP,ICLO,IRC,NVAL,I
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 OFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C KREC   : Output file record
C IMEM   : Output memory dataset
C NCHAN  : Nos. of data points in spectrum
C JCH1   : First channel of xaxis
C JCH2   : Last channel of xaxis
C VALUE  : Numeric values entered at terminal
C NVAL   : Nos. of values entered
C RMIN   :
C RMAX   :
C XMIN   :
C
      DATA ICLO/1/ , KREC/1/ , IFRAME/1/ , IMEM/1/
C
C-----------------------------------------------------------------------
      JOP=0
      NCHAN=256
      CALL GETCHN (ITERM,IPRINT,NCHAN,JCH1,JCH2,IRC)
      IF (IRC.EQ.0) THEN
         NCHAN=JCH2-JCH1+1
10       WRITE (IPRINT,1000)
         CALL GETVAL (ITERM,VALUE,NVAL,IRC)
         IF (IRC.EQ.1) GOTO 999
         IF (IRC.EQ.2) GOTO 10
         IF (NVAL.LT.2) THEN
            CALL ERRMSG ('Error: Two values required')
            GOTO 10
         ELSE
            JCH1=INT(VALUE(1))
            RMIN=VALUE(2)
         ENDIF
C
20       WRITE (IPRINT,1000)
         CALL GETVAL (ITERM,VALUE,NVAL,IRC)
         IF (IRC.EQ.1) GOTO 999
         IF (IRC.EQ.2) GOTO 20
         IF (NVAL.LT.2) THEN
            CALL ERRMSG ('Error: Two values required')
            GOTO 20
         ELSE
            JCH2=INT(VALUE(1))
            RMAX=VALUE(2)
         ENDIF
C
         IF (JCH1.EQ.0) JCH1=1
         IF (JCH2.EQ.0) JCH2=NCHAN
         XMIN=(RMAX-RMIN)/INT((JCH2-JCH1))
         SP2(1)=RMIN-(JCH1-1)*XMIN
         DO 30 I=2,NCHAN
            SP2(I)=SP2(1)+XMIN*REAL(I-1)
30       CONTINUE
C
         CALL APLOT (ITERM,IPRINT,SP2,NCHAN)
         CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
         IF (IRC.EQ.0) THEN
            CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                  SP2,KREC,JOP,ICLO,IRC)
         ENDIF
      ENDIF
999   RETURN
C
1000  FORMAT (' Enter channel & value: ',$)
      END


! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! Check that trailing trims are also removed from assignment of
! expressions involving concatenations of strings .
program main
  character(2) :: a,b,c
  character(8) :: d
  a = 'a '
  b = 'b '
  c = 'c '
  d = a // b // a // trim(c)   ! This should be optimized away.
  if (d /= 'a b a c ') call abort
  d = a // trim(b) // c // a   ! This shouldn't.
  if (d /= 'a bc a  ') call abort
  d = a // b // a // trim(trim(c)) ! This should also be optimized away.
  if (d /= 'a b a c ') call abort
end
! { dg-final { scan-tree-dump-times "string_len_trim" 1 "original" } }


text:
! Testing lookahead parsing of char-selector for different
! possible cases of len and kind specs.
program charfuns
  implicit none
  character*10 c
  c = f1("hello")
  c = f2(c)
  c = f3(c)
  c = f4(c)
  c = f5(c)
  c = f6(c)
  c = f7(c)
  c = f8(c)                     !not found by lookahead
  print *, c
contains
  character (len=10) function f1(c)
    character (len=*) c
    f1 = c
  end function f1
  character (len=10, kind=1) function f2(c)
    character (len=10) c
    f2 = c
  end function f2
  character (10, kind=1) function f3(c)
    character (len=10) c
    f3 = c
  end function f3
  character (10, 1) function f4(c)
    character (len=10) c
    f4 = c
  end function f4
  character (kind=1) function f5(c)
    character (len=10) c
    f5 = c
  end function f5
  character (kind=1, len=10) function f6(c)
    character (len=10) c
    f6 = c
  end function f6
  character (len=10, 1) function f7(c) !illegal to omit KIND= here
    character (len=10) c
    f7 = c
  end function f7
  character (kind=1, 10) function f8(c) !illegal to omit LEN= here
    character (len=10) c
    f8 = c
  end function f8
end program charfuns

! external function
character*10 function f8(c)
    character (len=10) c
    f8 = c
end function f8

max_stars_repo_name: kurtsansom/ftnchek

max_issues_repo_name: kurtsansom/ftnchek

max_forks_repo_name: kurtsansom/ftnchek