! { dg-do link }
! { dg-additional-sources "class_4b.f03 class_4c.f03" }
!
! Test the fix for PR41583, in which the different source files
! would generate the same 'vindex' for different class declared
! types.
!
! The test comprises class_4a, class_4b and class_4c.f03

! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module m
  type t
  end type t
end module m
! { dg-final { cleanup-modules "m m2" } }


text:
      subroutine infpar(nowcrp,jdplt,plant,irsyst)
c
c     + + + PURPOSE + + +
c     Calculates sat. hydraulic conductivity and effective matric
c     potential from :
c      1) bare soil hyd. cond.
c      2) avg. potential across wetting front
c      3) effective porosity
c      4) percent ground cover
c      5) percent canopy cover
c      6) relative effective saturation
c
c     Called from SOIL
c     Author(s): Savabi,Risse,Zhang
c     Reference in User Guide: Chapter 4
c
c NOTE: Computation of the fraction of soil surface covered by both
c       canopy and ground cover (COVU) assumes location of ground
c       cover and canopy cover are independent.  Reza Savabi says
c       this is correct.  I would expect the location of the residue
c       to be somewhat dependent on the location of the plants that
c       generated it.  -- CRM (9/14/92 conversation with R. Savabi)
c
c     Changes:
c           1) Common block SOLVAR was not used.  It was de-referenced.
c           2) The generic "SAVE", which saves ALL local variables,
c              was eliminated.
c           3) Eliminated local variables TOTADJ, IPLUG, & NCOUNT.
c           4) Introduced intermediate local variables TMPVR1
c              to TMPVR4 to make calculations more efficient.
c           5) The statement:
c                   if (wetfrt.eq.tc) wetfrt=tc+.00001
c              was changed to:
c                   if(abs(wetfrt-tc) .lt. 0.00001) wetfrt=tc+.00001
c           6) Local variable SAT11 was computed, but the result was
c              never used.  It was eliminated.
c           7) Added local variable RFCUMX so INFPAR could tell if
c              rainfall had occurred.  In my test data sets, this
c              eliminated about 80% of the executions of the code for
c              soil crusting adjustments.
c           8) Changed statement at end of subroutine to prevent a
c              divide by zero occurring in SR ROCHEK - prevents the
c              value of sm(iplane) from becoming zero.  dcf  8/16/93
c           9) Moved RFCUMX to common block cifpar.inc jca2 8/31/93
c          10) Added new Ksat adjustments from Risse and Zhang
c              dcf  1/11/94
c          11) Changes made to Ksat adjustments of Risse and
c              Zhang -  dcf     2/4/94
c          12) Changes made to Ksat adjustment equations again
c              by Nearing - dcf  3/8/94
c          13) Change to Ksat adjustment equations for established
c              perennials from John Zhang - dcf  5/26/94
c          14) Change to Ksat adjustment equations for surface
c              cover(both residue and canopy) adjustments to
c              hydraulic conductivity and also for first year
c              of perennial growth.   dcf  12/14/94
c          15) Change to exclude canopy cover factor in the
c              adjustment for hydraulic conductivity for the case
c              of furrow irrigation water addition.  dcf  12/14/94
c          16) Change statement which checks for water content to
c              be above upper limit so that saturation can occur for
c              a single storm simulation.  savabi and dcf  4/95
c               FROM:     if (st(i,iplane).ge.ul(i)) then
c                 TO:     if (st(i,iplane).ge.0.95*ul(i)) then
c
c     Version: This module recoded from WEPP Version 92.25.
c     Date recoded: 09/03/92 & 10/20/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxelm.inc'
      include 'pmxhil.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxpnd.inc'
      include 'pmxres.inc'
      include 'pmxsrg.inc'
      include 'pntype.inc'
      include 'ptilty.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp, jdplt, plant, irsyst
c
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - index of current crop on the OFE
c     jdplt  - julian planting date of current crop on OFE
c     plant  - index of current plant type on the OFE
c     irsyst - the type of irrigation system: 0 - none
c                                             1 - sprinkler
c                                             2 - furrow
c
c     + + + COMMON BLOCKS + + +
c
      include 'cavepar.inc'
c     modify: avsat(mxplan), avbd(mxplan)
c
      include 'cclim.inc'
c       read: tave
c
      include 'ccons.inc'
c       read: cpm(mxnsl,mxplan)
c     modify: avpor(mxplan)
c
      include 'ccover.inc'
c       read: cancov(mxplan), lanuse(mxplan)
c     modify: gcover(mxplan)
c
      include 'ccrpout.inc'
c       read: rescov(mxplan), bd(mxnsl,mxplan), rtmass(mxplan)
c
      include 'ccrpvr1.inc'
c       read: rtm(mxres,mxplan)
c
      include 'cgcovr.inc'
c       read: gcvplt(mxplan),mantyp(mxplan)
c     modify: gcvplt(mxplan)
c
      include 'chydrol.inc'
c       read: rain(mxplan),prcp
c
      include 'cirfurr.inc'
c     modify: dtheta
c
      include 'cke.inc'
c       read: rkecum(mxplan)
c
      include 'cparame.inc'
c      write: ks(mxplan), sm(mxplan)
c
      include 'cperen1.inc'
c       read: imngmt(mxcrop,mxplan),rtmmax(ntype)
c
      include 'cstmflg.inc'
c       read: norain(mxplan)
c
      include 'cstruc.inc'
c       read: iplane
c
      include 'ctemp.inc'
c       read: avclay(mxplan), avsand(mxplan)
c
      include 'ctillge.inc'
c       read: tillay(2,mxplan)
c
      include 'cwater.inc'
c       read: st(mxnsl,mxplan), ul(mxnsl,mxplan), thetdr(mxnsl,mxplan),
c             nsl(mxplan), dg(mxnsl,mxplan)
c
c     include 'cifpar.inc'
c     modify: rfcumx
c
      include  'cwint.inc'
c
cd    Added by S. Dun, Jan 08, 2008
      include 'cupdate.inc'
cd    End adding
c
c     + + + LOCAL VARIABLES + + +
      real avsm15, avks, sf, wetfrt, a, rra, bbbb, tc, crust(mxplan),
     1    eke, sc, cke, crstad, kbare, ktmp, ccovef, scovef, kcov
     1    ,fzul,ffi,tmpvr1,tmpvr2,tmpvr3,tmpvr4,avcpm
      integer i,tpfzfg
c
c    1    eke, sc, cke, crstad, kbare, ktmp, rtmt, rtmtef, ccovef,
c    1    scovef
c
c     + + + LOCAL DEFINITIONS + + +
c     avsm15 - average 1500 KPa (15 bar) soil water content
c     avks   - average saturated hydralic conductivity for the tillage
c              layer
c     sf     - matric potential across wetting front (m)
c     wetfrt - average depth of wetting front (m)
c     cf     - canopy cover adjustment for saturated hydraulic
c              conductivity
c     a      - macroporosity adjustment for saturated hydraulic
c              conductivity
c     bareu  - bare area under canopy (fraction)
c     bareo  - bare area outside canopy (fraction)
c     covu   - ground cover under canopy (fraction)
c     covo   - ground cover outside canopy (fraction)
c     tc     - crust thickness
c     crust  - crust adjustment for saturated hydraulic conductivity
c     eke    - effective hydraulic conductivity in fill layer
c              (m/sec)
c     sc     - reduction factor for subcrust hydraulic conductivity
c     avcpm  - average rock fragment correction factor for the tillage
c              layer
c     grdcov - ground cover value used in macroporosity calculations
c              for cropland annuals - assigned a value on date of
c              last planting.  For perennials and range - use actual
c              cover values
c     cke    - coefficient relating amount of kinetic energy since last
c              tillage to the speed of crust formation
c     rtmt   - total dead and live root mass in top 15 cm of soil
c              (kg/m**2) (NOT USED)
cc    rtmtef - transformed (live plus dead) root mass
c     ccovef - effective canopy cover corrected for the effect of
c              canopy height
c     scovef - effective total surface cover
c     ktmp   - same as AVKS, only in units of (mm/hr)
c     kbare  - effective AVKS after adjustment for crusting/tillage
c     kcov   - portion of equation to compute effective AVKS
c              (surface cover adjustment)
c     tpfzfg - top layer frozen flag
c              0: no influence of top frozen layer on infiltration
c              1: for there is influence of top frozen layer
c
c     + + + SAVES + + +
      save crust
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c      thickness.  The layers assumed to affect infiltration are the
c      primary (deepest), and [the average of] the secondary tillage
c      layers.)
c
      avbd(iplane) = 0.0
      avpor(iplane) = 0.0
      avsm15 = 0.0
      avcpm = 0.0
      tpfzfg = 0
c
      do 10 i = 1, 2
c ------ ratio of tillage layer thick. to primary (deepest) til. depth
        tmpvr1 = dg(i,iplane) / tillay(2,iplane)
c ------ bulk density
        avbd(iplane) = avbd(iplane) + bd(i,iplane) * tmpvr1
c ------ porosity for infiltration
        avpor(iplane) = avpor(iplane) + por(i,iplane) * tmpvr1
c ------ 15-bar soil water content
        avsm15 = avsm15 + thetdr(i,iplane) * tmpvr1
c ------ correction factor for rock fragments
        avcpm = avcpm + cpm(i,iplane) * tmpvr1
   10 continue
c
c     Range checks:
      if (avpor(iplane).gt.1.0) avpor(iplane) = 1.0
      if (avpor(iplane).lt.0.0) avpor(iplane) = 0.0
      if (avbd(iplane).lt.800.0) avbd(iplane) = 800.0
      if (avbd(iplane).gt.2200.0) avbd(iplane) = 2200.0
c
c ---- Calculate the harmonic mean of Ks in the tillage layer (AVKS)
c      for the infiltration routine.
c
cd    Modified by S. Dun, April 17, 2008
c     for infiltration
c
      if ((frozen(1,iplane) .gt. 0.0).and. (sscv(1,iplane).gt.0.0)
     1     .and.(sscv(2,iplane).gt.0.0) ) then
c
      avks = solthk(2,iplane) / (solthk(1,iplane)/sscv(1,iplane)
     1     + (solthk(2,iplane)-solthk(1,iplane))/sscv(2,iplane))
c
      eke = avks
      tpfzfg = 1
c
      else
      avks = solthk(2,iplane) / (solthk(1,iplane)/ssc(1,iplane)+(
     1    solthk(2,iplane)-solthk(1,iplane))/ssc(2,iplane))
      endif
cd    End Modifying
c
c ---- Calculate average water content in tillage layer (AVSAT)
c      for the infiltration routine.  (ST is constant > 15 bars)
      avsat(iplane) = (st(1,iplane)+st(2,iplane)) / tillay(2,iplane) +
     1    avsm15
      if (avsat(iplane).gt.avpor(iplane)) avsat(iplane) =
     1    avpor(iplane) * .98
c
c ---- Compute the matric potential of the infiltration zone (SF)
c     (WEPP Equation 4.3.2 ff)
c -- XXX -- This equation needs a *number* in the User Document!
c     (See top of p 4.5) -- CRM -- 9/14/92.
      tmpvr2 = avclay(iplane) ** 2
      tmpvr3 = avsand(iplane) ** 2
      tmpvr4 = avpor(iplane) ** 2
c
      sf = 0.01 * exp(6.531-7.33*avpor(iplane)+15.8*tmpvr2+3.81*tmpvr4+
     1    avsand(iplane)*(3.4*avclay(iplane)-4.98*avpor(iplane))+tmpvr4*
     1    (16.1*tmpvr3+16.0*tmpvr2)-14.0*tmpvr3*avclay(iplane)-
     1    avpor(iplane)*(34.8*tmpvr2+8.0*tmpvr3))
      if (sf.gt.0.5) sf = 0.5

c
      if (tpfzfg .ne. 1) then
c     no influence of top frozen layer on infitration.
c     when top frozen layer influence exists, sealing adjudtment is skipped
c
c     *** L0 IF ***
c     CROPLAND
      if (lanuse(iplane).eq.1) then
c
c ------ ground cover (fraction)
        gcover(iplane) = rescov(iplane)
c
c ------ Compute average depth of the wetting front (meters)
c       (WEPP Equation 4.3.11)
        wetfrt = 0.147 - 0.15 * tmpvr3 - (0.0003*avclay(iplane)*
     1      avbd(iplane))
        if (wetfrt.lt.0.005) wetfrt = 0.005
c
c ------ crust thickness
        tc = 0.005
c
c     *** L0 ELSE-IF ***
c     RANGELAND
      else if (lanuse(iplane).eq.2) then
c
c ------ average wetting front depth (meters)
c       (WEPP Equation 4.3.11)
        wetfrt = 0.147 - 0.15 * tmpvr3 - (0.0003*avclay(iplane)*
     1      avbd(iplane))
        if (wetfrt.lt.0.01) wetfrt = 0.01
c
c ------ crust thickness
        tc = 0.01
c
c ------ canopy cover adjustment factor for sat. hydraulic conductivity
c       (WEPP Equation 4.3.12)
c       cf = 1.0 + cancov(iplane)
c
c ------ macroporosity adjustment factor for sat. hydraulic conductivity
        a = exp(6.10-(10.3*avsand(iplane))-(3.7*avclay(iplane)))
        if (a.lt.1.0) a = 1.0
        if (a.gt.10.0) a = 10.0
c
c     *** L0 ELSE ***
c     FOREST
      else
c
c     (This branch left intentionally blank.)
c
c     *** L0 ENDIF ***
      end if
c
c
c     *** M0 IF ***
c     If rainfall or tillage has occurred, compute saturated
c     hydraulic conductivity adjustment for crusted soil surface.
c     if (rfcum.ne.rfcumx) then
c
c ------ correction factor for partial saturation of the sub-crust layer
c     (WEPP Equation 4.3.8)
      sc = 0.736 + (0.19*avsand(iplane))
c
c ------ compute maximum potential crust adjustment fraction
c     (WEPP Equation 4.3.7)
      if (abs(wetfrt-tc).lt.0.00001) wetfrt = tc + .00001
c
c     Use new equation for forming crust - see Rawls et al. 1989
c     Note: This is now maximum adjustment
      ffi = 45.19 - (46.68*sc)
      crust(iplane) = sc / (1.0+(ffi/(wetfrt*100)))
      if (crust(iplane).lt.0.20) crust(iplane) = 0.20
c
c     ************************************************************
c     * Note: CRUST is multiplied times Ksat.  When there is no  *
c     *       crust, Ksat is not adjusted; ie, CRUST = 1.  CRUST *
c     *       is computed in 2 parts.  The second part is the    *
c     *       adjustment for cumulative rainfall since tillage.  *
c     *       It is performed ONLY if RF since tillage is less   *
c     *       than 0.1 m                                         *
c     ************************************************************
c
c-----for CROPLAND, if cumulative RF since tillage is less than
c     1/10 meter, update crust reduction factor for rainfall.
c     New equation inserted Risse
c     crust adjustment=maxadj+(1-maxadj) exp(-C kecum (1-rr/4))
c     where maxadj is the same as it was in previous version with
c     correction for units(crust), C is calculated based on analysis
c     by Risse, and instead of using a linear relationship between 0
c     and 100mm of rfcum we used the exponential relationship of
c     Brakensiek and Rawls, 1983
c     (WEPP Equation 4.3.10)
c     if(lanuse(iplane).eq.1) then
c     Original Code:
c     1                            crust=1.-(((1.-crust)/0.1)*rfcum)
c     1                            crust = 1.0 - (1.0-crust)*10.0*rfcum
c     cke is coeffient relating to speed with which crust forms
c     based on analysis of natural runoff plot data by Risse
c
c-----for CROPLAND, if cumulative RF since tillage is less than
c     1/10 meter, update crust reduction factor for rainfall.
c
      if (lanuse(iplane).eq.1) then
        cke = -0.0028 + 0.0113 * avsand(iplane) + 0.125 *
     1      avclay(iplane) / cec1(1,iplane)
        if (cke.gt.0.01) cke = 0.01
        if (cke.lt.0.0001) cke = 0.0001
c       make sure random roughness does not cause positive exponent
        if (rrc(iplane).le.0.04) then
          rra = rrc(iplane)
        else
          rra = 0.04
        end if
c
        bbbb = -cke * rkecum(iplane) * (1-rra/0.04)
        if (bbbb.lt.-25.0) bbbb = -25.0
c       Calculate crusting/tillage adjustment
        crstad = crust(iplane) + (1-crust(iplane)) * exp(bbbb)
      else
        crstad = 1.0
      end if
c
c     *** M0 ENDIF ***
c     endif
c
c     Adjust AVKS for soil surface characteristics (canopy & cover)
c     and for dead and live roots.    (from zhang 1/94)   dcf
c
        kbare = avks * crstad
        ktmp = avks * 3.6e6
c
c     EXCLUDE the adjustment for canopy cover for the case of
c     snow melt or furrow irrigation.   dcf  12/15/94
c
      if(tave.gt.0.0)then
        if(prcp.gt.0.001 .or. irsyst.eq.1)then
c
c         Adjust the effectiveness of canopy cover by canopy height
c
          ccovef = cancov(iplane) * exp(-0.3358*canhgt(iplane)/2.0)
c
c         Calculate the total effective surface cover
c
          scovef = ccovef + rescov(iplane) - ccovef * rescov(iplane)
c
        else
          scovef = rescov(iplane)
        endif
      else
        scovef = rescov(iplane)
      endif
c
c       Calculate the final effective conductivity
c
c     IF the user has indicated that he/she wants the internal
c     Ksat adjustments used in the SOIL input file - then
c     adjust final effective conductivity for crusting/tillage/
c     crop/rainfall                dcf  1/11/94
c
      if (ksflag.eq.1) then
c
        if(tave.gt.0.0)then
c
c XXX     NOTE - We should really add in the amount of sprinkler
c XXX            irrigation water here (if any exists for the day)
c XXX            but unfortunately at this point in the program we
c XXX            do not yet know what this amount will be (have not
c XXX            call subroutine IRRIG yet).    dcf  12/15/94
c
          kcov = (0.0534 + 0.01179*ktmp) * prcp * 1000.0 / 3.6e6
        else
          kcov = 0.0
        endif
c
c       Zhang change 12/9/94
c       if(kcov .lt. avks)kcov = avks
        if(kcov .lt. 0.5*avks) kcov = 0.5*avks
c
        eke = kbare*(1.0 - scovef) + kcov*scovef
c
c       If crop adjusted eke is smaller than that of crust adjusted
c       set it back to crust adjusted value
c
        if (eke.lt.kbare) eke = kbare
c
c
c       ADJUST FOR ESTABLISHED PERENNIAL CROP (meadows, etc.)
c
c Note - Changed coefficient in equation below from 1.7965 to 1.81
c        when given change from Zhang.   7/1/94   dcf
c
        if(lanuse(iplane).eq.1)then
c
c         Changes to include perennial adjustment for first
c         year of perennial growth when plant is sufficiently
c         developed.   dcf  12/9/94
c         if(imngmt(nowcrp,iplane).eq.2 .and. jdplt.eq.0)
c    1      eke = 1.81 * eke
c
          if(imngmt(nowcrp,iplane).eq.2)then
            if(jdplt .eq. 0)then
              eke = 1.81 * eke
            else
c
c             If the root mass present for the perennial exceeds
c             half of the input maximum possible, then adjust the
c             EKE value by the full amount.  The 0.5 value is
c             arbitrary and could be changed here and below. dcf
c
              if(rtmass(iplane).gt.0.5*rtmmax(plant))then
                eke = 1.81*eke
              else
c
c               Linearly change the eke adjustment based upon the
c               ratio of root mass present to half the maximum
c               root mass possible (input) for the perennial.  The
c               use of the 0.5 value is arbitrary and could be
c               changed here and above.   dcf  12/9/94
c
                eke = eke + (1.62*eke/rtmmax(plant))*rtmass(iplane)
              endif
            endif
          endif
        endif
      else
        eke = avks
      end if
c     Added by S. Dun, May 17, 2008
c     for considering the influence of top frozen layer on infiltration
      endif
c     end adding

cd    Modified by S. Dun 06/20/2002
c     LIMIT MINIMUM KSAT TO 1.94E-08 m/s (0.07 mm/h) for pre
c       2006 soil files.
c
      if (solwpv.eq.2006) then
           if (eke.le.1.0e-14) eke = 3.0e-14
      else
           if (eke.le.1.94e-08) eke = 1.94e-08
      endif
c
cd    adjust the lower limit to e-14 m/s
cd    (the reference we are using is "Physical and Chemical Hydrogeology"
cd     by P.A. Domenico and F.W. Schwartz)
cd    end modifying.
c
c
c     *** BEGIN N0 LOOP ***
c
c     In case a restricted soil layer controls percolation and
c     infiltration....
c
      i = 0
   20 continue
      i = i + 1
c ---- If the water content is above the upper limit for this layer....
c
cd    Modified by S. Dun, April 17, 2008
c      for frozen soil effect
cd      if (st(i,iplane).ge.0.95*ul(i,iplane)) then
c
      fzul =ul(i,iplane) - frzw(i,iplane)
      if (st(i,iplane).ge.0.95*fzul) then
c ------ If this layer's Ksat is less than the average Ksat for the
c        plow layer ....
        if (ssc(i,iplane).le.eke) then
            eke = ssc(i,iplane)
        endif
c
        if ((frdp(iplane) .gt. 0.0).and. (sscv(i,iplane).gt.0.0)
     1     .and. (sscv(i,iplane).le.eke) ) then
c
            eke = sscv(i,iplane)
         endif
cd       End modifying
      else
c ------ (force exit from loop)
        i = nsl(iplane)
      end if
c     *** END N0 LOOP ***
      if (i.lt.nsl(iplane)) go to 20
c
      ks(iplane) = eke
c
c      Write(60, 1505) day, mon, year, eke, kbare, scovef,crstad
c     1                ,crust(iplane),bbbb
1505  format(1x, 3I6, 6E12.3)
c
c     Compute effective matric potential (SM), correcting for rock
c     fragments (using AVCPM).
c
      if (avsat(iplane).ge.(avpor(iplane)*avcpm)) avsat(iplane) = (
     1    avpor(iplane)*avcpm) * 0.99
c ---- compute water above field capacity
      dtheta(iplane) = avpor(iplane) * avcpm - avsat(iplane)
c ---- compute effective matric potential (SM)
      sm(iplane) = dtheta(iplane) * sf
c
c     rfcumx = rfcum
c
      return
      end

ext: for

max_stars_repo_name: jarad/dep

max_issues_repo_name: jarad/dep

max_forks_repo_name: akrherz/idep


MODULE arraymod
  IMPLICIT NONE
  CONTAINS
  SUBROUTINE test_array(array_in)
    INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: array_in

    PRINT *, 'In function, is array allocated :', ALLOCATED(array_in)
    ALLOCATE(array_in(-10:10))

  END SUBROUTINE test_array
END MODULE arraymod

PROGRAM test

  USE arraymod
  IMPLICIT NONE

  INTEGER, DIMENSION(:), ALLOCATABLE :: array
  ALLOCATE(array(0:9))
  CALL test_array(array)
  PRINT *,'After array is array allocated :', ALLOCATED(array)
  PRINT *,'Shape is', SIZE(array), LBOUND(array), UBOUND(array)

END PROGRAM test


text:
! RUN: %S/../test_errors.sh %s %t %flang -fopenacc

! Check OpenACC clause validity for the following construct and directive:
!   2.16.13 Wait

program openacc_wait_validity

  implicit none

  logical :: ifCondition = .TRUE.

  !$acc wait

  !$acc wait async

  !$acc wait(1)
  !$acc wait(1, 2)

  !$acc wait(queues: 1)
  !$acc wait(queues: 1, 2)

  !$acc wait(devnum: 1: 3)
  !$acc wait(devnum: 1: 3, 4)

  !$acc wait(devnum: 1: queues: 3)
  !$acc wait(devnum: 1: queues: 3, 4)

  !$acc wait(1) if(.true.)

  !ERROR: At most one IF clause can appear on the WAIT directive
  !$acc wait(1) if(.true.) if(.false.)

  !$acc wait(1) if(.true.) async

  !$acc wait(1) if(ifCondition) async

  !$acc wait(1) if(.true.) async(1)

  !ERROR: At most one ASYNC clause can appear on the WAIT directive
  !$acc wait(1) if(.true.) async(1) async

end program openacc_wait_validity

max_stars_repo_name: MochalovaAn/llvm

max_issues_repo_name: MochalovaAn/llvm

max_forks_repo_name: MochalovaAn/llvm


text:
Address(Audubon Circle) is a residential street in the Wildhorse region of East Davis.

 Intersecting Streets

  Hartley Street is across Rockwell
  Rockwell Drive
  Bishop Place
  Hopper Place
  Rockwell Drive

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      	program exptest
c-------------------------------------------------------------------
c
c Test program for exponential propagator using Arnoldi approach
c This main program is a very simple test using diagonal matrices
c (Krylov subspace methods are blind to the structure of the matrix
c except for symmetry). This provides a good way of testing the
c accuracy of the method as well as the error estimates.
c
c-------------------------------------------------------------------
        implicit real*8 (a-h,o-z)
        parameter (nmax = 400, ih0=60, ndmx=20,nzmax = 7*nmax)
        real*8 a(nzmax), u(ih0*nmax), w(nmax),w1(nmax),x(nmax),y(nmax)
	integer ioff(10)
	data iout/6/, a0/0.0/, b0/1.0/, epsmac/1.d-10/, eps /1.d-10/
c
c set dimension of matrix
c
	n = 100
c--------------------------- define matrix -----------------------------
c A is a single diagonal matrix (ndiag = 1 and ioff(1) = 0 )
c-----------------------------------------------------------------------
        ndiag = 1
	ioff(1) = 0
c
c-------- entries in the diagonal are uniformly distributed.
c
	h = 1.0d0 / real(n+1)
        do 1 j=1, n
	a(j) = real(j+1)* h
 1	continue
c--------
        write (6,'(10hEnter tn: ,$)')
	read (5,*) tn
c
        write (6,'(36hEpsilon (desired relative accuracy): ,$)')
	read (5,*)  eps
c-------
        write (6,'(36h m (= dimension of Krylov subspace): ,$)')
	read (5,*)  m
c-------
c define initial conditions: chosen so that solution = (1,1,1,1..1)^T
c-------
	do 2 j=1,n
	w(j) = dexp(a(j)*tn)
 2	w1(j) = w(j)
c
         call expprod (n, m, eps, tn, u, w, x, y, a, ioff, ndiag)
c
        print *, ' final answer '
        print *, (w(k),k=1,20)
c
	do 4 k=1,n
 4	w1(k) = dexp(-a(k)*tn) * w1(k)
        print *, ' exact solution '
        print *, (w1(k),k=1,20)
c
c---------- computing actual 2-norm of error ------------------
c
	t = 0.0d0
	do 47 k=1,n
 47	t = t+ (w1(k)-w(k))**2
        t = dsqrt(t / ddot(n, w,1,w,1) )
c
        write (6,*) ' final error', t
c--------------------------------------------------------------
	stop
	end
c-------
	subroutine oped(n,x,y,diag,ioff,ndiag)
c======================================================
c this kernel performs a matrix by vector multiplication
c for a diagonally structured  matrix stored in diagonal
c format
c======================================================
	implicit real*8 (a-h,o-z)
	real*8 x(n), y(n), diag(n,ndiag)
	common nope, nmvec
	integer j, n, ioff(ndiag)
CDIR$ IVDEP
	do 1 j=1, n
		y(j) = 0.00
 1	continue
c
	do 10 j=1,ndiag
	io = ioff(j)
	i1=max0(1,1-io)
	i2=min0(n,n-io)
CDIR$ IVDEP
	do 9 k=i1,i2
	y(k) = y(k)+diag(k,j)*x(k+io)
 9	continue
 10	continue
	nmvec  = nmvec + 1
	nope = nope + 2*ndiag*n
	return
	end
c

max_stars_repo_name: xywei/Mirana

max_issues_repo_name: xywei/Mirana

max_forks_repo_name: xywei/Mirana


text:
	subroutine filt(delt,df,numah,nfilt,zfilt,datin,dat)
c filters waveform datin by applying filter zfilt, output is in dat
	dimension datin(*),dat(*)
c clever use of redimensioning
	dimension zfilt(*)
c
	do 10 i=1,numah
10	    dat(i) =datin(i)

	if (nfilt.gt.numah) then
	    do 20 i=numah+1,nfilt+2
20		dat(i) = 0.
	end if

c fft the data, and pray that sign convention is OK, filter and return
	call fast(dat,nfilt)
	do 30 i=1,nfilt+2,2
	    temp = dat(i)*zfilt(i+1) + dat(i+1)*zfilt(i)
	    dat(i) = dat(i) * zfilt(i) - dat(i+1)*zfilt(i+1)
	    dat(i+1) = temp
30	continue
	dat(nfilt/2+1) = 0.
	dat(nfilt/2+2) = 0.
	call fsst (dat,nfilt)
	return
	end


text:
! This code may (or may not) be part of the COAMPS distribution,
! So it is not protected by the DART copyright agreement.
!
! DART $Id$

!------------------------------
! MODULE:       coamps_statevec_mod
! AUTHOR:       T. R. Whitcomb
!               Naval Research Laboratory
! DART VERSION: Jamaica
!
! Module containing the data structure and routines for dealing with
! a COAMPS state vector (a collection of COAMPS state variables)
!------------------------------

module coamps_statevec_mod

    use coamps_statevar_mod, only : state_variable, new_state_variable,    &
                                    read_state_variable, set_position,     &
                                    set_2d_flag, dump_state_variable,      &
                                    set_var_stagger,                       &
                                    get_mean_flag, define_mean_var,        &
                                    get_sigma_record, set_sigma_record,    &
                                    get_mass_level_flag,                   &
                                    operator(==)

    use coamps_domain_mod,   only : coamps_domain, get_domain_num_levels, &
                                    get_nest_count

    use coamps_nest_mod,     only : coamps_nest, get_nest_id

    use coamps_util_mod,     only : check_alloc_status,  &
                                    check_io_status

    use types_mod,           only :  r8

    use obs_kind_mod

    use utilities_mod,       only : do_output,     &
                                    E_WARN,        &
                                    E_ERR,         &
                                    error_handler, &
                                    get_unit

    implicit none

    private

    !------------------------------
    ! BEGIN PUBLIC INTERFACE
    !------------------------------

    public :: state_vector
    public :: initialize_state_vector

    public :: get_file_type

    ! Iterator structure and methods
    public :: state_iterator
    public :: get_iterator
    public :: has_next
    public :: get_next

    ! Diagnostics
    public :: dump_state_vector

    ! Search functions
    public :: find_state_variable

    public :: get_num_fields
    public :: get_total_size
    public :: get_domain
    public :: get_var_by_index

    !------------------------------
    ! END PUBLIC INTERFACE
    !------------------------------

    !------------------------------
    ! BEGIN EXTERNAL INTERFACE
    !------------------------------
    ! [none]
    !------------------------------
    ! END EXTERNAL INTERFACE
    !------------------------------

    !------------------------------
    ! BEGIN TYPES AND CONSTANTS
    !------------------------------

    ! Derived data type that contains the information used to read and
    ! store the field information for the state vector
    type :: state_vector
        private

        logical                                     :: FLAT_FILE_IO
        integer                                     :: num_fields
        integer                                     :: cur_fld_cnt

        type(coamps_domain),                pointer :: domain
        type(state_variable), dimension(:), pointer :: vars
        integer                                     :: total_size

    end type state_vector

    ! Iterate through the restart vector variables
    type :: state_iterator
        private

        type(state_vector), pointer :: state
        integer                     :: cur_index
    end type state_iterator

    ! Flat and restart files i/o constants
    integer,                      parameter :: FILE_TYPE_LEN       = 12
    character(len=FILE_TYPE_LEN), parameter :: FLAT_FILE_STRING    = 'FLAT_FILE'
    character(len=FILE_TYPE_LEN), parameter :: RESTART_FILE_STRING = 'RESTART_FILE'
    logical,                      parameter :: FLAG_FLAT           = .true.
    logical,                      parameter :: FLAG_RESTART        = .false.

    !------------------------------
    ! END TYPES AND CONSTANTS
    !------------------------------

    !------------------------------
    ! BEGIN MODULE VARIABLES
    !------------------------------

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

    !------------------------------
    ! END MODULE VARIABLES
    !------------------------------

contains

    !------------------------------
    ! BEGIN PUBLIC ROUTINES
    !------------------------------

    ! initialize_state_vector
    ! -----------------------
    ! Populate a COAMPS state vector structure by reading in the grid
    ! data and reading the state vector definition file
    ! INOUT state           COAMPS state vector
    ! INOUT state_list      COAMPS state vector
    !   IN  filename        name of state vector definition file
    !   IN  domain          domain for this run
    subroutine initialize_state_vector(state, filename, domain, list_only)
        type(state_vector),          intent(inout) :: state
        character(len=*),            intent(in)    :: filename
        type(coamps_domain), target, intent(in)    :: domain
        logical, optional,           intent(in)    :: list_only

        nullify(state%domain)
        nullify(state%vars)

        state%domain => domain
        state%cur_fld_cnt = 0

        if(present(list_only)) then
          call read_state_vector(state, filename, list_only)
        else
          call read_state_vector(state, filename)
        end if
        call calculate_state_positions(state)

    end subroutine initialize_state_vector

    ! get_file_type
    ! ------------
    ! Returns logical specifying restart or flat files
    !  PARAMETERS
    !  OUT file_type  Flat files or restart files?
    function get_file_type(state) result(file_type)
      type(state_vector), intent(in) :: state
      logical                        :: file_type
      file_type = state%FLAT_FILE_IO
    end function get_file_type

    ! dump_state_vector
    ! -----------------
    ! Write out all the components of the state vector
    !  PARAMETERS
    !   IN  state           State vector to dump
    subroutine dump_state_vector(state)
        type(state_vector), intent(in) :: state

        type(state_iterator) :: iterator

        if (do_output()) then
            write (*,*) "*** State Vector Contents ***"
            write (*,*) "-----------------------------"

            iterator = get_iterator(state)
            do while (has_next(iterator))
                call dump_state_variable(get_next(iterator))
            end do
        end if
    end subroutine dump_state_vector

    ! find_state_variable
    ! -------------------
    ! Search through the state vector for a variable matching the attributes
    ! supplied.  Return the first state variable found to match or a null
    ! pointer if no match was found.
    !  PARAMETERS
    !   IN  state           COAMPS state vector to search
    !   IN  nest            COAMPS nest the variable is defined on
    !   IN  var_kind        integer form of variable type
    !   IN  is_mean         true if variable is a mean field
    !   IN  level_type      level of variable to find
    !   IN  sigma_index     sigma level index for variable
    function find_state_variable(state, nest, var_kind, is_mean, &
                                 level_type, sigma_index, vert_value)
        type(state_vector),            intent(in)  :: state
        type(coamps_nest),             intent(in)  :: nest
        integer,                       intent(in)  :: var_kind
        logical,                       intent(in)  :: is_mean
        character(len=*),              intent(in)  :: level_type
        integer,                       intent(in)  :: sigma_index
        real(kind=r8), optional,       intent(in)  :: vert_value
        type(state_variable), pointer              :: find_state_variable

        type(state_iterator)         :: iterator
        type(state_variable), target :: test_var
        type(state_variable)         :: compare_var

        character(len=128) :: message
        character(len=*), parameter :: routine = 'find_state_variable'

        if(present(vert_value)) then
          compare_var = new_state_variable(get_nest_id(nest), var_kind, &
                                           is_mean, level_type,         &
                                           sigma_index,                 &
                                           vert_value = vert_value)
        else
          compare_var = new_state_variable(get_nest_id(nest), var_kind, &
                                           is_mean, level_type,         &
                                           sigma_index)
        end if

        ! Default assumption is no match found
        nullify(find_state_variable)

        iterator = get_iterator(state)
        do while (has_next(iterator))
            test_var = get_next(iterator)

            ! Return the first match found
            if (compare_var == test_var) then
                find_state_variable => test_var
                return
            end if
        end do

        ! If we got here, the search failed
        write (message,'(3A,A1,A,I3,L1)') "Could not find  ",    &
                          trim(get_name_for_quantity(var_kind)), &
                          " on ", level_type,"-level.", sigma_index, is_mean
    end function find_state_variable

    ! get_num_fields
    ! ------------
    ! Returns how many fields there are in the state vector
    !  PARAMETERS
    !   OUT num_vars          number of fields in state vector
    function get_num_fields(state) result(num_fields)
      type(state_vector), intent(in) :: state
      integer                        :: num_fields
      num_fields = state%num_fields
    end function get_num_fields

    ! get_iterator
    ! ------------
    ! Return an iterator for the state vector that can be used to access
    ! each element in turn
    !  PARAMETERS
    !   IN  state           State vector to iterate over
    function get_iterator(state)
        type(state_vector), target, intent(in)  :: state
        type(state_iterator)                    :: get_iterator

        get_iterator%state     => state
        get_iterator%cur_index =  1
    end function get_iterator

    ! has_next
    ! --------
    ! Return true if the given iterator has another value to give
    !  PARAMETERS
    !   IN  iterator        The iterator to check
    function has_next(iterator)
        type(state_iterator), intent(in)  :: iterator
        logical                           :: has_next

        has_next = (iterator%cur_index <= size(iterator%state%vars))
    end function has_next

    ! get_next
    ! --------
    ! Returns the current state variable based on the given iterator
    ! **AND** advance to the next position
    !  PARAMETERS
    !   IN  iterator        The iterator to grab a value from
    function get_next(iterator)
        type(state_iterator),          intent(inout) :: iterator
        type(state_variable), pointer                :: get_next

        ! Return the current value and advance to the next
        get_next           => iterator%state%vars(iterator%cur_index)
        iterator%cur_index = iterator%cur_index + 1

    end function get_next

    ! get_total_size
    ! --------------
    ! Get the total length of the state vector based on the variable
    ! definition and the domain.
    !  PARAMETERS
    !   IN  state           State vector to query
    function get_total_size(state)
        type(state_vector), intent(in)  :: state
        integer                         :: get_total_size

        get_total_size = state%total_size
    end function get_total_size

    ! get_domain
    ! ----------
    ! Returns the domain for a given state vector definition
    !  PARAMETERS
    !   IN  state           State vector definition to query
    function get_domain(state)
        type(state_vector),  intent(in)  :: state
        type(coamps_domain)              :: get_domain

        get_domain = state%domain
    end function get_domain

    ! get_var_by_index
    ! ----------
    ! Returns the var for a given index in the state vector
    !  PARAMETERS
    !   IN  state           State vector definition to query
    function get_var_by_index(state, index_in)
        type(state_vector),   intent(in) :: state
        integer,              intent(in) :: index_in
        type(state_variable), pointer    :: get_var_by_index

        get_var_by_index => state%vars(index_in)
    end function get_var_by_index

    !------------------------------
    ! END PUBLIC ROUTINES
    !------------------------------

    !------------------------------
    ! BEGIN PRIVATE ROUTINES
    !------------------------------

    ! add_to_list
    ! -------------------
    ! Adds the state_variable to the list
    !  PARAMETERS
    !   IN  var       Integer to add to the list
    ! INOUT list      List to add the entry to
    subroutine add_to_list(var, list)
      type(state_variable),  intent(in)    :: var
      type(state_vector),    intent(inout) :: list
      integer                              :: cur_index

      list%cur_fld_cnt = list%cur_fld_cnt + 1
      list%vars(list%cur_fld_cnt) = var

    end subroutine add_to_list

    ! read_state_vector
    ! -----------------
    ! Reads in the state vector definition file - the first line
    ! is the number of variables to follow, then each line after that
    ! contains information on each entry within the state vector
    !  PARAMETERS
    ! INOUT state                   The state vector to populate
    !   IN  state_definition_file   The definition file name to read from
    subroutine read_state_vector(state, state_definition_file, list_only)
        type(state_vector), intent(inout) :: state
        character(len=*),   intent(in)    :: state_definition_file
        logical, optional,  intent(in)    :: list_only

        integer :: state_definition_unit

        type(state_iterator) :: vars_iterator
        type(state_variable) :: cur_var

        character(len=*), parameter     :: routine = 'read_state_vector'
        integer                         :: io_status
        integer                         :: alloc_status

        integer                         :: num_lvls
        integer                         :: num_flds
        integer                         :: num_nests
        integer                         :: num_recs

        integer                         :: cur_lvl
        integer                         :: cur_fld
        integer                         :: cur_nest

        character(len=FILE_TYPE_LEN)    :: file_type
        logical                         :: list_only_local

        ! variables to deal with special case mean fields
        integer, parameter                                       :: NUM_DEFAULT_VARS = 3
        integer, parameter                                       :: VAR_NAME_LEN     = 4
        character(len=VAR_NAME_LEN), dimension(NUM_DEFAULT_VARS), parameter :: &
                  default_vars = (/'THBM','EXBM','EXBW'/)

        num_nests = get_nest_count(state%domain)

        if(present(list_only)) then
          list_only_local = list_only
        else
          list_only_local = .false.
        end if

        state_definition_unit = get_unit()
        open(unit=state_definition_unit, file=state_definition_file, &
             status='old', access='sequential', action='read',       &
             form='formatted', iostat=io_status)
        call check_io_status(io_status, routine, source, revision, revdate, &
                             'Opening file ' // state_definition_file)

        read(unit=state_definition_unit,fmt='(A)',iostat=io_status) file_type
        call check_io_status(io_status, routine, source, revision, revdate, &
                             'Read file type in state.vars')
        state%FLAT_FILE_IO = file_type_to_flag(file_type)

        ! Count the number of itemes in the state vector file
        num_recs = 0
        count_recs: do
          if(read_state_variable(state_definition_unit, cur_var,  &
                                 0, state%FLAT_FILE_IO)) exit count_recs

          if(state%FLAT_FILE_IO .AND. .not.list_only_local) then
            num_recs = num_recs + get_sigma_record(cur_var)
          else
            num_recs = num_recs + 1
          end if
        end do count_recs

        ! Account for 3 mean-state variable if this is flatfile i/o
        if(state%FLAT_FILE_IO)  then
          if(list_only_local) then
            num_recs = num_nests * (num_recs + 3)
          else
            num_recs = num_nests * (num_recs                         &
                     + 3 * get_domain_num_levels(state%domain) + 1)
          end if
        end if

        ! Rewind to the begining of the file
        rewind(state_definition_unit)
        read(unit=state_definition_unit,fmt='(A)',iostat=io_status) file_type

        allocate(state%vars(num_recs), stat=alloc_status)
        call check_alloc_status(alloc_status, routine, source, revision,    &
                                revdate, 'state%vars')

        state%num_fields = 0
        nest_input: do cur_nest = 1, num_nests
          read_list: do

            if(read_state_variable(state_definition_unit, cur_var,  &
                                   cur_nest, state%FLAT_FILE_IO)) exit read_list

            if(get_mean_flag(cur_var)) cycle read_list

            state%num_fields = state%num_fields + 1

            if(list_only_local) then
              if(get_sigma_record(cur_var) > 1) call set_2d_flag(cur_var, .false.)
              call set_var_stagger(cur_var)
              call add_to_list(cur_var, state)
              cycle read_list
            end if

            if(state%FLAT_FILE_IO) then
              num_lvls = get_sigma_record(cur_var)
              levels: do cur_lvl=1, num_lvls
                call set_sigma_record(cur_var, cur_lvl)
                call add_to_list(cur_var, state)
              end do levels
            else
              call add_to_list(cur_var, state)
            end  if

          end do read_list

          ! Add mean fields to the list.  Only for flat_file i/o, otherwise
          ! variables are defined in state_vector text file.
          if(state%FLAT_FILE_IO) then
            fld_loop: do cur_fld = 1, NUM_DEFAULT_VARS

              cur_var = define_mean_var(default_vars(cur_fld), cur_nest)
              num_lvls = get_domain_num_levels(state%domain)
              if(.not.get_mass_level_flag(cur_var)) num_lvls = num_lvls + 1

              if(list_only_local) then
                call set_sigma_record(cur_var, num_lvls)
                call set_2d_flag(cur_var, .false.)
                call set_var_stagger(cur_var)
                call add_to_list(cur_var, state)
              else
                lvl_loop: do cur_lvl = 1, num_lvls
                  call set_sigma_record(cur_var, cur_lvl)
                  call add_to_list(cur_var, state)
                end do lvl_loop
              end if

            end do fld_loop
          end if

          ! Rewind the file for the next nest
          rewind(state_definition_unit)
          read(unit=state_definition_unit,fmt='(A)',iostat=io_status) file_type
        end do nest_input

        close(state_definition_unit)

    end subroutine read_state_vector

    ! calculate_state_positions
    ! -------------------------
    ! Iterate through the state vector definition and calculate the piece of
    ! the large state vector corresponding to each state variable.
    !  PARAMETERS
    !   IN  state         state vector definition to iterate over
    subroutine calculate_state_positions(state)
        type(state_vector), intent(inout) :: state

        type(state_iterator)          :: iterator
        type(state_variable), pointer :: cur_var
        integer                       :: cur_state_pos

        cur_state_pos = 0
        iterator = get_iterator(state)
        do while (has_next(iterator))
          cur_var => get_next(iterator)
          cur_state_pos = set_position(cur_var, cur_state_pos, state%domain)
        end do

        state%total_size = cur_state_pos
    end subroutine calculate_state_positions

    ! file_type_to_flag
    ! ---------------
    ! Converts a character string describing whether the entire field
    ! is read from a flat file (FLAT) or a restart file (RESTART) to
    ! the interna llogical representation
    !  PARAMETERS
    !   IN  file_type_string     FLAT or RESTART
    !   OUT flat_flag       consistent with module-defined flag
    function file_type_to_flag(file_type_string) result(file_type_flag)
      character(len=FILE_TYPE_LEN), intent(in) :: file_type_string
      logical                                  :: file_type_flag
      select case (adjustl(file_type_string))
      case (adjustl(FLAT_FILE_STRING))
         file_type_flag = FLAG_FLAT
      case (adjustl(RESTART_FILE_STRING))
         file_type_flag = FLAG_RESTART
      case default
         call error_handler(E_ERR, 'file_type_to_flag', &
                            'FILE_TYPE ' // file_type_string // &
                            ' not found!', source, revision, revdate)
      end select
    end function file_type_to_flag

    !------------------------------
    ! END PRIVATE ROUTINES
    !------------------------------
end module coamps_statevec_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text:
*----------------------------------------------------------------------*
      subroutine init_cnt_info(cnt_info,
     &     iocc_op1,iocc_ex1,nj_op1,iocc_op2,iocc_ex2,nj_op2,
     &     iocc_cnt,nj_cnt,
     &     iocc_op1op2,nj_op1op2,iocc_op1op2tmp,nj_op1op2tmp)
*----------------------------------------------------------------------*
*     initialize dimensions and arrays
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'def_contraction_info.h'

      type(contraction_info), intent(inout) ::
     &     cnt_info

      integer, intent(in) ::
     &     nj_op1,nj_op2,nj_cnt,
     &     nj_op1op2,nj_op1op2tmp
      integer, intent(in) ::
     &     iocc_op1(ngastp,2,nj_op1),iocc_ex1(ngastp,2,nj_op1),
     &     iocc_op2(ngastp,2,nj_op2),iocc_ex2(ngastp,2,nj_op2),
     &     iocc_cnt(ngastp,2,nj_cnt),
     &     iocc_op1op2(ngastp,2,nj_op1op2),
     &     iocc_op1op2tmp(ngastp,2,nj_op1op2tmp)

      call get_num_subblk(cnt_info%ncblk_op1,cnt_info%nablk_op1,
     &                    iocc_op1,nj_op1)
      call get_num_subblk(cnt_info%ncblk_ex1,cnt_info%nablk_ex1,
     &                    iocc_ex1,nj_op1)
      call get_num_subblk(cnt_info%ncblk_op2,cnt_info%nablk_op2,
     &                    iocc_op2,nj_op2)
      call get_num_subblk(cnt_info%ncblk_ex2,cnt_info%nablk_ex2,
     &                    iocc_ex2,nj_op2)
      call get_num_subblk(cnt_info%ncblk_op1op2,cnt_info%nablk_op1op2,
     &                    iocc_op1op2,nj_op1op2)
      call get_num_subblk(cnt_info%ncblk_op1op2tmp,
     &                    cnt_info%nablk_op1op2tmp,
     &                    iocc_op1op2tmp,nj_op1op2tmp)
      call get_num_subblk(cnt_info%ncblk_cnt,cnt_info%nablk_cnt,
     &                    iocc_cnt,nj_cnt)

      allocate(
     &     cnt_info%cinfo_op1c(cnt_info%ncblk_op1,3),
     &     cnt_info%cinfo_op1a(cnt_info%nablk_op1,3),
     &     cnt_info%cinfo_ex1c(cnt_info%ncblk_ex1,3),
     &     cnt_info%cinfo_ex1a(cnt_info%nablk_ex1,3),
     &     cnt_info%cinfo_op2c(cnt_info%ncblk_op2,3),
     &     cnt_info%cinfo_op2a(cnt_info%nablk_op2,3),
     &     cnt_info%cinfo_ex2c(cnt_info%ncblk_ex2,3),
     &     cnt_info%cinfo_ex2a(cnt_info%nablk_ex2,3),
     &     cnt_info%cinfo_cntc(cnt_info%ncblk_cnt,3),
     &     cnt_info%cinfo_cnta(cnt_info%nablk_cnt,3),
     &     cnt_info%cinfo_op1op2c(cnt_info%ncblk_op1op2,3),
     &     cnt_info%cinfo_op1op2a(cnt_info%nablk_op1op2,3),
     &     cnt_info%cinfo_op1op2tmpc(cnt_info%ncblk_op1op2tmp,3),
     &     cnt_info%cinfo_op1op2tmpa(cnt_info%nablk_op1op2tmp,3)
     &     )
      allocate(
     &     cnt_info%map_info_1c(
     &                     max(1,cnt_info%ncblk_op1*2*(nj_op1+nj_cnt))),
     &     cnt_info%map_info_1a(
     &                     max(1,cnt_info%nablk_op1*2*(nj_op1+nj_cnt))),
     &     cnt_info%map_info_2c(
     &                     max(1,cnt_info%ncblk_op2*2*(nj_op2+nj_cnt))),
     &     cnt_info%map_info_2a(
     &                     max(1,cnt_info%nablk_op2*2*(nj_op2+nj_cnt))),
     &     cnt_info%map_info_12c(
     &               max(1,max(cnt_info%ncblk_op1op2tmp,
     &                         cnt_info%ncblk_op1op2)
     &                                             *2*(nj_op1+nj_op2))),
     &     cnt_info%map_info_12a(
     &               max(1,max(cnt_info%nablk_op1op2tmp,
     &                         cnt_info%nablk_op1op2)
     &                                             *2*(nj_op1+nj_op2)))
     &     )

      cnt_info%diag_type1 = 0
      cnt_info%diag_type2 = 0
      cnt_info%diag_type12 = 0

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public


text:
!! Copyright (C) 2008 Pavel Sakov
!!
!! This file is part of EnKF-Matlab. EnKF-Matlab is a free software. See
!! LICENSE for details.

! File:           qgflux.f90
!
! Created:        31/08/2007
!
! Last modified:  08/02/2008
!
! Author:         Pavel Sakov
!                 CSIRO Marine and Atmospheric Research
!                 NERSC
!
! Purpose:        Fortran code for QG model. Time derivative.
!
! Description:
!
! Revisions:

module qgflux_mod

  use utils_mod
  use parameters_mod
  use calc_mod, only: arakawa, laplacian
  use helmholtz_mod, only: helmholtz

  implicit none

  public qg_flux

contains

  subroutine calc_psi(PSIGUESS, Q, PSI)
    real(8), dimension(:, :), intent(in) :: PSIGUESS, Q
    real(8), dimension(:, :), intent(out) :: PSI

    call helmholtz(PSIGUESS, Q, F, NX1, NY1, MREFIN, 1.0d0 / NX1, 1, 2, 3, N, M, PSI)
  end subroutine calc_psi

  subroutine qg_flux(t, Q, PSIGUESS, PSI, QFLUX)
    real(8), intent(in) :: t
    real(8), dimension(:, :), intent(in) :: Q, PSIGUESS
    real(8), dimension(:, :), intent(out) :: PSI, QFLUX

    real(8), dimension(N, M) :: JACOBIAN
    real(8), dimension(N, M) :: ZETA, ZETA2, ZETA4

    call calc_psi(PSIGUESS, Q, PSI)
    call arakawa(PSI, Q, dx, dy, JACOBIAN)
    call laplacian(PSI, dx, dy, ZETA)
    call laplacian(ZETA, dx, dy, ZETA2)
    call laplacian(ZETA2, dx, dy, ZETA4)

    QFLUX = - r * JACOBIAN - rkb * ZETA + rkh * ZETA2 - rkh2 * ZETA4 + CURLT
    QFLUX(2 : N - 1, 2 : M - 1) = QFLUX(2 : N - 1, 2 : M - 1)&
         - (0.5d0 / dx) * (PSI(3 : N, 2 : M - 1) - PSI(1 : N - 2, 2 : M - 1))
    QFLUX(1, :) = 0.0d0
    QFLUX(N, :) = 0.0d0
    QFLUX(:, 1) = 0.0d0
    QFLUX(:, M) = 0.0d0
  end subroutine qg_flux

  subroutine qg_flux_tl(t, Q0, PSI0, Q, PSIGUESS, PSI, QFLUX)
    real(8), intent(in) :: t
    real(8), dimension(:, :), intent(in) :: Q, PSIGUESS
    real(8), dimension(:, :), intent(in) :: Q0, PSI0
    real(8), dimension(:, :), intent(out) :: PSI, QFLUX

    real(8), dimension(N, M) :: J1, J2
    real(8), dimension(N, M) :: ZETA, ZETA2, ZETA4

    call calc_psi(PSIGUESS, Q, PSI)
    call arakawa(PSI0, Q, dx, dy, J1)
    call arakawa(PSI, Q0, dx, dy, J2);
    call laplacian(PSI, dx, dy, ZETA)
    call laplacian(ZETA, dx, dy, ZETA2)
    call laplacian(ZETA2, dx, dy, ZETA4)

    QFLUX = - r * J1 - r * J2 - rkb * ZETA + rkh * ZETA2 - rkh2 * ZETA4
    QFLUX(2 : N - 1, 2 : M - 1) = QFLUX(2 : N - 1, 2 : M - 1)&
         - (0.5d0 / dx) * (PSI(3 : N, 2 : M - 1) - PSI(1 : N - 2, 2 : M - 1))
    QFLUX(1, :) = 0.0d0
    QFLUX(N, :) = 0.0d0
    QFLUX(:, 1) = 0.0d0
    QFLUX(:, M) = 0.0d0
  end subroutine qg_flux_tl

end module qgflux_mod

max_issues_repo_name: cecidip/DAPPER

max_forks_repo_name: cecidip/DAPPER


text:
!##############################################################################
!# ****************************************************************************
!# <name> stokesdbg2d </name>
!# ****************************************************************************
!#
!# <purpose>
!# </purpose>
!##############################################################################

module stokesdbg2d

use fsystem
use storage
use genoutput
use collection, only: t_collection

use stokesdbg_core
use stokesdbg_driver2d

use stokesdbg_edge_div

implicit none

private

public :: stokesdbg_run2d

contains

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

!<subroutine>

  subroutine stokesdbg_run2d(rparam, idriver)
  type(t_parlist), intent(inout) :: rparam
  integer, intent(in) :: idriver

!</subroutine>

  type(t_problem) :: rproblem
  type(t_system) :: rsystem
  type(t_collection) :: rcollect
  type(t_linearForm) :: rform
  real(DP), dimension(2), target :: DerrorUL2, DerrorUH1
  real(DP), dimension(1), target :: DerrorPL2
  type(t_errorScVec) :: rerrorU, rerrorP
  integer :: ilvl, imesh, iinfo

    ! allocate levels
    call stdbg_initProblem(rproblem, rparam)

    ! store driver id
    rproblem%idriver = idriver

    ! store problem parameters
    rcollect%DquickAccess(1) = rproblem%dnu
    rcollect%DquickAccess(2) = rproblem%dalpha
    rcollect%DquickAccess(3) = rproblem%dbeta
    rcollect%DquickAccess(4) = rproblem%dgamma
    rcollect%IquickAccess(1) = idriver
    rcollect%IquickAccess(2) = 0
    rcollect%IquickAccess(3) = rproblem%ilevelMin
    rcollect%IquickAccess(4) = rproblem%ilevelMax

    ! fetch additional info
    call parlst_getvalue_int(rparam, '', 'VORTEX_VELO', rcollect%IquickAccess(6), 0)
    call parlst_getvalue_int(rparam, '', 'VORTEX_PRES', rcollect%IquickAccess(7), 0)

    ! read in triangulations
    call parlst_getvalue_int(rparam, '', 'MESH', imesh, 0)
    select case(imesh)
    case (0)
      call stdbg_initTriangulation2D(rproblem, 'QUAD')
    case (1)
      call stdbg_initTriangulation2D(rproblem, 'QUADX4R')
    case (2)
      call stdbg_initTriangulation2D(rproblem, 'QUADIRR2')
    case (100)
      call stdbg_initTriangulation2D(rproblem, 'TRIA')
    case (102)
      call stdbg_initTriangulation2D(rproblem, 'TRIAX12')
    end select

    ! initialise discretisations
    call stdbg_initDiscretisation(rproblem)

    ! initialise multilevel projections
    call stdbg_initProjections(rproblem)

    ! initialise matrices
    call stdbg_initMatrices(rproblem)

    ! initialise BCs
    call stdrv_initBoundaryConditions(rproblem)

    ! loop over all levels
    call output_lbrk()
    do ilvl = rproblem%ilevelMin, rproblem%ilevelMax

      call output_line("Processing Level " // trim(sys_sil(ilvl, 4)) // "...")

      ! store current level in collection
      rcollect%IquickAccess(2) = ilvl

      ! initialise system
      call stdbg_initSystem(rsystem, rproblem, ilvl)

      ! Assemble the RHS vectors
      rcollect%IquickAccess(5) = 1
      call linf_buildSimpleVector(rsystem%rvecRhsVelo%RvectorBlock(1), &
          rproblem%Rlevels(ilvl)%rcubInfo, stdrv_funcRhsVelo, .true., DER_FUNC, rcollect)
      call linf_buildSimpleVector(rsystem%rvecRhsPres%RvectorBlock(1), &
          rproblem%Rlevels(ilvl)%rcubInfo, stdrv_funcRhsPres, .true., DER_FUNC, rcollect)
      rcollect%IquickAccess(5) = 2
      call linf_buildSimpleVector(rsystem%rvecRhsVelo%RvectorBlock(2), &
          rproblem%Rlevels(ilvl)%rcubInfo, stdrv_funcRhsVelo, .true., DER_FUNC, rcollect)
      call linf_buildSimpleVector(rsystem%rvecRhsPres%RvectorBlock(2), &
          rproblem%Rlevels(ilvl)%rcubInfo, stdrv_funcRhsPres, .true., DER_FUNC, rcollect)

      ! combine rhs vectors
      call lsysbl_vectorLinearComb(rsystem%rvecRhsVelo, rsystem%rvecRhsPres, &
          1.0_DP, 1.0_DP, rsystem%rvecRhs)

      ! Filter solution and rhs vectors
      call vecfil_discreteBCsol(rsystem%rvecSol)
      call vecfil_discreteBCrhs(rsystem%rvecRhs)
      call vecfil_discreteBCrhs(rsystem%rvecRhsVelo)
      call vecfil_discreteBCdef(rsystem%rvecRhsPres) !???

      ! initialise filter chain
      call stdrv_initFilterChain(rsystem)

      ! initialise multigrid solver
      call stdbg_initMultigrid(rsystem)

      ! solve system
      call stdbg_solve(rsystem)

      ! post-process solution
      call stdrv_postProcSol(rsystem)

      !*** write divergence ***
      !call stokesdbg_writeEdgeDiv(rsystem%rvecSol%RvectorBlock(1:2), "edge-div", CUB_G5_1D)

      ! compute errors
      ! Set up the error structure for velocity
      rerrorU%p_RvecCoeff => rsystem%rvecSol%RvectorBlock(1:2)
      rerrorU%p_DerrorL2 => DerrorUL2
      rerrorU%p_DerrorH1 => DerrorUH1

      ! Set up the error structure for pressure
      rerrorP%p_RvecCoeff => rsystem%rvecSol%RvectorBlock(3:3)
      rerrorP%p_DerrorL2 => DerrorPL2

      ! Calculate errors of velocity and pressure against analytic solutions.
      call pperr_scalarVec(rerrorU, stdrv_funcVelocity2D, rcollect);
      call pperr_scalarVec(rerrorP, stdrv_funcPressure2D, rcollect);

      ! Calculate errors of velocity field
      rproblem%p_Dstat(DSTAT_U_L2,rsystem%ilevel) = sqrt(DerrorUL2(1)**2 + DerrorUL2(2)**2)
      rproblem%p_Dstat(DSTAT_U_H1,rsystem%ilevel) = sqrt(DerrorUH1(1)**2 + DerrorUH1(2)**2)

      ! Store error of pressure
      rproblem%p_Dstat(DSTAT_P_L2,rsystem%ilevel) = derrorPL2(1)

      ! Calculate divergence of velocity field
      call stdbg_aux_calcDiv2D(rproblem%p_Dstat(DSTAT_U_DIV,rsystem%ilevel), &
        rsystem%rvecSol%RvectorBlock(1:2), rproblem%Rlevels(ilvl)%rcubInfo)

      ! write VTK if desired
      call stdbg_writeVTK(rsystem)

      ! release system
      call stdbg_doneSystem(rsystem)

    end do ! next level

    ! print statistics
    call stdbg_printMeshStatistics2D(rproblem)
    call stdbg_printMatrixStatistics(rproblem)
    call stdbg_printSolverStatistics(rproblem)
    call stdbg_printErrorStatistics(rproblem)

    ! release problem
    call stdbg_doneProblem(rproblem)

  end subroutine

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


module complex_transform_routines

    use auxiliary_routines

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: cfft1i, cfft1b, cfft1f, cfft2i, cfft2b, cfft2f, cfftmi, cfftmb, cfftmf

    interface
        !
        !==> 1D complex initialization
        !
        module subroutine cfft1i(n, wsave, lensav, ierror)
            !
            ! cfft1i: initialization for cfft1b and cfft1f.
            !
            !  Purpose:
            !
            !  cfft1i initializes array wsave for use in its companion routines
            !  cfft1b and cfft1f. Routine cfft1i must be called before the first
            !  call to cfft1b or cfft1f, and after whenever the value of integer
            !  n changes.
            !
            !  Parameters:
            !
            !  input,
            !  n, the length of the sequence to be
            !  transformed.  the transform is most efficient when n is a product
            !  of small primes.
            !
            !  input
            !  lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !  output,
            !  wsave(lensav), containing the prime factors
            !  of n and  also containing certain trigonometric values which will be used
            !  in routines cfft1b or cfft1f.
            !
            !  output
            !  ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: n
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (in)  :: lensav
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine cfft1i
        !
        !==> 1D complex backward
        !
        module subroutine cfft1b(n, inc, c, lenc, wsave, lensav, work, lenwrk, ierror)

            use, intrinsic :: ISO_C_binding, only: c_f_pointer, c_loc
            !
            !  input
            !  integer n, the length of the sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array c, of two consecutive elements within the sequence to be transformed.
            !
            !  integer lenc, the dimension of the c array.
            !  lenc must be at least inc*(n-1) + 1.
            !
            !  real wsave(lensav). wsave's contents must be initialized with a call
            !  to cfft1i before the first call to routine cfft1f
            !  or cfft1b for a given transform length n.  wsave's contents may be
            !  re-used for subsequent calls to cfft1f and cfft1b with the same n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !
            !  input lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*n.
            !
            !  input/output
            !  complex c(lenc) containing the sequence to be
            !  transformed.
            !
            !  real workspace work(lenwrk).
            !
            !  integer ier, error_flag.
            !  0, successful exit;
            !  1, input parameter lenc not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  20, input error returned by lower level routine.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)             :: n
            integer (ip), intent (in)             :: inc
            complex (wp), intent (in out), target :: c(lenc)
            integer (ip), intent (in)             :: lenc
            integer (ip), intent (in)             :: lensav
            integer (ip), intent (in)             :: lenwrk
            integer (ip), intent (out)            :: ierror
            real (wp),    intent (in out)         :: work(lenwrk)
            real (wp),    intent (in out)         :: wsave(lensav)
            !--------------------------------------------------------------
        end subroutine cfft1b
            !
            !==> 1D complex forward
            !
        module subroutine cfft1f(n, inc, c, lenc, wsave, lensav, work, lenwrk, ierror)
            use, intrinsic :: ISO_C_binding, only: c_f_pointer, c_loc
            !
            ! cfft1f: complex forward fast fourier transform, 1d.
            !
            !  purpose:
            !
            !  cfft1f computes the one-dimensional fourier transform of a single
            !  periodic sequence within a complex array. this transform is referred
            !  to as the forward transform or fourier analysis, transforming the
            !  sequence from physical to spectral space.
            !
            !  this transform is normalized since a call to cfft1f followed
            !  by a call to cfft1b (or vice-versa) reproduces the original
            !  array within roundoff error.
            !
            !  input
            !
            !  integer n, the length of the sequence to be
            !  transformed. the transform is most efficient when
            !  n is a product of small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array c, of two consecutive elements within the sequence to be transformed.
            !
            !  real wsave(lensav).  wsave's contents must be
            !  initialized with a call to cfft1i before the first call to routine cfft1f
            !  or cfft1b for a given transform length n.  wsave's contents may be re-used
            !  for subsequent calls to cfft1f and cfft1b with the same n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*n.
            !
            !  input/output
            !  complex c(lenc) containing the sequence to be transformed.
            !
            !  real work(lenwrk), workspace array
            !  integer lenc, the dimension of the c array.
            !  lenc must be at least inc*(n-1) + 1.
            !
            !  output
            !  integer ier, error_flag.
            !  0, successful exit;
            !  1, input parameter lenc not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  20, input error returned by lower level routine.
            !
            !------------------------------------------------------------------
            ! Dummy arguments
            !------------------------------------------------------------------
            integer (ip), intent (in)             :: n
            integer (ip), intent (in)             :: inc
            complex (wp), intent (in out), target :: c(lenc)
            integer (ip), intent (in)             :: lenc
            real (wp),    intent (in)             :: wsave(lensav)
            integer (ip), intent (in)             :: lensav
            real (wp),    intent (out)            :: work(lenwrk)
            integer (ip), intent (in)             :: lenwrk
            integer (ip), intent (out)            :: ierror
            !------------------------------------------------------------------
        end subroutine cfft1f
        !
        !==> 2D complex initialization
        !
        module subroutine cfft2i(l, m, wsave, lensav, ierror)
            !
            ! cfft2i: initialization for cfft2b and cfft2f.
            !
            !  purpose:
            !
            !  cfft2i initializes real array wsave for use in its companion
            !  routines cfft2f and cfft2b for computing two-dimensional fast
            !  fourier transforms of complex data.  prime factorizations of l and m,
            !  together with tabulations of the trigonometric functions, are
            !  computed and stored in array wsave.
            !
            !  on 10 may 2010, this code was modified by changing the value
            !  of an index into the wsave array.
            !
            !  input
            !  integer l, the number of elements to be transformed
            !  in the first dimension. the transform is most efficient when l is a
            !  product of small primes.
            !
            !  integer m, the number of elements to be transformed
            !  in the second dimension. the transform is most efficient when m is a
            !  product of small primes.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least
            !
            !  2*(l+m) + int(log(real(l)))+ int(log(real(m))) + 8.
            !
            !  output
            !  real wsave(lensav), contains the prime factors of l
            !  and m, and also certain trigonometric values which will be used in
            !  routines cfft2b or cfft2f.
            !
            !  integer  ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  20, input error returned by lower level routine.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: l
            integer (ip), intent (in)  :: m
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (in)  :: lensav
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine cfft2i
        !
        !==> 2D complex backward
        !
        module subroutine cfft2b(ldim, l, m, c, wsave, lensav, work, lenwrk, ierror)
            !
            ! cfft2b: complex fast ror transform, 2d.
            !
            !  purpose:
            !
            !  cfft2b computes the two-dimensional discrete ror transform of a
            !  complex periodic array.  this transform is known as the backward
            !  transform or synthesis, transforming from spectral to
            !  physical space.  routine cfft2b is normalized, in that a call to
            !  cfft2b followed by a call to cfft2f (or vice-versa) reproduces the
            !  original array within roundoff error.
            !
            !  bug fix
            !  on 10 may 2010, this code was modified by changing the value
            !  of an index into the wsave array.
            !
            !  parameters:
            !
            !  input
            !  integer ldim, the first dimension of c.
            !
            !  integer l, the number of elements to be transformed
            !  in the first dimension of the two-dimensional complex array c.  the value
            !  of l must be less than or equal to that of ldim.  the transform is
            !  most efficient when l is a product of small primes.
            !
            !  integer m, the number of elements to be transformed in
            !  the second dimension of the two-dimensional complex array c.  the transform
            !  is most efficient when m is a product of small primes.
            !
            !  real wsave(lensav). wsave's contents must be initialized with
            !  a call to cfft2i before the first call to routine cfft2f
            !  or cfft2b with transform lengths l and m.  wsave's contents may be
            !  re-used for subsequent calls to cfft2f and cfft2b with the same
            !  transform lengths l and m.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least
            !
            !  2*(l+m) + int(log(real(l))) + int(log(real(m))) + 8.
            !
            !  real work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*l*m.
            !
            !  input/output
            !  complex c(ldim,m), on intput, the array of two dimensions
            !  containing the (l,m) subarray to be transformed.  on
            !  output, the transformed data.
            !
            !
            !  output
            !
            !  integer ierror, the error_flag.
            !
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  5, input parameter ldim < l;
            !  20, input error returned by lower level routine.
            !
            !------------------------------------------------------------------
            ! Dummy arguments
            !------------------------------------------------------------------
            integer (ip), intent (in)     :: ldim
            integer (ip), intent (in)     :: l
            integer (ip), intent (in)     :: m
            complex (wp), intent (in out) :: c(ldim,m)
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (in out) :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !------------------------------------------------------------------
        end subroutine cfft2b
        !
        !==> 2D complex forward
        !
        module subroutine cfft2f(ldim, l, m, c, wsave, lensav, work, lenwrk, ierror)
            !
            ! cfft2f: complex forward fast fourier transform, 2d.
            !
            !  Purpose:
            !
            !  cfft2f computes the two-dimensional discrete fourier transform of
            !  a complex periodic array. This transform is known as the forward
            !  transform or fourier analysis, transforming from physical to
            !  spectral space. routine cfft2f is normalized, in that a call to
            !  cfft2f followed by a call to cfft2b (or vice-versa) reproduces the
            !  original array within roundoff error.
            !
            !  BUG FIX
            !  On 10 May 2010, this code was modified by changing the value
            !  of an index into the wsave array.
            !
            !  INPUT
            !
            !  integer ldim, the first dimension of the array c.
            !
            !  integer l, the number of elements to be transformed
            !  in the first dimension of the two-dimensional complex array c.  the value
            !  of l must be less than or equal to that of ldim.  the transform is most
            !  efficient when l is a product of small primes.
            !
            !  integer m, the number of elements to be transformed
            !  in the second dimension of the two-dimensional complex array c.  the
            !  transform is most efficient when m is a product of small primes.
            !
            !  real wsave(lensav). wsave's contents must be
            !  initialized with a call to cfft2i before the first call to routine cfft2f
            !  or cfft2b with transform lengths l and m.  wsave's contents may be re-used
            !  for subsequent calls to cfft2f and cfft2b having those same
            !  transform lengths.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least
            !
            !  2*(l+m) + int(log(real(l))) + int(log(real(m))) + 8.
            !
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*l*m.
            !
            !  INPUT/OUTPUT
            !  complex c(ldim,m), on input, the array of two
            !  dimensions containing the (l,m) subarray to be transformed. On output, the
            !  transformed data.
            !
            !  real work(lenwrk), workspace array
            !
            !  OUTPUT
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  5, input parameter ldim < l;
            !  20, input error returned by lower level routine.
            !
            !------------------------------------------------------------------
            ! Dummy arguments
            !------------------------------------------------------------------
            integer (ip), intent (in)     :: ldim
            integer (ip), intent (in)     :: l
            integer (ip), intent (in)     :: m
            complex (wp), intent (in out) :: c(ldim,m)
            real (wp),    intent (in)     :: wsave(lensav)
            integer (ip), intent (in)     :: lensav
            real (wp),    intent (in out) :: work(lenwrk)
            integer (ip), intent (in)     :: lenwrk
            integer (ip), intent (out)    :: ierror
            !------------------------------------------------------------------
        end subroutine cfft2f
        !
        !==> multiple complex initialization
        !
        module subroutine cfftmi(n, wsave, lensav, ierror)
            !
            !  cfftmi: initialization for cfftmb and cfftmf.
            !
            !  purpose:
            !
            !  cfftmi initializes array wsave for use in its companion routines
            !  cfftmb and cfftmf.  cfftmi must be called before the first call
            !  to cfftmb or cfftmf, and after whenever the value of integer n changes.
            !
            !  parameters:
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !  real wsave(lensav), containing the prime factors
            !  of n and also containing certain trigonometric values which will be used in
            !  routines cfftmb or cfftmf.
            !
            !  integer ierror, error_flag.
            !  0, successful exit;
            !  2, input parameter lensav not big enough.
            !
            !--------------------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------------------
            integer (ip), intent (in)  :: n
            real (wp),    intent (out) :: wsave(lensav)
            integer (ip), intent (in)  :: lensav
            integer (ip), intent (out) :: ierror
            !--------------------------------------------------------------
        end subroutine cfftmi
        !
        !==> multiple complex backward
        !
        module subroutine cfftmb(lot, jump, n, inc, c, lenc, wsave, lensav, work, lenwrk, ierror)
            !
            ! cfftmb: complex backward fft, 1d, multiple vectors.
            !
            !  purpose:
            !
            !  cfftmb computes the one-dimensional fourier transform of multiple
            !  periodic sequences within a complex array.  this transform is referred
            !  to as the backward transform or fourier synthesis, transforming the
            !  sequences from spectral to physical space.  this transform is
            !  normalized since a call to cfftmf followed by a call to cfftmb (or
            !  vice-versa) reproduces the original array within roundoff error.
            !
            !  the parameters inc, jump, n and lot are consistent if equality
            !  i1*inc + j1*jump = i2*inc + j2*jump for i1,i2 < n and j1,j2 < lot
            !  implies i1=i2 and j1=j2.  for multiple ffts to execute correctly,
            !  input variables inc, jump, n and lot must be consistent, otherwise
            !  at least one array element mistakenly is transformed more than once.
            !
            !  parameters:
            !
            !  integer lot, the number of sequences to be transformed
            !  within array c.
            !
            !  integer jump, the increment between the locations, in
            !  array c, of the first elements of two consecutive sequences to be
            !  transformed.
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array c, of two consecutive elements within the same sequence to be
            !  transformed.
            !
            !  input/output, complex (wp) c(lenc), an array containing lot
            !  sequences, each having length n, to be transformed.  c can have any
            !  number of dimensions, but the total number of locations must be at least
            !  lenc.  on output, c contains the transformed sequences.
            !
            !  integer lenc, the dimension of the c array.
            !  lenc must be at least (lot-1)*jump + inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to cfftmi before the first call to routine cfftmf
            !  or cfftmb for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*lot*n.
            !
            !  integer ierror, error_flag.
            !  0, successful exit
            !  1, input parameter lenc not big enough;
            !  2, input parameter lensav not big enough;
            !  3, input parameter lenwrk not big enough;
            !  4, input parameters inc, jump, n, lot are not consistent.
            !
            !--------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------
            integer (ip) lot
            integer (ip) jump
            integer (ip) n
            integer (ip) inc
            real (wp) c(2,lenc)
            integer (ip) lenc
            real (wp) wsave(lensav)
            integer (ip) lensav
            real (wp) work(lenwrk)
            integer (ip) lenwrk
            integer (ip) ierror
            !--------------------------------------------------
        end subroutine cfftmb
        !
        !==> multiple complex forward
        !
        module subroutine cfftmf(lot, jump, n, inc, c, lenc, wsave, lensav, work, lenwrk, ierror)
            !
            ! cfftmf: complex forward fft, 1d, multiple vectors.
            !
            !  Purpose:
            !
            !  cfftmf computes the one-dimensional fourier transform of multiple
            !  periodic sequences within a complex array. this transform is referred
            !  to as the forward transform or fourier analysis, transforming the
            !  sequences from physical to spectral space. this transform is
            !  normalized since a call to cfftmf followed by a call to cfftmb
            !  (or vice-versa) reproduces the original array within roundoff error.
            !
            !  the parameters integers inc, jump, n and lot are consistent if equality
            !  i1*inc + j1*jump = i2*inc + j2*jump for i1,i2 < n and j1,j2 < lot
            !  implies i1=i2 and j1=j2. for multiple ffts to execute correctly,
            !  input variables inc, jump, n and lot must be consistent, otherwise
            !  at least one array element mistakenly is transformed more than once.
            !
            !  parameters:
            !
            !  integer lot, the number of sequences to be
            !  transformed within array c.
            !
            !  integer jump, the increment between the locations,
            !  in array c, of the first elements of two consecutive sequences to be
            !  transformed.
            !
            !  integer n, the length of each sequence to be
            !  transformed.  the transform is most efficient when n is a product of
            !  small primes.
            !
            !  integer inc, the increment between the locations, in
            !  array c, of two consecutive elements within the same sequence to be
            !  transformed.
            !
            !  input/output, complex (wp) c(lenc), array containing lot sequences,
            !  each having length n, to be transformed.  c can have any number of
            !  dimensions, but the total number of locations must be at least lenc.
            !
            !  integer lenc, the dimension of the c array.
            !  lenc must be at least (lot-1)*jump + inc*(n-1) + 1.
            !
            !  input, real (wp) wsave(lensav).  wsave's contents must be
            !  initialized with a call to cfftmi before the first call to routine cfftmf
            !  or cfftmb for a given transform length n.
            !
            !  integer lensav, the dimension of the wsave array.
            !  lensav must be at least 2*n + int(log(real(n))) + 4.
            !
            !  workspace, real (wp) work(lenwrk).
            !
            !  integer lenwrk, the dimension of the work array.
            !  lenwrk must be at least 2*lot*n.
            !
            !  integer ierror, error_flag.
            !  0 successful exit;
            !  1 input parameter lenc not big enough;
            !  2 input parameter lensav not big enough;
            !  3 input parameter lenwrk not big enough;
            !  4 input parameters inc, jump, n, lot are not consistent.
            !
            !--------------------------------------------------
            ! Dummy arguments
            !--------------------------------------------------
            integer (ip) lot
            integer (ip) jump
            integer (ip) n
            integer (ip) inc
            real(wp) c(2,lenc)
            integer (ip) lenc
            real (wp) wsave(lensav)
            integer (ip) lensav
            real (wp) work(lenwrk)
            integer (ip) lenwrk
            integer (ip) ierror
            !--------------------------------------------------
        end subroutine cfftmf
    end interface

    !---------------------------------------------------------------------------------
    ! Variables confined to the module
    !---------------------------------------------------------------------------------
    real (wp), parameter :: ZERO = 0.0_wp
    real (wp), parameter :: HALF = 0.5_wp
    real (wp), parameter :: ONE = 1.0_wp
    real (wp), parameter :: TWO = 2.0_wp
    real (wp), parameter :: THREE = 3.0_wp
    real (wp), parameter :: FOUR = 4.0_wp
    real (wp), parameter :: FIVE = 5.0_wp
    !---------------------------------------------------------------------------------

end module complex_transform_routines


text:
MODULE kinds_mod
  use iso_fortran_env, only : real32, real64
  implicit none
  private
#ifdef DOUBLE
  integer, public, parameter :: KindScalarVar = real64
#else
  integer, public, parameter :: KindScalarVar = real32
#endif DOUBLE
#ifdef RT_DOUBLE
  integer, public, parameter :: KindRTVar = real64
#else
  integer, public, parameter :: KindRTVar = real32
#endif RT_DOUBLE
  type, public:: kinds_t
  contains
    procedure, nopass:: is_set
  end type
  type(kinds_t), public:: kinds
CONTAINS

!===============================================================================
!> Utility function to handle optional logical switches in parameter lists
!===============================================================================
LOGICAL FUNCTION is_set (switch)
  logical, optional:: switch
  if (present(switch)) then
    is_set = switch
  else
    is_set = .false.
  end if
END  FUNCTION

END MODULE kinds_mod

max_stars_repo_name: applejwjcat/dispatch

max_issues_repo_name: applejwjcat/dispatch

max_forks_repo_name: applejwjcat/dispatch


text:
module Dh_allDa
	! contains functions that compute the dh/dalpha matrices of the material model
	! and one main (model-indepenent) function that calls all dh/dalpha functions of the model
	! and returns the function values as a matrix

	! load additional modules
	use constants
	use material_info
	use derived_types

    implicit none

contains

	function DhDa(sigma, alpha)
		! computes the dh/dalpha matrix
		! in case of multi surface plasticity the dh/dalpha matrices of all yield surfaces
		! of the model must be computed in this subroutine
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: 					sigma		! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 					alpha		! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha),size(alpha), n_yf) :: 	DhDa	! results array of rank 3

		! internal variable
		! --------------------------------------------------------------------------

		! --------------------------------------
		! computation of all dh/dalpha matrices (modified leon, ...)
		! returning dh/dsigma matrices return array
		! --------------------------------------

		DhDa(:,:,1) = Dh_1Da(sigma, alpha)

	end function DhDa

	function Dh_1Da(sigma, alpha)
		! compute dh/dalpha matrix for the first hardening function
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(6), intent(in) :: 				sigma				! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 				alpha				! internal variables vector

		! return variable
		real(kind=dbl), dimension(size(alpha),size(alpha)) :: 	Dh_1Da

		! internal variables
		! --------------------------------------------------------------------------

		! ...

	end function Dh_1Da

end module Dh_allDa

max_issues_repo_name: OVGULIU/TsaiWu-Fortran

max_forks_repo_name: OVGULIU/TsaiWu-Fortran


text:
The Tercero Hall Cup is a competition between buildings that is held throughout the year at the Tercero residence halls. There is generally one event per quarter and the building who gets the most points at the end of the year gets their building name engraved on a trophy in a display case outside the Tercero area lounge. Past events have included scavenger hunts, iron chef competitions, improvised costume competitions, and a carnival called Terceropalooza. Points are also often earned by having members of a floor or building attend meetings and other events throughout the year.

The current holder of the Tercero Hall Cup, the winner of the 20072008 school year, is Kearney Hall Kearney 4. They won by a landslide, but had some pretty fierce competition from Kearney 1.


text:
C
C $Id: mdptre.f,v 1.9 2008-09-18 00:42:17 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDPTRE (UINS,VINS,UOUT,VOUT,UINT,VINT)
C
        DOUBLE PRECISION UINS,VINS,UOUT,VOUT,UINT,VINT
C
C This routine finds the point of intersection (UINT,VINT) of the line
C from (UINS,VINS) to (UOUT,VOUT) with the edge of an elliptical frame.
C The first point is inside the frame and the second outside the frame.
C
C Because MDPTRE can be called with the same actual arguments for UINT
C and VINT as for UOUT and VOUT, respectively, UINT and VINT must not
C be reset until all use of UOUT and VOUT is complete.
C
C Declare required common blocks.  See MAPBDX for descriptions of these
C common blocks and the variables in them.
C
        COMMON /MAPCM2/  BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG,ISSL
        DOUBLE PRECISION BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG
        INTEGER          ISSL
        SAVE   /MAPCM2/
C
C Declare local variables.
C
        DOUBLE PRECISION A,B,C,P,Q,UTM1,UTM2,UTM3,VTM1,VTM2,VTM3
C
C What's involved is just a lot of algebra.
C
        IF (ABS(UOUT-UINS).GT.ABS(VOUT-VINS)) THEN
          P=(VOUT-VINS)/(UOUT-UINS)
          Q=(UOUT*VINS-UINS*VOUT)/(UOUT-UINS)
          A=VRNG*VRNG+P*P*URNG*URNG
          B=2.D0*(P*Q*URNG*URNG-UCEN*VRNG*VRNG-P*URNG*URNG*VCEN)
          C=UCEN*UCEN*VRNG*VRNG+Q*Q*URNG*URNG-2.D0*Q*URNG*URNG*VCEN+
     +                           URNG*URNG*VCEN*VCEN-URNG*URNG*VRNG*VRNG
          UTM1=SQRT(MAX(B*B-4.D0*A*C,0.D0))
          UTM2=.5D0*(-B-UTM1)/A
          UTM3=.5D0*(-B+UTM1)/A
          IF (ABS(UTM2-(UINS+UOUT)/2.D0).LT.
     +        ABS(UTM3-(UINS+UOUT)/2.D0)) THEN
            UINT=UTM2
          ELSE
            UINT=UTM3
          END IF
          VINT=P*UINT+Q
        ELSE
          P=(UOUT-UINS)/(VOUT-VINS)
          Q=(UINS*VOUT-UOUT*VINS)/(VOUT-VINS)
          A=URNG*URNG+P*P*VRNG*VRNG
          B=2.D0*(P*Q*VRNG*VRNG-URNG*URNG*VCEN-P*UCEN*VRNG*VRNG)
          C=URNG*URNG*VCEN*VCEN+Q*Q*VRNG*VRNG-2.D0*Q*UCEN*VRNG*VRNG+
     +                           UCEN*UCEN*VRNG*VRNG-URNG*URNG*VRNG*VRNG
          VTM1=SQRT(MAX(B*B-4.D0*A*C,0.D0))
          VTM2=.5D0*(-B-VTM1)/A
          VTM3=.5D0*(-B+VTM1)/A
          IF (ABS(VTM2-(VINS+VOUT)/2.D0).LT.
     +        ABS(VTM3-(VINS+VOUT)/2.D0)) THEN
            VINT=VTM2
          ELSE
            VINT=VTM3
          END IF
          UINT=P*VINT+Q
        END IF
C
C Done.
C
        RETURN
C
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl