text:
MODULE modutils
use modalgs
use modcommons
implicit none
private
integer,parameter :: FD_SIZE = QTOOLS_FD_EXPANSION_MAX_ORDER
doubleprecision,dimension(0:FD_SIZE,-FD_SIZE:FD_SIZE) :: v_dnFdxn,v_dnFdyn,v_dnFdzn

public :: qtools_fd_template
public :: v_dnFdxn,v_dnFdyn,v_dnFdzn
public :: dnFdxn,dnFdyn,dnFdzn

contains

subroutine read_filed (UnitNum, FileName, NumRows, NumCols, Array )
  integer, intent (in) :: UnitNum
  character (len=*), intent (in) :: FileName
  integer, intent (in) :: NumRows, NumCols
  double precision, dimension (1:NumRows, 1:NumCols), intent (out) :: Array
  integer :: i, j
  open (unit=UnitNum, file=FileName, status='old', action='read' )
  do i=1, NumRows
     read (UnitNum, *) (Array (i, j), j=1,NumCols)
  end do
  close (UnitNum)
  return
end subroutine read_filed

subroutine read_filei (UnitNum, FileName, NumRows, NumCols, Array )
  integer, intent (in) :: UnitNum
  character (len=*), intent (in) :: FileName
  integer, intent (in) :: NumRows, NumCols
  integer, dimension (1:NumRows, 1:NumCols), intent (out) :: Array
  integer :: i, j
  open (unit=UnitNum, file=FileName, status='old', action='read' )
  do i=1, NumRows
     read (UnitNum, *) (Array (i, j), j=1,NumCols)
  end do
  close (UnitNum)
  return
end subroutine read_filei

integer function qtools_factorial(n) result(rval)
    integer :: n,i
    rval = 1
    do i = 1 , n
        rval = rval * i
    enddo
end function qtools_factorial

integer function qtools_Dij(i,j) result(rval)
    integer :: i,j
    rval = 0
    if(i==j) rval = 1
end function qtools_Dij
! ------------------------------------------------------------------- !
!               FINITE DIFFERENCE EXPANSION GENERATOR
! ------------------------------------------------------------------- !
! Calculate convolution vector for approximated finite difference
! derivative of order (deriv) and error order (order). You can use
! provided internal arrays: dnFdxn,dnFdyn,dnFdzn
! d_array(deriv,convolution) is filled for given deriv and values of
!       convolution are stored in range -m:m where
!       m = floor( (deriv + order - 1)/2 )
! ------------------------------------------------------------------- !
subroutine qtools_fd_template(d_array,deriv,order)
    doubleprecision,dimension(0:FD_SIZE,-FD_SIZE:FD_SIZE) :: d_array
    integer :: order,deriv
    integer :: f,i,n,m,p,d
    doubleprecision, allocatable,dimension(:,:) :: Cni

    ! clean values for given derivative

    d = deriv
    p = order

    m = floor( (p + d - 1.0)/2 )
    if(2*m + 1 /= p + d) then
        p = p + 1 ! fix order of derivative
    endif
    m = floor( (p + d - 1.0)/2 )

    if(deriv > FD_SIZE) then
        print*,"QTOOLS::Required derivative order (d) is to big"
        print*,"        Provided value:",deriv," Max. value:",FD_SIZE
        stop
    endif
    if(    m > FD_SIZE) then
        print*,"QTOOLS::Required derivative error order (p) is to big"
        print*,"        Provided value:",order," Max. value:",FD_SIZE
        stop
    endif

    ! Create coeficient matrix
    allocate(Cni(0:p + d - 1,-m:m))
    Cni = 0
    do n =  0 , p + d - 1
    do i = -m , m
        Cni(n,i) = i**n
    enddo
    enddo
    ! invert and get the values for p-th derivative
    call dalg_invmat(Cni)

    Cni = transpose(Cni)
    f = qtools_factorial(d)
    d_array(deriv,:) = 0
    do i = -m , m
         d_array(deriv,i) = f*Cni(deriv,i)
    enddo
    if(QSYS_DEBUG_LEVEL > 0) then
        print"(A,i3,A,i3)"," QTOOLS::Created FD template for d=",d," derivative of order p=",p
        print*,"        Calculated template (convolution vector):"
        print*,"        | ======================== |"
        print*,"        |  F(x +-i e ) |   VALUE   |"
        print*,"        | ======================== |"
        do i = -m , -1
             print"(A,i2,A,f10.6,A)","         | F( x -",-i,"*e ) |",d_array(deriv,i)," |"
        enddo
        print"(A,f10.6,A)","         |    F( x )    |",d_array(deriv,i)," |"
        do i =  1 , m
             print"(A,i2,A,f10.6,A)","         | F( x +",i,"*e ) |",d_array(deriv,i)," |"
        enddo
        print*,"        | ======================== |"
    endif
    deallocate(Cni)
end subroutine qtools_fd_template

doubleprecision function dnFdxn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdxn(n,dx)*qtools_Dij(0,dy)*qtools_Dij(0,dz)
end function dnFdxn

doubleprecision function dnFdyn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdyn(n,dy)*qtools_Dij(0,dx)*qtools_Dij(0,dz)
end function dnFdyn

doubleprecision function dnFdzn(n,dx,dy,dz) result(rval)
    integer :: n,dx,dy,dz
    rval = v_dnFdzn(n,dz)*qtools_Dij(0,dx)*qtools_Dij(0,dy)
end function dnFdzn

END MODULE modutils

max_stars_repo_name: kmkolasinski/Bubel

max_issues_repo_name: kmkolasinski/Bubel

max_forks_repo_name: kmkolasinski/Bubel


text:
	SUBROUTINE GQMRKR  ( imark, imkhw, szmark, imkwid, iret )
C************************************************************************
C* GQMRKR								*
C*									*
C* This subroutine returns the current marker attributes, including 	*
C* the marker number, the marker flag, the marker size and the marker   *
C* line width.								*
C*									*
C* GQMRKR  ( IMARK, IMKHW, SZMARK, IMKWID, IRET )			*
C*									*
C* Output parameters:							*
C*	IMARK		INTEGER		Marker number			*
C*	IMKHW		INTEGER		Marker flag			*
C*					  1 = software			*
C*					  2 = hardware			*
C*	SZMARK		REAL		Marker size 			*
C*	IMKWID		INTEGER		Line width 			*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* I. Graffman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* S. Schotz/GSC	 1/90	Added marker width			*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* A. Hardy/GSC          6/98   Cleaned up prolog                       *
C************************************************************************
	INCLUDE		'FUNCCODE.PRM'
	INCLUDE		'ERROR.PRM'
C
	INTEGER		isend (2), ircv (2)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 2
	isend (2) = FQMRKR
C
	CALL GPUT  ( isend, 2, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
C*	Get output parameters.
C
	CALL GGET  ( iret, 1, ierr )
	IF  ( ierr .ne. NORMAL )  THEN
	    iret = ierr
	    RETURN
	END IF
C
	CALL GGET  ( ircv, 2, ierr )
	IF  ( ierr .ne. NORMAL )  iret = ierr
	imark  = ircv (1)
	imkhw  = ircv (2)
C
	CALL GGETR  ( szmark, 1, ierr )
	IF  ( ierr .ne. NORMAL )  iret = ierr
C
	CALL GGET ( imkwid, 1, ierr )
	IF  ( ierr .ne. NORMAL )  iret = ierr
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


!-----------------------------------------------------------------
!                        input.f90  -  description
!                     ------------------------------
!          begin    : Mon 01.08.2016
!          email    : sk1916@ic.ac.uk, skournopoulos@msn.com
!-----------------------------------------------------------------
! This module is used to read and store all input variables used
! by the main program.
!
! Until an input file is prepared and tested this module will only
! contain variables that are user-defined.
!
!-----------------------------------------------------------------
!
! 10.08.2016      Created               Skou
! 15.08.2016      Added input file      Skou
!
!-----------------------------------------------------------------
Module Input
    Use nrtype
    Implicit None

    Integer(I4B) :: IFluid  = 0 ! 1 - SW
                                ! 2 - LJ

    Integer(I4B) :: IMethod = 0 ! 1 - 1st order PT
                                ! 2 - Lambda DFT

    Integer(I4B) :: NTermsCP = 0 !  number if terms to calculate for coupling parameter method
    Real(DP)     :: relaxation   ! multiplied with delta to relax the Newton method (1 is the default value)\
    Real(DP)     :: tolerance    ! tolerance of the numerical method

    ! temperature - initial/final value and increment
    Real(DP)     :: T_init = ZERO ! Τ = 146.4 Τ*
    Real(DP)     :: T_end  = ZERO
    Real(DP)     :: T_inc  = ZERO

    ! initial guesses for packing fractions. they correspond to T_init
    Real(DP)     :: eta_l_init = ZERO   ! eta = rho * 1.3703744
    Real(DP)     :: eta_g_init = ZERO

    ! fluid parameters
    Real(DP)     :: sigma       = ZERO            ! meters
    Real(DP)     :: eps_over_k  = ZERO            ! epsilon over k in Kelvin
    Real(DP)     :: range_attr  = ZERO
    Real(DP)     :: range_rep   = ZERO
    Real(DP)     :: part_mass   = ZERO            ! mass of one particle (eg methane) in kg

    ! output file path and name
    Character    :: CFileOutput*240

contains

    !-----------------------------------------------------------
    !  Read input file. Check input variables for consistency
    !-----------------------------------------------------------
    Subroutine ReadInput
        Implicit None
        Integer(I4B)   :: NLinesRead, IUn

        NLinesRead = 0
        IUn        = NGetFileUnit()
        open(IUn, File='input_phaseEq.txt', status='OLD', ERR=67)

        call ReadCommentLines(IUn, 3)
        NLinesRead  = NLinesRead + 3

        read(IUn, *, ERR=66) CFileOutput
        NLinesRead = NLinesRead + 1

        call ReadCommentLines(IUn, 8)
        NLinesRead  = NLinesRead + 8

        read(IUn, *, ERR=66) IFluid, IMethod, NTermsCP, relaxation, tolerance
        NLinesRead  = NLinesRead + 1

        if ( (IFluid  < 1).OR.(IFluid  > 2) ) STOP "ReadInput: ERROR - IFluid options are 1 (SW) or 2 (LJ)"
        if ( (IMethod < 1).OR.(IMethod > 2) ) STOP "ReadInput: ERROR - IMethod options are 1 (1st order pert theory) &
                                                                       or 2 (lambda method)"
        call ReadCommentLines(IUn, 5)
        NLinesRead  = NLinesRead + 5

        read(IUn, *, ERR=66) T_init, T_end, T_inc, eta_l_init, eta_g_init
        NLinesRead  = NLinesRead + 1

        if (.NOT. (SIGN(ONE,T_end - T_init) == SIGN(ONE,T_inc))) &
            STOP "ReadInput: ERROR - Change the sign of T_inc or the order of T_init, T_end"

        call ReadCommentLines(IUn, 5)
        NLinesRead  = NLinesRead + 5

        read(IUn, *, ERR=66) sigma, eps_over_k, range_rep, range_attr, part_mass
        NLinesRead  = NLinesRead + 1

        ! units transformation to SI
        sigma      = sigma*1.D-10

        close(IUn)

        return

        66 print*, 'ReadInput: Read Error - LinesRead ', NLinesRead ; close(IUn) ; STOP
        67 print*, 'ReadInput: Open  Problem'                       ; close(IUn) ; STOP
    End Subroutine ReadInput

    !-----------------------------------------------------------
    !  Read a number of comment lines from a given file
    !-----------------------------------------------------------
    Subroutine ReadCommentLines(IFileUnit, NLines)
        Implicit None
        Integer(I4B) :: IFileUnit, NLines, i ; Character :: CDummy*1
        Intent(IN)   :: IFileUnit, NLines
        do i=1, NLines  ;  read(IFileUnit,*) CDummy  ;  enddo
    End Subroutine ReadCommentLines

    !-----------------------------------------------------------
    ! Give sequential file unit numbers on each call,
    ! starting from "NFileUnit"
    !-----------------------------------------------------------
    Function NGetFileUnit()
        Implicit None
        Integer(I4B)       :: NGetFileUnit
        Integer(I4B), Save :: NFileUnit = 20
        NGetFileUnit = NFileUnit
        NFileUnit    = NFileUnit + 1
    End Function NGetFileUnit

End Module Input


text:
Barnabas Truman started life as a harmlesslooking little kittycat. My, how hes grown since then!

Okay, so he went through a rather awkward phase during the 1970s. Didnt we all? And dont you wish you hadnt seen this? Thats what I thought. Move along now.

In the summer of 1600, Truman was working as a bounty hunter and trying to hunt down his cousin, the notorious pirate captain Mad Morgan Burnsides. After a long and glorious battle, Truman was beginning to gain the upper hand, but a fateful accident (apparently involving an accordion, a scimitar, and three bottles of fine Jamaican rum; he doesnt like to talk about it much) caused him to lose his beard, his honor, and his left eye, and the brave Truman was forced to retreat. While recuperating from his injuries he learned to play Irish music on the hammer dulcimer (already being quite skilled on the pennywhistle and wiki:WikiPedia:Bodhran bodhrán).

As soon as his beard grew back in, Truman donned his green warcloak and picked up his mighty staff, and, invoking the powers of the mighty surfer god Saint Christopher, walked boldly across the waters of the ocean, once again seeking the dastardly pirate Burnsides. This time he won the battle, regained his honor, and took Burnsidess awesome pirate hat as spoils of his victory. Tragically, it was not until Truman triumphantly returned home that he realized to his horror that he had been wearing the eyepatch on the wrong side the whole time.

At some point in history, Barnabas found the time to earn a bachelors degree in mathematicks, with a minor in philosophy. This picture proves it! See? Also, he has horns. Sometimes. Theyre retractable.

He now lives under the Bike Tunnels bridge between Olson Hall Olson and Shields Library, as a friendly ogre. Any rumors that he eats a freshman each year are slanderous, and any resemblance to a certain halfgiant wizard school dropout is strictly coincidental (he had the beard way before http://www.sunpig.com/abi/images/2005/11/hagrid.jpg Robbie Coltraine made it popular!).

Truman works as a TA for the Mathematics math department and an observer/judicator for the Ancient Order of Walkers. He spends most of his spare time playing awexome Irish folk music, getting very close to ascending in NetHack, thinking about mathematicks, thinking about his lady fair, thinking about Renaissance Faires, arguing about philosophy/religion/politics/whatever strikes his fancy, watching silly Flash cartoons, reading silly web comics and sillier fantasy novels, and telling ridiculous stories like the one you have just read. He has also taken up, as a hobby, the study of the Campus Crusade for Chaos and Confusion and its history and philosophy. He does not have a grappling hook, but he does have a really cool walkingstaff. (Sorry, ladies, Mr. Truman is no longer single.)

20050504 19:35:21 nbsp You know what Barnabas, you really scare me sometimes... Users/MeganCurtis

20050704 23:13:28 nbsp f.n.o.r.d. Users/SirPallas

20051023 14:17:34 nbsp Drop me a line, I have the fifty punds of fish guts you requested last week.  This is a limited time offer. Users/JaniceGutshall

20051024 22:05:40 nbsp Mmm, I just love punds of fish guts! Users/BarnabasTruman

20060111 12:00:56 nbsp Hi, Im writing an article for the California Aggie on the Jagged Tree. You had some really nice things to say about it and I was wondering if I could interview you. If you are interested, my email is cemaris@ucdavis.edu. Carly Users/LizethCazares

20060209  2:41:00 nbsp There where four of us. Everything fell apart. I’m sorry. I found out I’m Manicdepressive.  It explains some things.  I still feel embarrassed. I want to come to terms with Matt’s death.  Could you tell me if there is a place dedicated to remembering him? Also, On one hand I’m trying to make more since of C4, MBS, and exponential distributions.  On the other, I’m looking for some one who knows how to play Go.  Could you help me with any of this?
    There is a group that plays Go at the E Street Cafe Roma early Thursday evenings.  There are also various student and public grief counseling services available that you might look into.  Most are very low pressure and just give you a place to talk and discuss your emotional state.   Users/JabberWokky
    Given that I am 452 miles from E Street, Google’s guess is that I would make it there around midnight.  So even though I would very much love to come today I will have to wait until next Thursday.  Also, I want to thank you for making this easier JabberWokky.  Users/PatrickStaight

20060527 21:22:10 nbsp You look a lot like my geometry TA from last quarter, who was a very demanding grader on the journals, but added a lot of insight through his frequent comments, increasing my learning experience.  i still cant figure out how you folded the corner of that page so it wasnt straight   :) Users/MattHh

20060714 13:27:46 nbsp Hey Barnabas! Im from the Pacifico coop, and Im working under the new management (nasco) to change things around here.  I read your comment on the Pacifico wiki page, and I was just wondering if you would be open to changing or removing the comment (and maybe also elaborating on your experience to me via emailI really want to hear about experiences and ideas to make it better).  I really appreciate the comment and definitely want people to have an honest perspective of the place, but I was hoping you might be on our side in trying to start fresh.  Were having a tough time getting people in here, a lot because theres a bad impression out there.  But I think theres a lot of potential.  My email is alice@pacifico.nasco.coop, I really hope to hear from you! Users/AliceWhite

20060720 20:12:17 nbsp is that a real Les Paul in your picture? Or an Ibenez imitation? Either way cool. Users/CarlosBarahona

20060721 01:58:46 nbsp Thatd be a question for my brother; I just borrowed his for the photo shoot. Users/BarnabasTruman

20060728 07:46:46 nbsp The reason we dont have html tags is because we are nazis who believe in the superiority of our markup language (Heil!) that is more user friendly, and moreover is master (Heil!). It also lets the site look more coherent than myspace. Users/NickSchmalenberger

20060927 21:17:37 nbsp Barnabas Truman is an excellent geometer... wellversed in the classical art... Users/PaulCernea

20061104 19:09:42 nbsp did math 23 ever really exist? or is it just not offered anymore?  by the way not many people can pull off the cape quite as well as you do.  It must be an inate gift. Users/MattHh

20061106 18:20:46 nbsp Math 23? Well, not officially; it was more of a Discordian joke. Note the professor listed on http://www.math.ucdavis.edu/~phoenix/index23.html the course website. I do offer cheap tutoring in numerology for interested parties though. Users/BarnabasTruman

20070308 00:58:12 nbsp hi Barnabas, I am writing an article about beards for my journalism class and would very much like to speak with you. If you will, would you please contact me at mailto(emkane AT ucdavis DOT edu) ASAP? I would appreciate it very much! Users/EliseKane

20100725 03:57:56 nbsp IT BE BARNABAS! O{{{__}}}O A WIKI LEGEND AWAKENS FROM HIS SLUMBNER Users/StevenDaubert

20101028 20:44:45 nbsp Hey Barnabas, I have a bike over at the shop for your wife.  Go ahead and bring back the rental and she can take the new one home. Users/Aaron.Curtin

20111119 00:24:46 nbsp A WILD BARNABAS APPEARS! Users/StevenDaubert

20111119 00:39:08 nbsp Barnabas was a servant of the people. He did what was needed. Now he is needed again. Users/BarnabasTruman

20111203 13:20:58 nbsp If you could get some photos of Dutton, that would be great to preserve (well, not ideal in terms of agenda, but great in terms of preserving this bit of history). Users/JabberWokky

20120501 nbsp http://www.theaggie.org/2012/05/01/abacuswizardfactorsrenaissanceintotheequation/ Hey, look, a spotting in the wild! I love how the entire basis of this article is, Look, some dude wears a CAPE! Around school! Like, every day, even! Users/JenniferRutherford

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine stressperm_6(i)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************

c     same as model 5 but added pore pressure term
c
c     perm model 2 - volume strains
c     lagged permeability only (stress-based) (only after each time step)
c     only good for 2D or 3D models
c
c     need to subtract biot and thermal stresses to get
c     lithostatic component
      use comai
      use combi
      use comdi
      use comsi

      implicit none
      integer i, iispmd,ipchk

      real*8 biot,ctherm,e1i,e2i,e3i,erat,efac,epi,eti,dpd,dt
      real*8 shti,shpi,lith_damage_fac,str_eff,pary1,pary2
      real*8 pary3,parsy3,parx1,parx2,parx3,parsx3,stress_min_prin
      real*8 lith_min,pterm,parxy3,parxz3,paryz3,parz1,parz2
      real*8 parsz3,parz3

      parameter (lith_min = 1.0)
c
c

      biot=bulk(i)
      ctherm=alp(i)
      e1i = e1(i)
      e2i = e2(i)
      e3i = e3(i)
      erat=e2i/e1i
      efac=3.d0*e2i+2.d0*e3i
c     stress due to temp and pore pressure changes
      epi=efac*biot
      eti=efac*ctherm
      dpd=phi(i)-phini(i)
      dt=t(i)-tini(i)
      shti=(eti*dt)
      shpi=(epi*dpd)

c     spm1f is strx_min, min x-tensile stressfor damage to occur
c     spm2f is stry_min, min y-tensile stressfor damage to occur
c     spm3f is stry_min, min z-tensile stressfor damage to occur
c     spm4f is e10_facx, damage factor (maximum x) for elastic modulus
c     spm5f is e10_facy, damage factor (maximum y) for elastic modulus
c     spm6f is e10_facz, damage factor (maximum z) for elastic modulus
c     spm7f is str_multx, maximum change in x-permeability allowed
c     spm8f is str_multy, maximum change in y-permeability  allowed
c     spm9f is str_multz, maximum change in z-permeability  allowed
c     model 3 and model 5 are fully coupled
c     model 6 is simple directional plasticity
c
      if(icnl.ne.0) then
c     2D x-y version  (y can be vertical)
         strx_min = spm1f(iispmd)
         stry_min = spm2f(iispmd)
         e10_facx = spm4f(iispmd)
         e10_facy = spm5f(iispmd)
         perx_m = spm7f(iispmd)
         pery_m = spm8f(iispmd)
         lith_damage_fac = spm10f(iispmd)
         str_eff = spm11f(iispmd)
c
         ipchk = 0
c     changes occur
c     x direction changes
         if(str_y(i).lt.-stry_min) then
c     pary1 is stress diffrence in tension
            pary1 = abs((str_y(i))+stry_min)
c     assume max perm changes occur at tensile stress of
c     tesile_stess_fac (=10)
            pary2 = stry_min*(tensile_str_fac-1.)
            pary3 = (perx_m-1.)/pary2
            pnx(i) = pnx0(i)*(pary3*pary1+1.0)
c     rock strength never increases
            parsy3 =  (e10_facy-1.)/pary2
            e1(i) = min(e1(i),e10(i)*(parsy3*pary1+1.0))
            e2(i) = min(e2(i),e20(i)*(parsy3*pary1+1.0))
            e3(i) = min(e3(i),e10(i)*(parsy3*pary1+1.0))
            e1(i) = max(e1(i), e10_facy*e10(i))
            e2(i) = max(e2(i), e10_facy*e20(i))
            e3(i) = max(e3(i), e10_facy*e30(i))
         endif
         if(str_x(i).lt.-strx_min) then
c     parx1 is stress diffrence in tension
            parx1 = abs((str_x(i))+strx_min)
c     assume max perm changes occur at tensile stress of
c     tesile_stess_fac (=10)
            parx2 = stry_min*(tensile_str_fac-1.)
            parx3 = (pery_m-1.)/parx2
            pny(i) = pny0(i)*(parx3*parx1+1.0)
c     rock strength never increases
            parsx3 =  (e10_facx-1.)/parx2
            e1(i) = min(e1(i),e10(i)*(parsx3*parx1+1.0))
            e2(i) = min(e2(i),e20(i)*(parsx3*parx1+1.0))
            e3(i) = min(e3(i),e30(i)*(parsx3*parx1+1.0))
            e1(i) = max(e1(i), e10_facx*e10(i))
            e2(i) = max(e2(i), e10_facx*e20(i))
            e3(i) = max(e3(i), e10_facx*e30(i))
         endif
c
c     pore pressure term (greater than the minimum earth stress)
c     only effects y direction (assumed the maximum stress direction)
c
         if(lith_damage_fac.gt.0.0) then
            stress_min_prin =
     &           max((str_y(i))*lith_damage_fac,lith_min)
            pterm = phi(i)-pres_elev
            pary1 = (pterm-stress_min_prin)/stress_min_prin
            if(pary1.gt.0.0) then
               pary3 = (pery_m-1.)/str_eff
               pny(i) = pny0(i)*(pary3*pary1+1.0)
            endif
         endif

c
         pnx(i) = min(perx_m*pnx0(i),pnx(i))
         pny(i) = min(pery_m*pny0(i),pny(i))
c
      else if(icnl.eq.0) then
c
c     3D  version  (z is always the vertical direction)
c
         strx_min = spm1f(iispmd)
         stry_min = spm2f(iispmd)
         strz_min = spm3f(iispmd)
         e10_facx = spm4f(iispmd)
         e10_facy = spm5f(iispmd)
         e10_facz = spm6f(iispmd)
         perx_m = spm7f(iispmd)
         pery_m = spm8f(iispmd)
         perz_m = spm9f(iispmd)
         lith_damage_fac = spm10f(iispmd)
         str_eff = spm11f(iispmd)
c
         ipchk = 0
c
c     x direction tensile stress affects y and z perms
c
c     determine maximum changes affecting x direction
         parx1 = 0.
         if(str_x(i).lt.-strx_min) then
c     parx1 is stress difference in tension	- x direction
            parx1 = abs((str_x(i))+strx_min)
         endif
         if(parx1.gt.0.0) then
c     parx1 is stress diffrence in tension calculated above
c     assume max perm changes occur at tensile stress of
c     tesile_stess_fac(=10)
c     change x and z dirextions
            parx2 = strx_min*(tensile_str_fac-1.)
            parxy3 = (pery_m-1.)/parx2
            pny(i) = pny0(i)*(parxy3*parx1+1.0)
            parxz3 = (perz_m-1.)/parx2
            pnz(i) = pnz0(i)*(parxz3*parx1+1.0)
c     rock strength never increases
            parsx3 =  (e10_facx-1.)/parx2
            e1(i) = min(e1(i),e10(i)*(parsx3*parx1+1.0))
            e2(i) = min(e2(i),e20(i)*(parsx3*parx1+1.0))
            e3(i) = min(e3(i),e30(i)*(parsx3*parx1+1.0))
            e1(i) = max(e1(i), e10_facx*e10(i))
            e2(i) = max(e2(i), e10_facx*e20(i))
            e3(i) = max(e3(i), e10_facx*e30(i))
         endif
c
c     y direction tensile stress affects x and z perms
c
c     determine maximum changes affecting y direction
         pary1 = 0.
         if(str_y(i).lt.-stry_min) then
c     pary1 is stress difference in tension	- y direction
            pary1 = abs((str_y(i))+stry_min)
         endif
         if(pary1.gt.0.0) then
c     pary1 is stress diffrence in tension	calculated above
c     assume max perm changes occur at tensile stress of
c     tesile_stess_fac(=10)
c     change x and z dirextions
            pary2 = stry_min*(tensile_str_fac-1.)
            parxy3 = (perx_m-1.)/pary2
            pnx(i) = pnx0(i)*(parxy3*pary1+1.0)
            paryz3 = (perz_m-1.)/pary2
            pnz(i) = pnz0(i)*(paryz3*pary1+1.0)
c     rock strength never increases
            parsy3 =  (e10_facy-1.)/pary2
            e1(i) = min(e1(i),e10(i)*(parsy3*pary1+1.0))
            e2(i) = min(e2(i),e20(i)*(parsy3*pary1+1.0))
            e3(i) = min(e3(i),e30(i)*(parsy3*pary1+1.0))
            e1(i) = max(e1(i), e10_facy*e10(i))
            e2(i) = max(e2(i), e10_facy*e20(i))
            e3(i) = max(e3(i), e10_facy*e30(i))
         endif
c
c     z direction tensile stress affects x and y perms
c
c     determine maximum changes affecting z direction
         parz1 = 0.0
         if(str_z(i).lt.-strz_min) then
c     parz1 is stress difference in tension - z direction
            parz1 = abs((str_z(i))+strz_min)
         endif
         if(parz1.gt.0.0) then
c     parz1 is stress diffrence in tension	calculated above
c     assume max perm changes occur at tensile stress of
c     tesile_stess_fac(=10)
c     change x and y dirextions
            parz2 = strz_min*(tensile_str_fac-1.)
            parxz3 = (perx_m-1.)/parz2
            pnx(i) = pnx0(i)*(parxz3*parz1+1.0)
            paryz3 = (pery_m-1.)/parz2
            pny(i) = pny0(i)*(paryz3*parz1+1.0)
c     rock strength never increases
            parsz3 =  (e10_facz-1.)/parz2
            e1(i) = min(e1(i),e10(i)*(parsz3*parz1+1.0))
            e2(i) = min(e2(i),e20(i)*(parsz3*parz1+1.0))
            e3(i) = min(e3(i),e30(i)*(parsz3*parz1+1.0))
            e1(i) = max(e1(i), e10_facz*e10(i))
            e2(i) = max(e2(i), e10_facz*e20(i))
            e3(i) = max(e3(i), e10_facz*e30(i))
         endif
c
c     effective stress permeability enhancement
c     assume z direction is the maximum lithostatic stress direction
c
         if(lith_damage_fac.gt.0.0) then
            stress_min_prin =
     &           max((str_z(i))*lith_damage_fac,lith_min)
            pterm = phi(i)-pres_elev
            parz1 = (pterm-stress_min_prin)/stress_min_prin
            if(parz1.gt.0.0) then
               parz3 = (perz_m-1.)/str_eff
               pnz(i) = pnz0(i)*(parz3*parz1+1.0)
            endif
         endif
         pnx(i) = min(perx_m*pnx0(i),pnx(i))
         pny(i) = min(pery_m*pny0(i),pny(i))
         pnz(i) = min(perx_m*pnz0(i),pnz(i))

      endif

      return

      end
c....................................................................

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM


text:
Wicca, Witchcraft, and Magick is a free course taught through the Experimental College. You can sign up inperson or online.

Forget double double toil and trouble, Harry Potter, and devil worship; learn about real witchcraft. This course is for everyone from experienced practitioners looking for a different perspective, to people brand new to witchcraft. Discussion and handson activities will feature prominently in this course. We will start with the history and theory behind paganism and the Craft, seeing where science, faith, and ethics intersect. From this we will progress into drawing a circle, calling quarters, deities, divination, and ritual itself.


text:
      subroutine sphere46_compute_error(blockno, mx,my,mbc,meqn,
     &      dx,dy,xlower,ylower,t,q,error, soln)
      implicit none

      integer mx,my,mbc,meqn, blockno
      double precision dx, dy, xlower, ylower, t
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision error(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision soln(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer*8 cont, get_context

      integer example
      common /example_comm/ example

      integer i,j
      double precision xc,yc, qexact
      double precision xc1, yc1
      double precision xp, yp, zp
      integer flow_flag

      cont = get_context()

      if (example .ne. 3) then
c          # Divergent flow
           flow_flag = 0
      else
c          # non-divergent flow
           flow_flag = 1
      endif

c     # Assume a single field variable only
      do j = 1,my
         yc = ylower + (j-0.5)*dy
         do i = 1,mx
            xc = xlower + (i-0.5)*dx

            if (t .eq. 0) then
               soln(i,j,1) = q(i,j,1)
            else
c              # Map computational coordinates to unit square
               call fclaw2d_map_c2m(cont,blockno,xc,yc,xp, yp, zp)
               call user_map2comp(blockno,xc,yc,xp,yp,zp,xc1,yc1)
               soln(i,j,1) = qexact(xc1,yc1,t,flow_flag)
            endif
            error(i,j,1) = q(i,j,1) - soln(i,j,1)
         enddo
      enddo

      end

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
      program main
      implicit none
      include "omp_lib.h"
      integer nthreads, tid

C$OMP PARALLEL PRIVATE(nthreads, tid)
      tid = OMP_GET_THREAD_NUM()
      print *, "Hello, world! I am thread ", tid
C$OMP BARRIER
      if (tid .eq. 0) then
        nthreads = OMP_GET_NUM_THREADS()
        print *, "Number of threads = ", nthreads
      end if
C$OMP END PARALLEL

      stop
      end

max_stars_repo_name: shawfdong/hyades

max_issues_repo_name: shawfdong/hyades

max_forks_repo_name: shawfdong/hyades


text:
! { dg-do compile }
module test_common_binding_labels_2
  use, intrinsic :: iso_c_binding, only: c_double, c_int
  implicit none

  common /mycom/ r, s
  real(c_double) :: r
  real(c_double) :: s
  bind(c, name="my_common_block") :: /mycom/

  common /com2/ i
  integer(c_int) :: i
  bind(c, name="") /com2/
end module test_common_binding_labels_2

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
program main
    use plantFEM
    implicit none

    type(FEMDomain_) :: dam
    real(real64) :: x(4),altitude(4)

    ! plantFEM用メッシュ生成スクリプト
    ! https://github.com/kazulagi/plantFEM

    ! メッシュの元となったデータ：
    ! 牧　隆泰, 1958, 日本水利施設進展の研究, 土木雑誌社

    ! 以下、メッシュ分割プログラム
    ! 要素分割数
    call dam%create(meshtype="Cube",x_num=40,y_num=30,z_num=12)
    ! 堤体寸法(上下流方向長 m,堤長不明（暫定99.86m), 堤高13m)
    call dam%resize(x=90.00d0,y=99.86d0,z=3.0d0)
    call dam%move(x=-5.0d0,z=-2.0d0)
    ! 上流からx(n) m 進んだ地点の高さがaltitude(n) m
    ! 勾配はgoogle earth からの推定
    x(1) = 0.00d0;              altitude(1) = 0.0d0+1.00d0;
    x(2) = 13.0d0*3.0d0;         altitude(2) = 13.0d0+1.0d0;
    x(3) = 13.0d0*3.0d0+7.3d0;  altitude(3) = 13.0d0+1.0d0;
    x(4) = 13.0d0*3.0d0+7.3d0+13.0d0*2.50d0; altitude(4) = 0.0d0+1.0d0;
    call dam%edit(x=x, altitude=altitude)

    ! 保存
    call dam%msh("国兼池")
    call dam%stl("国兼池")

end program main

max_stars_repo_name: kazulagi/earthdamjp

max_issues_repo_name: kazulagi/earthdamjp

max_forks_repo_name: kazulagi/earthdamjp


module eu_model
  use data_type
  use reconstruction
  use gradient
  use time_advance
  use mesh
  use eu_data_type
  use eu_physics
  use eu_solver
  use eu_boundary
  implicit none
  ! Riemann solver indices
  integer,parameter :: benchmark_idx_ivc           = 1
  integer,parameter :: benchmark_idx_shockvortex   = 2
  integer,parameter :: benchmark_idx_doublemach    = 3
  integer,parameter :: benchmark_idx_shockshear    = 4
  integer,parameter :: benchmark_idx_shockboundary = 5
  integer,parameter :: benchmark_idx_sedov         = 6
  integer,parameter :: benchmark_idx_rt            = 7
  integer,parameter :: benchmark_idx_rm            = 8
  integer,parameter :: benchmark_idx_forwardstep   = 9
  integer,parameter :: benchmark_idx_backwardstep  = 10
  integer,parameter :: benchmark_idx_sod           = 11
  integer,parameter :: benchmark_idx_lax           = 12
  integer,parameter :: benchmark_idx_shuosher      = 13
  integer,parameter :: benchmark_idx_blast         = 14

  character(len=64) :: file_fmt

  integer :: base_flwd_count = 0
  class(eu_data_list_t), pointer :: base_flwd_list, &
                                    base_flwd_list_tail

  integer :: flwd_count
  type(eu_data_iterator_t),dimension(:),allocatable :: flwd_que ! decomposited flwd_que

  ! global model variables
  double precision :: max_eig_xi_g,max_eig_eta_g
  double precision :: dt_g = 1.d0

  double precision :: gamma = 1.4d0
  double precision :: Mach_inf = 1.d0
  double precision :: T_inf = 300.d0 ,T_ref = 110.0d0
  integer :: riemann_solver = 0
  integer :: benchmark_idx = 0
  NAMELIST/model_eu_params/ gamma, Mach_inf, T_inf,T_ref, &
                            riemann_solver,               &
                            benchmark_idx,file_fmt

  integer :: reconst_xi_idx      = upwind1_id
  integer :: reconst_eta_idx     = upwind1_id
  integer :: grad_xi_idx         = grad_2nd_l1_idx
  integer :: grad_eta_idx        = grad_2nd_l1_idx
  integer :: time_integrator_idx = rk3rdtvd_idx
  integer :: max_stage
  logical :: adaptive_dt = .true.
  double precision :: cfl = 0.5d0
  namelist /numeric_params/ reconst_xi_idx,reconst_eta_idx, &
                            grad_xi_idx,grad_eta_idx, &
                            time_integrator_idx,cfl,dt_g,adaptive_dt

  double precision :: x0,y0,xl,yl
  integer :: isize_plane,jsize_plane
  integer :: ibf_plane,jbf_plane
  double precision :: uinf = 0.5d0, vinf = 0.d0, b0 = 0.5d0
  NAMELIST/model_eu_ivc_params/ uinf, vinf, b0,    &
                                x0, y0, xl, yl,           &
                                isize_plane, jsize_plane, &
                                ibf_plane, jbf_plane

  NAMELIST/model_eu_shockvortex_params/ x0, y0, xl, yl,   &
                                        isize_plane,jsize_plane, &
                                        ibf_plane,jbf_plane

  NAMELIST/model_eu_doublemach_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_shockshear_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_shockboundary_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_sedov_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_rt_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_rm_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  double precision :: xa0,ya0,xb0,yb0,xal,yal,xbl,ybl
  integer :: nn
  NAMELIST/model_eu_fs_params/  xa0,ya0,xb0,yb0,    &
                                xal,yal,xbl,ybl,    &
                                nn,                 &
                                ibf_plane,jbf_plane

  NAMELIST/model_eu_bs_params/ x0, y0, xl, yl,   &
                                       isize_plane,jsize_plane, &
                                       ibf_plane,jbf_plane

  NAMELIST/model_eu_sod_params/ x0, y0, xl, yl,   &
                                isize_plane,jsize_plane, &
                                ibf_plane,jbf_plane

  NAMELIST/model_eu_lax_params/ x0, y0, xl, yl,   &
                                isize_plane,jsize_plane, &
                                ibf_plane,jbf_plane

  NAMELIST/model_eu_shuosher_params/ x0, y0, xl, yl,   &
                                isize_plane,jsize_plane, &
                                ibf_plane,jbf_plane

  NAMELIST/model_eu_blast_params/ x0, y0, xl, yl,   &
                                isize_plane,jsize_plane, &
                                ibf_plane,jbf_plane

  interface
    module subroutine initial_model_eu_ivc(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_ivc

    module subroutine initial_model_eu_sv(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_sv

    module subroutine initial_model_eu_dm(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_dm

    module subroutine initial_model_eu_ssl(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_ssl

    module subroutine initial_model_eu_sb(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_sb

    module subroutine initial_model_eu_sedov(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_sedov

    module subroutine initial_model_eu_rt(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_rt

    module subroutine initial_model_eu_rm(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_rm

    module subroutine initial_model_eu_fs(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_fs

    module subroutine initial_model_eu_bs(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_bs

    module subroutine initial_model_eu_sod(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_sod

    module subroutine initial_model_eu_lax(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_lax

    module subroutine initial_model_eu_shuosher(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_shuosher

    module subroutine initial_model_eu_blast(funit)
      implicit none
      integer,intent(in) :: funit
    end subroutine initial_model_eu_blast
  end interface

contains
subroutine write_model_inp_eu(funit)
  implicit none
  integer,intent(in) :: funit
  write(funit,NML=model_eu_params)
  write(funit,NML=numeric_params)
  write(funit,NML=model_eu_ivc_params)
  write(funit,NML=model_eu_shockvortex_params)
  write(funit,NML=model_eu_doublemach_params)
  write(funit,NML=model_eu_shockshear_params)
  write(funit,NML=model_eu_sod_params)
  write(funit,NML=model_eu_lax_params)
  write(funit,NML=model_eu_shuosher_params)
  write(funit,NML=model_eu_blast_params)
end subroutine write_model_inp_eu

subroutine create_model_eu(funit)
  implicit none
  integer,intent(in) :: funit
  read(funit,NML=model_eu_params)
  read(funit,NML=numeric_params)
  max_stage = set_maxstage(time_integrator_idx)
  select case(benchmark_idx)
    case(benchmark_idx_ivc)
      read(funit,NML=model_eu_ivc_params)
    case(benchmark_idx_shockvortex)
      read(funit,NML=model_eu_shockvortex_params)
    case(benchmark_idx_doublemach)
      read(funit,NML=model_eu_doublemach_params)
    case(benchmark_idx_shockshear)
      read(funit,NML=model_eu_shockshear_params)
    case(benchmark_idx_shockboundary)
    case(benchmark_idx_sedov)
    case(benchmark_idx_rt)
    case(benchmark_idx_rm)
    case(benchmark_idx_forwardstep)
      read(funit,NML=model_eu_fs_params)
    case(benchmark_idx_backwardstep)
    case(benchmark_idx_sod)
      read(funit,NML=model_eu_sod_params)
    case(benchmark_idx_lax)
      read(funit,NML=model_eu_lax_params)
    case(benchmark_idx_shuosher)
      read(funit,NML=model_eu_shuosher_params)
    case(benchmark_idx_blast)
      read(funit,NML=model_eu_blast_params)
    case default
      print*,"Error: create_model_eu()"
      print*,"Invalid benchmark index: ",benchmark_idx
      stop
  end select
end subroutine create_model_eu

subroutine initial_model_eu(funit)
  implicit none
  integer,intent(in) :: funit
  print*,"Initializing Euler model:"
  select case(benchmark_idx)
  case(benchmark_idx_ivc)
    print*," - Isentropic Vortex Convection."
    call initial_model_eu_ivc(funit)
  case(benchmark_idx_shockvortex)
    print*," - Shock Vortex Interaction."
    ! call initial_model_eu_svi(funit)
  case(benchmark_idx_doublemach)
    print*," - Double Mach Reflection."
    call initial_model_eu_dm(funit)
  ! case(benchmark_idx_shockshear)
  !   print*," - Shock Shear Layer Interaction."
  !   call initial_model_eu_ss(funit)
  ! case(benchmark_idx_shockboundary)
  !   print*," - Shock Boundary Layer Interaction."
  !   ! call initial_model_eu_sb(funit)
  ! case(benchmark_idx_sedov)
  !   print*," - Sediv Problem."
  ! case(benchmark_idx_rt)
  !   print*," - Rayleigh-Taylor Interaction."
  ! case(benchmark_idx_rm)
  !   print*," - Richtmyer-Meshkov Instability."
  case(benchmark_idx_forwardstep)
    print*," - Forward Wind Tunnel Step."
    call initial_model_eu_fs(funit)
  ! case(benchmark_idx_backwardstep)
  !   print*," - Backward Wind Tunnel Step."
  ! case(benchmark_idx_sod)
  !   print*," - Sod shock tube problem."
  !   call initial_model_eu_sod(funit)
  ! case(benchmark_idx_lax)
  !   print*," - Lax shock tube problem."
  !   call initial_model_eu_lax(funit)
  ! case(benchmark_idx_shuosher)
  !   print*," - Shu-Osher problem."
  !   call initial_model_eu_shuosher(funit)
  ! case(benchmark_idx_blast)
  !   print*," - Blast wave problem."
  !   call initial_model_eu_blast(funit)
  case default
    print*,"Error: initial_model_eu()"
    print*,"Invalid benchmark index: ",benchmark_idx
    stop
  end select
end subroutine initial_model_eu

subroutine evolve_model_eu(istep,time,elasp_time)
  implicit none
  integer,intent(inout) :: istep
  double precision,intent(inout) :: time,elasp_time
  type(eu_data_t),pointer :: flwd
  integer :: istage,iflwd
  istage = 1
  do while(istage.le.max_stage)
    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      call flwd%set_stage(istage)
    enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      flwd%info%eig_xi  = 0.d0
      flwd%info%eig_eta = 0.d0
    enddo
    !$OMP END PARALLEL DO

    ! Convert conservative variables to primatives for interior grids
    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      call cmpt_prim_eu(flwd)
    enddo
    !$OMP END PARALLEL DO

    ! Set boundary condition and convert cons to prims or prims to cons
    ! according to bc type
    !$OMP PARALLEL DO PRIVATE(iflwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      call set_bc_eu(flwd_que,flwd_count,iflwd)
    enddo
    !$OMP END PARALLEL DO

    max_eig_xi_g  = 0.d0
    max_eig_eta_g = 0.d0
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      max_eig_xi_g  = max(max_eig_xi_g,flwd%info%eig_xi)
      max_eig_eta_g = max(max_eig_eta_g,flwd%info%eig_eta)
    enddo

    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      flwd%info%eig_xi_g  = max_eig_xi_g
      flwd%info%eig_eta_g = max_eig_eta_g
    enddo
    !$OMP END PARALLEL DO

    ! Convective terms
    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      call cmpt_cnvt_eu(flwd,           &
                        riemann_solver, &
                        reconst_xi_idx, &
                        reconst_eta_idx)
    enddo
    !$OMP END PARALLEL DO

    ! Diffusive terms
    ! do iflwd = 1, flwd_count
    !   flwd => flwd_que(iflwd)%flwd
    !   call cmpt_dfsv_eu(flwd,        &
    !                     grad_xi_idx, &
    !                     grad_eta_idx)
    ! enddo

    ! do iflwd = 1, flwd_count
    !   flwd => flwd_que(iflwd)%flwd
    !   call cmpt_lhs_eu(flwd)
    ! enddo

    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      call cmpt_rhs_eu(flwd)
    enddo
    !$OMP END PARALLEL DO

    if((istage.eq.1) .and. &
       (adaptive_dt)) then
      !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
      !$OMP SHARED(flwd_que)
      do iflwd = 1, flwd_count
        flwd => flwd_que(iflwd)%flwd
        call cmpt_dt_eu(flwd)
      enddo
      !$OMP END PARALLEL DO

      dt_g = flwd_que(1)%flwd%info%dt
      do iflwd = 2, flwd_count
        flwd => flwd_que(iflwd)%flwd
        dt_g = min(dt_g,flwd%info%dt)
      enddo
      dt_g = cfl*dt_g

      !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
      !$OMP SHARED(flwd_que)
      do iflwd = 1, flwd_count
        flwd => flwd_que(iflwd)%flwd
        flwd%info%dt = dt_g
      enddo
      !$OMP END PARALLEL DO
    endif

    !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
    !$OMP SHARED(flwd_que)
    do iflwd = 1, flwd_count
      flwd => flwd_que(iflwd)%flwd
      call evlv_mdl_eu(flwd, time_integrator_idx)
    enddo
    !$OMP END PARALLEL DO

    istage = istage + 1
  enddo

  istep = istep + 1
  time  = time + dt_g
  elasp_time  = elasp_time + dt_g

  !$OMP PARALLEL DO PRIVATE(iflwd,flwd) &
  !$OMP SHARED(flwd_que)
  do iflwd = 1, flwd_count
    flwd => flwd_que(iflwd)%flwd
    flwd%info%time = time
  enddo
  !$OMP END PARALLEL DO
end subroutine evolve_model_eu

subroutine print_status_model_eu(istep,time)
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time

  write(*,*) "======== istep = ",istep,"time = ",time,"=========="
  write(*,*) "dt = ", dt_g
  write(*,*) 'max eigen value xi', max_eig_xi_g
  write(*,*) 'max eigen value eta', max_eig_eta_g

end subroutine print_status_model_eu

subroutine write_model_eu(istep,time)
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time
  type(eu_data_list_t),pointer :: flwd_node

  type(eu_data_t),pointer      :: flwd
  type(block_t),pointer        :: blk
  type(block_data_t),pointer   :: d_blk
  type(eu_info_data_t),pointer :: info
  type(rvectorfield_t),pointer :: prim
  type(rvectorfield_t),pointer :: cons

  type(eu_data_t),pointer      :: flwd_tile
  type(block_t),pointer        :: blk_tile
  type(block_data_t),pointer   :: d_blk_tile
  type(eu_info_data_t),pointer :: info_tile
  type(rvectorfield_t),pointer :: prim_tile
  type(rvectorfield_t),pointer :: cons_tile

  character(len=32) :: sstep,stime
  character(len=1024) :: varnamelist
  character(len=1024) :: header
  integer :: funit = 11
  integer :: iflwd,nvars
  integer :: isize,jsize,ibf,jbf
  integer :: i,j
  integer :: i0,j0
  integer :: itile,jtile

  type(fscalarshape_t) :: lo_int, hi_int

  ! Compute current primative variables for all tiles
  do iflwd = 1, flwd_count
    flwd => flwd_que(iflwd)%flwd
    info => flwd%info
    prim => flwd%prim
    cons => flwd%cons(info%stage_num)

    isize   = info%isize
    jsize   = info%jsize
    ibf     = info%ibf
    jbf     = info%jbf

    lo_int = set_shape(1+ibf,1+jbf)
    hi_int = set_shape(isize+ibf,jsize+jbf)
    call cmpt_cons2prim_range(prim, cons, lo_int, hi_int, info)
  enddo

  flwd_node => base_flwd_list
  do while(associated(flwd_node))
    flwd => flwd_node%flwd
    blk  => flwd%blk
    prim => flwd%prim
    do jtile = 1, blk%tile_dim(2)
      do itile = 1, blk%tile_dim(1)
        flwd_tile => flwd%tiles(itile,jtile)
        blk_tile  => flwd_tile%blk
        info_tile => flwd_tile%info

        prim_tile => flwd_tile%prim

        isize   = info_tile%isize
        jsize   = info_tile%jsize
        ibf     = info_tile%ibf
        jbf     = info_tile%jbf

        do j = 0, jsize - 1
          do i = 0, isize - 1
            i0 = blk_tile%p_ilo + i
            j0 = blk_tile%p_jlo + j
            prim%p(:,i0,j0) = prim_tile%p(:,ibf + i+1,jbf + j+1)
          enddo
        enddo
      enddo
    enddo
    flwd_node => flwd_node%next
  enddo

  if(file_fmt.eq.'tec') then
    call write_model_tec_eu(istep,time)
  else if(file_fmt.eq.'hdf') then
    call write_model_hdf5_eu(istep,time)
  else
    print*,'No such File Format:',file_fmt
  endif
end subroutine write_model_eu

subroutine write_model_tec_eu(istep,time)
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time
  type(eu_data_list_t),pointer :: flwd_node

  type(eu_data_t),pointer      :: flwd
  type(block_t),pointer        :: blk
  type(block_data_t),pointer   :: d_blk
  type(eu_info_data_t),pointer :: info
  type(rvectorfield_t),pointer :: prim
  type(rvectorfield_t),pointer :: cons

  type(eu_data_t),pointer      :: flwd_tile
  type(block_t),pointer        :: blk_tile
  type(block_data_t),pointer   :: d_blk_tile
  type(eu_info_data_t),pointer :: info_tile
  type(rvectorfield_t),pointer :: prim_tile
  type(rvectorfield_t),pointer :: cons_tile

  character(len=32) :: sstep,stime
  character(len=1024) :: varnamelist
  character(len=1024) :: header
  integer :: funit = 11
  integer :: iflwd,nvars
  integer :: isize,jsize,ibf,jbf
  integer :: i,j
  integer :: i0,j0
  integer :: itile,jtile

  type(fscalarshape_t) :: lo_int, hi_int

  write(sstep,'(i16)') istep
  write(stime,'(f12.6)') time
  open(funit,file="DMPeu_"//trim(adjustl(sstep))//"_"//trim(adjustl(stime))//".tec",form='formatted')

  flwd_node => base_flwd_list
  do while(associated(flwd_node))
    flwd => flwd_node%flwd
    info => flwd%info
    blk  => flwd%blk
    write(funit,*)'title=','"flow time ',time,'"'
    varnamelist = ""
    call get_varnamelist(varnamelist)
    header = 'variables="x","y"'//trim(adjustl(varnamelist))
    write(funit,*) header
    header = "DATAPACKING=BLOCK, VARLOCATION=([3-8]=CELLCENTERED)"

    write(funit,*) 'ZONE I=',info%isize+1, &
                    ' J=',info%jsize+1, &
                    trim(adjustl(header))
    call get_numvars(nvars)
    call blk%write_block_ascii(funit)
    call flwd%write_data_fmt(funit)
    flwd_node => flwd_node%next
  enddo
  close(funit)
end subroutine write_model_tec_eu

subroutine write_model_hdf5_eu(istep,time)
  use HDF5
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time
  type(eu_data_list_t),pointer :: flwd_node

  type(eu_data_t),pointer      :: flwd
  type(block_t),pointer        :: blk
  type(block_data_t),pointer   :: d_blk
  type(eu_info_data_t),pointer :: info
  type(rvectorfield_t),pointer :: prim
  type(rvectorfield_t),pointer :: cons

  character(len=32) :: sstep,stime
  character(len=1024) :: varnamelist
  character(len=1024) :: header
  integer :: iflwd,nvars
  integer :: isize,jsize,ibf,jbf
  integer :: i,j
  integer :: i0,j0
  integer :: itile,jtile

  type(fscalarshape_t) :: lo_int, hi_int

  flwd_node => base_flwd_list
  do while(associated(flwd_node))
    flwd => flwd_node%flwd
    info => flwd%info
    blk  => flwd%blk
    write(funit,*)'title=','"flow time ',time,'"'
    varnamelist = ""
    call get_varnamelist(varnamelist)
    header = 'variables="x","y"'//trim(adjustl(varnamelist))
    write(funit,*) header
    header = "DATAPACKING=BLOCK, VARLOCATION=([3-8]=CELLCENTERED)"

    write(funit,*) 'ZONE I=',info%isize+1, &
                    ' J=',info%jsize+1, &
                    trim(adjustl(header))
    call get_numvars(nvars)
    call blk%write_block_ascii(funit)
    call flwd%write_data_hdf5(funit)
    flwd_node => flwd_node%next
  enddo
end subroutine write_model_hdf5_eu

subroutine save_model_eu(istep,time)
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time
  character(len=32) :: sstep,stime
  integer :: funit = 11
  integer :: iflwd
  type(fscalarshape_t) :: lo_int, hi_int

end subroutine save_model_eu

subroutine load_model_eu(istep,time)
  implicit none
  integer,intent(in) :: istep
  double precision,intent(in) :: time
  character(len=32) :: sstep,stime
  character(len=1024) :: varnamelist
  character(len=1024) :: header
  integer :: funit = 11
  integer :: iflwd,nvars
  type(fscalarshape_t) :: lo_int, hi_int

end subroutine load_model_eu

subroutine destroy_model_eu()
  implicit none
  integer :: iflwd
  deallocate(base_flwd_list)
  deallocate(flwd_que)
  call destroy_mesh()
end subroutine destroy_model_eu

function add_flwd_to_model() result(flwd_node)
  implicit none
  class(eu_data_list_t),pointer :: flwd_node
  allocate(flwd_node)
  allocate(flwd_node%flwd)
  flwd_node%prev  => null()
  flwd_node%next => null()
  if(.not.associated(base_flwd_list)) then
    base_flwd_list      => flwd_node
    base_flwd_list_tail => base_flwd_list
  else
    base_flwd_list_tail%next => flwd_node
    flwd_node%prev           => base_flwd_list_tail
    base_flwd_list_tail      => flwd_node
  endif
end function add_flwd_to_model

subroutine map_flwd_to_base_mesh()
  implicit none
  class(eu_data_list_t),pointer :: flwd_node
  class(block_list_t),pointer   :: blk_node
  class(block_t),pointer        :: blk
  class(eu_data_t),pointer      :: flwd
  integer :: itile,jtile
  integer :: iblk

  blk_node => base_blk_list
  do while(associated(blk_node))
    blk       => blk_node%blk
    flwd_node => add_flwd_to_model()
    flwd      => flwd_node%flwd
    call flwd%config_eu(max_stage,blk)
    call flwd%create_eu()

    blk_node => blk_node%next
  enddo
end subroutine map_flwd_to_base_mesh

subroutine create_work_que()
  use omp_lib
  implicit none
  class(eu_data_list_t),pointer               :: flwd_node
  class(block_t),pointer                      :: blk
  class(eu_data_t),pointer                    :: flwd
  class(block_t),pointer                      :: blk_tile
  class(eu_data_t),pointer                    :: flwd_tile
  integer :: itile,jtile
  integer :: max_num_threads

  call partision_mesh()
  call map_flwd_to_base_mesh()
  flwd_count = blk_count
  if(allocated(flwd_que)) deallocate(flwd_que)
  allocate(flwd_que(flwd_count))

  flwd_node => base_flwd_list
  do while(associated(flwd_node))
    flwd      => flwd_node%flwd
    blk       => flwd%blk
    if(blk%partisioned) then
      if(associated(flwd%tiles)) deallocate(flwd%tiles)
      allocate(flwd%tiles(blk%tile_dim(1),blk%tile_dim(2)))
      do jtile = 1, blk%tile_dim(2)
        do itile = 1, blk%tile_dim(1)
          blk_tile  => blk%tiles(itile,jtile)
          flwd_tile => flwd%tiles(itile,jtile)
          call flwd_tile%config_eu(max_stage,blk_tile)
          call flwd_tile%create_eu()
          flwd_tile%parent            => flwd
          flwd_que(blk_tile%idx)%flwd => flwd_tile
        enddo
      enddo
    endif
    flwd_node => flwd_node%next
  enddo
  print*,"Work flow has been created:",blk_count,"tiles in total."
  max_num_threads = omp_get_max_threads()
  call omp_set_num_threads(min(max_num_threads,blk_count))
  max_num_threads = omp_get_max_threads()
  print*,"Using ",max_num_threads,"threads."
end subroutine create_work_que

! ! Shock Shear layer
! subroutine initial_model_eu_ss(funit)
!   implicit none
!   integer,intent(in) :: funit
!   integer,parameter :: blk_num = 1

!   type(eu_data_t), pointer     :: flwd
!   type(block_t), pointer       :: blk
!   type(eu_info_data_t),pointer :: info
!   type(rvectorfield_t),pointer :: prim
!   type(rvectorfield_t),pointer :: cons
!   type(blk_bndy_t), pointer    :: bndy
!   type(eu_bc_data_t), pointer  :: bc
!   type(ivector_t), pointer     :: bc_info

!   integer :: i,j,iblk,bc_num
!   integer :: i0,j0
!   double precision :: xc0,yc0,rc0
!   double precision :: rho0,u0,v0,p0,ei0
!   double precision,parameter :: pie = 4.d0*atan(1.d0)

!   ! initial mesh data
!   call create_mesh(blk_num,mesh_type_cart)
!   call allocate_block(blks(blk_num),blk_num,   &
!                       isize_plane,jsize_plane, &
!                       ibf_plane,jbf_plane)

!   do iblk = 1, nblk
!     call init_cart_blk(blks(iblk),x0,y0,xl,yl)
!   enddo

!   call cmpt_metrics_cart()

!   blks(1)%nbndy = 4
!   allocate(blks(1)%bndys(blks(1)%nbndy))
!   ! boundary conditions
!   ! left boundary
!   bndy => blks(1)%bndys(1)
!   bndy%idx    = 1

!   bndy%ilo(1)  = 1
!   bndy%ihi(1)  = ibf_plane
!   bndy%jlo(1)  = jbf_plane + 1
!   bndy%jhi(1)  = jbf_plane + jsize_plane

!   bndy%bc_num = 1
!   allocate(bndy%bc_infos(bndy%bc_num))
!   bc_info => bndy%bc_infos(1)
!   call create(bc_info,2)
!   bc_info%p(1) = ssl_bc_idx
!   bc_info%p(2) = inlt1_ssl_idx

!   ! bottom boundary
!   bndy => blks(1)%bndys(2)
!   bndy%idx    = 2

!   bndy%ilo(1) = ibf_plane + 1
!   bndy%ihi(1) = ibf_plane + isize_plane
!   bndy%jlo(1) = 1
!   bndy%jhi(1) = jbf_plane

!   bndy%ilo(2) = ibf_plane + 1
!   bndy%ihi(2) = ibf_plane + isize_plane
!   bndy%jlo(2) = jbf_plane + jbf_plane
!   bndy%jhi(2) = jbf_plane + 1

!   bndy%bc_num = 1
!   allocate(bndy%bc_infos(bndy%bc_num))
!   bc_info => bndy%bc_infos(1)
!   call create(bc_info,2)
!   bc_info%p(1) = ssl_bc_idx
!   bc_info%p(2) = rflt2_ssl_idx

!   ! right boundary
!   bndy => blks(1)%bndys(3)
!   bndy%idx    = 3

!   bndy%ilo(1)  = isize_plane + ibf_plane + 1
!   bndy%ihi(1)  = isize_plane + ibf_plane + ibf_plane
!   bndy%jlo(1)  = jbf_plane + 1
!   bndy%jhi(1)  = jbf_plane + jsize_plane

!   bndy%bc_num = 1
!   allocate(bndy%bc_infos(bndy%bc_num))
!   bc_info => bndy%bc_infos(1)
!   call create(bc_info,3)
!   bc_info%p(1) = ssl_bc_idx
!   bc_info%p(2) = otlt3_ssl_idx
!   bc_info%p(3) = axis_xi

!   ! top boundary
!   bndy => blks(1)%bndys(4)
!   bndy%idx    = 4

!   bndy%ilo(1)  = ibf_plane + 1
!   bndy%ihi(1)  = ibf_plane + isize_plane
!   bndy%jlo(1)  = jsize_plane + jbf_plane + 1
!   bndy%jhi(1)  = jsize_plane + jbf_plane + jbf_plane

!   bndy%bc_num = 1
!   allocate(bndy%bc_infos(bndy%bc_num))
!   bc_info => bndy%bc_infos(1)
!   call create(bc_info,2)
!   bc_info%p(1) = ssl_bc_idx
!   bc_info%p(2) = inlt4_ssl_idx

!   ! partiiton mesh for parallel computation
!   call mesh_partition()

!   ! initial model data
!   allocate(flwd_que(1))
!   call flwd_que(1)%config_eu(max_stage, blks(1))
!   call flwd_que(1)%create_eu
!   flwd => flwd_que(1)
!   blk  => flwd%blk
!   info => flwd%info
!   cons => flwd%cons(max_stage)

!   ! Setup boundary condition 2 data
!   bc => flwd%bcs(2)
!   bc%vs_num = 1
!   allocate(bc%vs(bc%vs_num))
!   call create(bc%vs(1), 4)
!   bc%vs(1)%p(:) = 1.d0
!   bc%vs(1)%p(3) =-1.d0

!   ! Setup boundary condition 3 data
!   bc => flwd%bcs(3)
!   bc%vs_num = 1
!   allocate(bc%vs(bc%vs_num))
!   call create(bc%vs(1), 4)
!   bc%vs(1)%p(:) = 0.d0

!   info%gamma = gamma
!   do j=1,info%jsize
!     do i=1,info%isize
!       i0 = i + info%ibf
!       j0 = j + info%jbf

!       xc0 = blk%xc%p(i0,j0)
!       yc0 = blk%yc%p(i0,j0)

!       if(yc0.ge.0) then
!         rho0 = 1.6374d0
!         u0   = 3.d0
!         v0   = 0.d0
!         p0   = 0.3327d0
!       else
!         rho0 = 0.3626d0
!         u0   = 2.d0
!         v0   = 0.d0
!         p0   = 0.3327d0
!       endif
!       ei0  = p0/(rho0*(gamma-1.d0))

!       cons%p(1,i0,j0) = rho0
!       cons%p(2,i0,j0) = rho0*u0
!       cons%p(3,i0,j0) = rho0*v0
!       cons%p(4,i0,j0) = rho0*(ei0+0.5d0*(u0**2+v0**2))
!     enddo
!   enddo
!   info%eig_xi  = 0.d0
!   info%eig_eta = 0.d0
!   info%time    = 0.d0
! end subroutine initial_model_eu_ss

subroutine get_varnamelist(varnamelist)
  implicit none
  character(len=*),intent(inout) :: varnamelist
  integer :: n,iphase
  character(len=16),dimension(8) :: svarname
  character(len=8)  :: svarindex

  svarname(1) = ',"rho"'
  svarname(2) = ',"u"'
  svarname(3) = ',"v"'
  svarname(4) = ',"p"'
  svarname(5) = ',"c"'
  svarname(6) = ',"t"'

  do n=1, 6
    varnamelist = trim(adjustl(varnamelist))//trim(adjustl(svarname(n)))
  enddo

end subroutine get_varnamelist

subroutine get_numvars(nvars)
  implicit none
  integer,intent(inout) :: nvars
  nvars = 6
end subroutine get_numvars

end module


text:
program t
  if (.true.) then
    print *,'ok'
    stop
  end if
  print *,'bad'
end program t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
! This file was automatically generated by SWIG (http://www.swig.org).
! Version 4.0.0
!
! Do not make changes to this file unless you know what you are doing--modify
! the SWIG interface file instead.
module fnvector_mod
 use, intrinsic :: ISO_C_BINDING
 use fsundials_types_mod
 implicit none
 private

 ! DECLARATION CONSTRUCTS
 ! typedef enum N_Vector_ID
 enum, bind(c)
  enumerator :: SUNDIALS_NVEC_SERIAL
  enumerator :: SUNDIALS_NVEC_PARALLEL
  enumerator :: SUNDIALS_NVEC_OPENMP
  enumerator :: SUNDIALS_NVEC_PTHREADS
  enumerator :: SUNDIALS_NVEC_PARHYP
  enumerator :: SUNDIALS_NVEC_PETSC
  enumerator :: SUNDIALS_NVEC_CUDA
  enumerator :: SUNDIALS_NVEC_RAJA
  enumerator :: SUNDIALS_NVEC_OPENMPDEV
  enumerator :: SUNDIALS_NVEC_TRILINOS
  enumerator :: SUNDIALS_NVEC_CUSTOM
 end enum
 integer, parameter, public :: N_Vector_ID = kind(SUNDIALS_NVEC_SERIAL)
 public :: SUNDIALS_NVEC_SERIAL, SUNDIALS_NVEC_PARALLEL, SUNDIALS_NVEC_OPENMP, SUNDIALS_NVEC_PTHREADS, SUNDIALS_NVEC_PARHYP, &
    SUNDIALS_NVEC_PETSC, SUNDIALS_NVEC_CUDA, SUNDIALS_NVEC_RAJA, SUNDIALS_NVEC_OPENMPDEV, SUNDIALS_NVEC_TRILINOS, &
    SUNDIALS_NVEC_CUSTOM
 public :: FN_VGetVectorID
 public :: FN_VClone
 public :: FN_VCloneEmpty
 public :: FN_VDestroy
 public :: FN_VSpace
 public :: FN_VGetArrayPointer
 public :: FN_VSetArrayPointer
 public :: FN_VLinearSum
 public :: FN_VConst
 public :: FN_VProd
 public :: FN_VDiv
 public :: FN_VScale
 public :: FN_VAbs
 public :: FN_VInv
 public :: FN_VAddConst
 public :: FN_VDotProd
 public :: FN_VMaxNorm
 public :: FN_VWrmsNorm
 public :: FN_VWrmsNormMask
 public :: FN_VMin
 public :: FN_VWL2Norm
 public :: FN_VL1Norm
 public :: FN_VCompare
 public :: FN_VInvTest
 public :: FN_VConstrMask
 public :: FN_VMinQuotient
 public :: FN_VLinearCombination
 public :: FN_VScaleAddMulti
 public :: FN_VDotProdMulti
 public :: FN_VLinearSumVectorArray
 public :: FN_VScaleVectorArray
 public :: FN_VConstVectorArray
 public :: FN_VWrmsNormVectorArray
 public :: FN_VWrmsNormMaskVectorArray
 public :: FN_VScaleAddMultiVectorArray
 public :: FN_VLinearCombinationVectorArray
 public :: FN_VCloneEmptyVectorArray
 public :: FN_VCloneVectorArray
 public :: FN_VDestroyVectorArray

! WRAPPER DECLARATIONS
interface
function FN_VGetVectorID(w) &
bind(C, name="N_VGetVectorID") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: w
integer(C_INT) :: fresult
end function

function FN_VClone(w) &
bind(C, name="N_VClone") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: w
type(C_PTR) :: fresult
end function

function FN_VCloneEmpty(w) &
bind(C, name="N_VCloneEmpty") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: w
type(C_PTR) :: fresult
end function

subroutine FN_VDestroy(v) &
bind(C, name="N_VDestroy")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: v
end subroutine

subroutine FN_VSpace(v, lrw, liw) &
bind(C, name="N_VSpace")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: v
integer(C_INT64_T) :: lrw
integer(C_INT64_T) :: liw
end subroutine

function FN_VGetArrayPointer(v) &
bind(C, name="N_VGetArrayPointer") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: v
type(C_PTR) :: fresult
end function

subroutine FN_VSetArrayPointer(v_data, v) &
bind(C, name="N_VSetArrayPointer")
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE) :: v_data
type(C_PTR), value :: v
end subroutine

subroutine FN_VLinearSum(a, x, b, y, z) &
bind(C, name="N_VLinearSum")
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), value :: a
type(C_PTR), value :: x
real(C_DOUBLE), value :: b
type(C_PTR), value :: y
type(C_PTR), value :: z
end subroutine

subroutine FN_VConst(c, z) &
bind(C, name="N_VConst")
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), value :: c
type(C_PTR), value :: z
end subroutine

subroutine FN_VProd(x, y, z) &
bind(C, name="N_VProd")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: y
type(C_PTR), value :: z
end subroutine

subroutine FN_VDiv(x, y, z) &
bind(C, name="N_VDiv")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: y
type(C_PTR), value :: z
end subroutine

subroutine FN_VScale(c, x, z) &
bind(C, name="N_VScale")
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), value :: c
type(C_PTR), value :: x
type(C_PTR), value :: z
end subroutine

subroutine FN_VAbs(x, z) &
bind(C, name="N_VAbs")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: z
end subroutine

subroutine FN_VInv(x, z) &
bind(C, name="N_VInv")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: z
end subroutine

subroutine FN_VAddConst(x, b, z) &
bind(C, name="N_VAddConst")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
real(C_DOUBLE), value :: b
type(C_PTR), value :: z
end subroutine

function FN_VDotProd(x, y) &
bind(C, name="N_VDotProd") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: y
real(C_DOUBLE) :: fresult
end function

function FN_VMaxNorm(x) &
bind(C, name="N_VMaxNorm") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
real(C_DOUBLE) :: fresult
end function

function FN_VWrmsNorm(x, w) &
bind(C, name="N_VWrmsNorm") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: w
real(C_DOUBLE) :: fresult
end function

function FN_VWrmsNormMask(x, w, id) &
bind(C, name="N_VWrmsNormMask") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: w
type(C_PTR), value :: id
real(C_DOUBLE) :: fresult
end function

function FN_VMin(x) &
bind(C, name="N_VMin") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
real(C_DOUBLE) :: fresult
end function

function FN_VWL2Norm(x, w) &
bind(C, name="N_VWL2Norm") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: w
real(C_DOUBLE) :: fresult
end function

function FN_VL1Norm(x) &
bind(C, name="N_VL1Norm") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
real(C_DOUBLE) :: fresult
end function

subroutine FN_VCompare(c, x, z) &
bind(C, name="N_VCompare")
use, intrinsic :: ISO_C_BINDING
real(C_DOUBLE), value :: c
type(C_PTR), value :: x
type(C_PTR), value :: z
end subroutine

function FN_VInvTest(x, z) &
bind(C, name="N_VInvTest") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: x
type(C_PTR), value :: z
logical(C_BOOL) :: fresult
end function

function FN_VConstrMask(c, x, m) &
bind(C, name="N_VConstrMask") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: c
type(C_PTR), value :: x
type(C_PTR), value :: m
logical(C_BOOL) :: fresult
end function

function FN_VMinQuotient(num, denom) &
bind(C, name="N_VMinQuotient") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: num
type(C_PTR), value :: denom
real(C_DOUBLE) :: fresult
end function

function FN_VLinearCombination(nvec, c, x, z) &
bind(C, name="N_VLinearCombination") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
real(C_DOUBLE) :: c
type(C_PTR), value :: x
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VScaleAddMulti(nvec, a, x, y, z) &
bind(C, name="N_VScaleAddMulti") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
real(C_DOUBLE) :: a
type(C_PTR), value :: x
type(C_PTR), value :: y
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VDotProdMulti(nvec, x, y, dotprods) &
bind(C, name="N_VDotProdMulti") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
type(C_PTR), value :: x
type(C_PTR), value :: y
real(C_DOUBLE) :: dotprods
integer(C_INT) :: fresult
end function

function FN_VLinearSumVectorArray(nvec, a, x, b, y, z) &
bind(C, name="N_VLinearSumVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
real(C_DOUBLE), value :: a
type(C_PTR), value :: x
real(C_DOUBLE), value :: b
type(C_PTR), value :: y
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VScaleVectorArray(nvec, c, x, z) &
bind(C, name="N_VScaleVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
real(C_DOUBLE) :: c
type(C_PTR), value :: x
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VConstVectorArray(nvec, c, z) &
bind(C, name="N_VConstVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
real(C_DOUBLE), value :: c
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VWrmsNormVectorArray(nvec, x, w, nrm) &
bind(C, name="N_VWrmsNormVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
type(C_PTR), value :: x
type(C_PTR), value :: w
real(C_DOUBLE) :: nrm
integer(C_INT) :: fresult
end function

function FN_VWrmsNormMaskVectorArray(nvec, x, w, id, nrm) &
bind(C, name="N_VWrmsNormMaskVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
type(C_PTR), value :: x
type(C_PTR), value :: w
type(C_PTR), value :: id
real(C_DOUBLE) :: nrm
integer(C_INT) :: fresult
end function

function FN_VScaleAddMultiVectorArray(nvec, nsum, a, x, y, z) &
bind(C, name="N_VScaleAddMultiVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
integer(C_INT), value :: nsum
real(C_DOUBLE) :: a
type(C_PTR), value :: x
type(C_PTR), value :: y
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VLinearCombinationVectorArray(nvec, nsum, c, x, z) &
bind(C, name="N_VLinearCombinationVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: nvec
integer(C_INT), value :: nsum
real(C_DOUBLE) :: c
type(C_PTR), value :: x
type(C_PTR), value :: z
integer(C_INT) :: fresult
end function

function FN_VCloneEmptyVectorArray(count, w) &
bind(C, name="N_VCloneEmptyVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: count
type(C_PTR), value :: w
type(C_PTR) :: fresult
end function

function FN_VCloneVectorArray(count, w) &
bind(C, name="N_VCloneVectorArray") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
integer(C_INT), value :: count
type(C_PTR), value :: w
type(C_PTR) :: fresult
end function

subroutine FN_VDestroyVectorArray(vs, count) &
bind(C, name="N_VDestroyVectorArray")
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: vs
integer(C_INT), value :: count
end subroutine

end interface

end module

max_stars_repo_name: ghweber/amrex

max_issues_repo_name: ghweber/amrex

max_forks_repo_name: ghweber/amrex


text:
      subroutine dummy()
      integer i
      end

max_stars_repo_name: MikeBMW/CarND-MPC-Project

max_issues_repo_name: WatsonZhouAnda/Cheetah-Software

max_forks_repo_name: WatsonZhouAnda/Cheetah-Software


text:
! This test checks lowering of OpenACC exit data directive.

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

subroutine acc_exit_data
  integer :: async = 1
  real, dimension(10, 10) :: a, b, c
  real, pointer :: d
  logical :: ifCondition = .TRUE.

!CHECK: [[A:%.*]] = fir.alloca !fir.array<10x10xf32> {{{.*}}uniq_name = "{{.*}}Ea"}
!CHECK: [[B:%.*]] = fir.alloca !fir.array<10x10xf32> {{{.*}}uniq_name = "{{.*}}Eb"}
!CHECK: [[C:%.*]] = fir.alloca !fir.array<10x10xf32> {{{.*}}uniq_name = "{{.*}}Ec"}
!CHECK: [[D:%.*]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = "d", uniq_name = "{{.*}}Ed"}

  !$acc exit data delete(a)
!CHECK: acc.exit_data delete([[A]] : !fir.ref<!fir.array<10x10xf32>>){{$}}

  !$acc exit data delete(a) if(.true.)
!CHECK: [[IF1:%.*]] = arith.constant true
!CHECK: acc.exit_data if([[IF1]]) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>){{$}}

  !$acc exit data delete(a) if(ifCondition)
!CHECK: [[IFCOND:%.*]] = fir.load %{{.*}} : !fir.ref<!fir.logical<4>>
!CHECK: [[IF2:%.*]] = fir.convert [[IFCOND]] : (!fir.logical<4>) -> i1
!CHECK: acc.exit_data if([[IF2]]) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>){{$}}

  !$acc exit data delete(a) delete(b) delete(c)
!CHECK: acc.exit_data delete([[A]], [[B]], [[C]] : !fir.ref<!fir.array<10x10xf32>>, !fir.ref<!fir.array<10x10xf32>>, !fir.ref<!fir.array<10x10xf32>>){{$}}

  !$acc exit data copyout(a) delete(b) detach(d)
!CHECK: acc.exit_data copyout([[A]] : !fir.ref<!fir.array<10x10xf32>>) delete([[B]] : !fir.ref<!fir.array<10x10xf32>>) detach([[D]] : !fir.ref<!fir.box<!fir.ptr<f32>>>){{$}}

  !$acc exit data delete(a) async
!CHECK: acc.exit_data delete([[A]] : !fir.ref<!fir.array<10x10xf32>>) attributes {async}

  !$acc exit data delete(a) wait
!CHECK: acc.exit_data delete([[A]] : !fir.ref<!fir.array<10x10xf32>>) attributes {wait}

  !$acc exit data delete(a) async wait
!CHECK: acc.exit_data delete([[A]] : !fir.ref<!fir.array<10x10xf32>>) attributes {async, wait}

  !$acc exit data delete(a) async(1)
!CHECK: [[ASYNC1:%.*]] = arith.constant 1 : i32
!CHECK: acc.exit_data async([[ASYNC1]] : i32) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>)

  !$acc exit data delete(a) async(async)
!CHECK: [[ASYNC2:%.*]] = fir.load %{{.*}} : !fir.ref<i32>
!CHECK: acc.exit_data async([[ASYNC2]] : i32) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>)

  !$acc exit data delete(a) wait(1)
!CHECK: [[WAIT1:%.*]] = arith.constant 1 : i32
!CHECK: acc.exit_data wait([[WAIT1]] : i32) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>)

  !$acc exit data delete(a) wait(queues: 1, 2)
!CHECK: [[WAIT2:%.*]] = arith.constant 1 : i32
!CHECK: [[WAIT3:%.*]] = arith.constant 2 : i32
!CHECK: acc.exit_data wait([[WAIT2]], [[WAIT3]] : i32, i32) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>)

  !$acc exit data delete(a) wait(devnum: 1: queues: 1, 2)
!CHECK: [[WAIT4:%.*]] = arith.constant 1 : i32
!CHECK: [[WAIT5:%.*]] = arith.constant 2 : i32
!CHECK: [[WAIT6:%.*]] = arith.constant 1 : i32
!CHECK: acc.exit_data wait_devnum([[WAIT6]] : i32) wait([[WAIT4]], [[WAIT5]] : i32, i32) delete([[A]] : !fir.ref<!fir.array<10x10xf32>>)

end subroutine acc_exit_data

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


text:
      module def_vitals_gettrk
        type tcvcard         ! Define a new type for a TC Vitals card
          sequence
          character*4   tcv_center      ! Hurricane Center Acronym
          character*3   tcv_storm_id    ! Storm Identifier (03L, etc)
          character*9   tcv_storm_name  ! Storm name
          integer       tcv_century     ! 2-digit century id (19 or 20)
          integer       tcv_yymmdd      ! Date of observation
          integer       tcv_hhmm        ! Time of observation (UTC)
          integer       tcv_lat         ! Storm Lat (*10), always >0
          character*1   tcv_latns       ! 'N' or 'S'
          integer       tcv_lon         ! Storm Lon (*10), always >0
          character*1   tcv_lonew       ! 'E' or 'W'
          integer       tcv_stdir       ! Storm motion vector (in degr)
          integer       tcv_stspd       ! Spd of storm movement (m/s*10)
          integer       tcv_pcen        ! Min central pressure (mb)
          integer       tcv_penv        ! val outrmost closed isobar(mb)
          integer       tcv_penvrad     ! rad outrmost closed isobar(km)
          integer       tcv_vmax        ! max sfc wind speed (m/s)
          integer       tcv_vmaxrad     ! rad of max sfc wind spd (km)
          integer       tcv_r15ne       ! NE rad of 15 m/s winds (km)
          integer       tcv_r15se       ! SE rad of 15 m/s winds (km)
          integer       tcv_r15sw       ! SW rad of 15 m/s winds (km)
          integer       tcv_r15nw       ! NW rad of 15 m/s winds (km)
          character*1   tcv_depth       ! Storm depth (S,M,D) X=missing
        end type tcvcard
        type (tcvcard), save, allocatable :: storm(:)
        integer, save, allocatable :: stormswitch(:)
        real, save, allocatable    :: slonfg(:,:),slatfg(:,:)
        character*3, save, allocatable :: stcvtype(:) ! FOF or TCV
      end module def_vitals_gettrk
c
      module inparms_gettrk
        type datecard  ! Define a new type for the input namelist parms
          sequence
          integer       bcc    ! First 2 chars of yy of date (century)
          integer       byy    ! Beginning yy of date to search for
          integer       bmm    ! Beginning mm of date to search for
          integer       bdd    ! Beginning dd of date to search for
          integer       bhh    ! Beginning hh of date to search for
          integer       model  ! integer identifier for model data used
        end type datecard
      end module inparms_gettrk
c
      module trkrparms
        type trackstuff  ! Define a new type for various tracker parms
          sequence
          real          westbd  ! Western boundary of search area
          real          eastbd  ! Eastern boundary of search area
          real          northbd ! Northern boundary of search area
          real          southbd ! Southern boundary of search area
          character*7   type    ! 'tracker', 'midlat' or 'tcgen'
          real          mslpthresh ! min mslp gradient to be maintained
          real          v850thresh ! min avg 850 Vt to be maintained
          character*8   gridtype ! 'global' or 'regional'
          real          contint  ! Contour interval to be used for
                                 ! "midlat" or "tcgen" cases.
        end type trackstuff
      end module trkrparms
c
      module contours
        integer, parameter :: maxconts=100 ! max # of cont. intervals
        type cint_stuff  ! Define a new type for contour interval info
          sequence
          real    :: xmaxcont ! max contour level in a field
          real    :: xmincont ! min contour level in a field
          real    :: contvals(maxconts) ! contour values in the field
          integer :: numcont  ! # of contour levels in a field
        end type cint_stuff
      end module contours
c
      module atcf
        integer         atcfnum   ! ATCF ID of model (63 for GFDL...)
        character*4     atcfname  ! ATCF Name of model (AVNO for AVN...)
      end module atcf
c
      module tracked_parms
          real, save, allocatable  ::  zeta(:,:,:)
          real, save, allocatable  ::  u(:,:,:)
          real, save, allocatable  ::  v(:,:,:)
          real, save, allocatable  ::  hgt(:,:,:)
          real, save, allocatable  ::  slp(:,:)
      end module tracked_parms
c
      module radii
c       For Barnes smoothing of parameters for tracking, e-folding
c       radius = retrk (km), influence radius = ritrk (km). Max radius
c       for searching for the max vorticity = rads (km).  There is an
c       important distinction between rads and ritrk.  rads is used to
c       determine the maximum distance from the guess position that
c       we'll allow points to be in order to be considered as a
c       candidate location for the updated fix position.  On the other
c       hand, ritrk is used once you're doing the barnes analysis on
c       data for that candidate location, so that if data is not within
c       distance ritrk of the candidate location, we ignore it.  Also,
c       for use in find_maxmin, nhalf = the number of times to halve the
c       spacing of the search grid.  Note that different values are used
c       for the magnitude of the wind than for other parameters; this is
c       so that the search area is restricted in order to avoid a
c       problem of the program finding one wind minimum near the center
c       and another one out near the storm's edge.
c
c       redlm and ridlm = the e-folding radius (km) and influence radius
c       (km) for Barnes analysis of u,v for updating first guess lat,lon
c       for search.  dlm = deep layer mean.
c
c        real, parameter :: retrk_most=60.0, retrk_vmag=60.0
c        real, parameter :: ritrk_most=120.0, ritrk_vmag=120.0
c        real, parameter :: rads_most=120.0, rads_vmag=120.0
c        real, parameter :: retrk_most=150.0, retrk_vmag=60.0
c        real, parameter :: ritrk_most=300.0, ritrk_vmag=120.0
c        real, parameter :: rads_most=300.0, rads_vmag=120.0
        real, parameter :: retrk_most=75.0, retrk_vmag=60.0
        real, parameter :: ritrk_most=150.0, ritrk_vmag=120.0
        real, parameter :: rads_most=300.0, rads_vmag=120.0
        real, parameter :: retrk_coarse=150.0
        real, parameter :: ritrk_coarse=300.0
        real, parameter :: rads_coarse=350.0
c        real, parameter :: redlm=500.0, ridlm=2000.0
        real, parameter :: redlm=500.0, ridlm=1700.0
        integer, parameter :: maxvgrid = 8  ! In find_maxmin, determines
c                    what size grid to send to subroutine  barnes. e.g.,
c                    maxvgrid = 8 means send an 8x8 grid.
        integer, parameter :: nhalf = 5
      end module radii
c
      module grid_bounds
        real, save ::  glatmin, glatmax, glonmin, glonmax  ! These
                       ! define the boundaries of the input data grid
        real, save, allocatable ::  glat(:), glon(:)  ! Will be filled
                       ! with lat/lon values for each pt on input grid
      end module grid_bounds
c
      module error_parms
        real, parameter :: err_avn_init=275.0 ! init errmax for avn,mrf
                                              ! and gdas
        real, parameter :: err_reg_init=300.0 ! init errmax for others
        real, parameter :: err_ecm_max=330.0  ! errmax for ecmwf
        real, parameter :: err_reg_max=225.0  ! errmax for others for
                                              ! remaining fcst times
        real, parameter :: max_mslp_850=323.0 ! Max dist betw mslp &
                                              ! 850 zeta centers
        real, parameter :: maxspeed_tc=60  ! max speed of storm movement
                                           ! for tracker or tcgen cases
        real, parameter :: maxspeed_ml=80  ! max speed of storm movement
                                           ! for midlat cases
C        real, parameter :: errpgro=1.25, errpmax=600.0
        real, parameter :: errpgro=1.25, errpmax=485.0
        real, parameter :: stermn = 0.1   ! Min Std dev for trk errors
        real, parameter :: uverrmax = 225.0  ! For use in get_uv_guess
      end module error_parms
c
      module set_max_parms_gettrk
        integer, parameter :: maxstorm_tc=15  ! max # of storms pgm can
                                           ! handle, for tc tracker case
        integer, parameter :: maxstorm_mg=500  ! max # of storms pgm can
                                      ! handle, for midlat or tcgen case
        integer, parameter :: maxtime=31   ! max # of fcst times pgm
        integer, parameter :: maxtp=9      ! max # of tracked parms
        integer, parameter :: maxmodel=8   ! max # of models currently
                                           ! available
        integer, save :: interval_fhr      ! # of hrs between fcst times
        integer, parameter :: maxcenters=150 ! max # of max/min centers
                                             ! to be tracked.
      end module set_max_parms_gettrk
c
      module level_parms
        integer, parameter :: nlevs=4   ! max # of vert levs to be read
        integer, parameter :: nlevg=3   ! # of vert levs to be used for
                                        ! figuring next guess position
        integer, parameter :: nlevm1=2  ! # tracked levs for hgt & zeta
        integer, parameter :: levsfc=4  ! array position of sfc winds.
        integer, parameter :: nlev850=1 ! array position in u and v
        integer, parameter :: nlev700=2 ! arrays for 850, 700 & 500
        integer, parameter :: nlev500=3 ! winds.  Used in get_uv_center
        real, save      :: wgts(nlevg)  ! Wghts for use in get_next_ges
        data wgts /0.25, 0.50, 0.25/    ! 850, 700 & 500 mb wgts
      end module level_parms
c
      module trig_vals_gettrk
        real, save :: pi, dtr
        real, save :: dtk = 111.1949     ! Dist (km) over 1 deg lat
                                         ! using erad=6371.0e+3
        real, save :: erad = 6371.0e+3   ! Earth's radius (m)
        real, save :: ecircum = 40030.2  ! Earth's circumference
                                         ! (km) using erad=6371.e3
        real, save :: omega = 7.292e-5
      end module trig_vals_gettrk
c
c---------------------------------------------------------------------c
c

max_stars_repo_name: GEOS-ESM/GEOSadas

max_issues_repo_name: GEOS-ESM/GEOSadas

max_forks_repo_name: GEOS-ESM/GEOSadas


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!> \brief
!> This module contains the classes and procedures for setting up the `parallelizationModel` attribute of ParaMonte samplers.
!> For more information, see the description of this attribute in the body of the module.
!> \author Amir Shahmoradi

module SpecBase_ParallelizationModel_mod

    use Constants_mod, only: IK
    implicit none

    character(*), parameter         :: MODULE_NAME = "@SpecBase_ParallelizationModel_mod"

    integer(IK), parameter          :: MAX_LEN_PARALLELIZATION_MODEL = 63

    character(MAX_LEN_PARALLELIZATION_MODEL) :: parallelizationModel

    type                            :: ParallelizationModel_type
        logical                     :: isSinglChain
        logical                     :: isMultiChain
        logical                     :: isForkJoin
        character(10)               :: multiChain
        character(11)               :: singlChain
        character(:), allocatable   :: def
        character(:), allocatable   :: val
        character(:), allocatable   :: null
        character(:), allocatable   :: desc
    contains
        procedure, pass             :: set => setParallelizationModel, checkForSanity, nullifyNameListVar
    end type ParallelizationModel_type

    interface ParallelizationModel_type
        module procedure            :: constructParallelizationModel
    end interface ParallelizationModel_type

    private :: constructParallelizationModel, setParallelizationModel, checkForSanity, nullifyNameListVar

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function constructParallelizationModel(methodName) result(ParallelizationModelObj)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: constructParallelizationModel
#endif
        use, intrinsic :: iso_fortran_env, only: output_unit
        use Constants_mod, only: NULL_SK, IK, PMSM
        use Decoration_mod, only: TAB
        use String_mod, only: num2str
        implicit none
        character(*), intent(in)        :: methodName
        type(ParallelizationModel_type) :: ParallelizationModelObj

        ParallelizationModelObj%isSinglChain = .false.
        ParallelizationModelObj%isMultiChain = .false.
        ParallelizationModelObj%singlChain = "singleChain"
        ParallelizationModelObj%multiChain = "multiChain"
        ParallelizationModelObj%def = ParallelizationModelObj%singlChain
        ParallelizationModelObj%null = repeat(NULL_SK, MAX_LEN_PARALLELIZATION_MODEL)

        ParallelizationModelObj%desc = &
        "parallelizationModel is a string variable that represents the parallelization method to be used in "// methodName //". &
        &The string value must be enclosed by either single or double quotation marks when provided as input. "
        if (methodName==PMSM%ParaDRAM .or. methodName==PMSM%ParaDISE) then
            ParallelizationModelObj%desc = ParallelizationModelObj%desc // &
            "Two options are currently supported:\n\n&
            &    parallelizationModel = '" // ParallelizationModelObj%multiChain // "'\n\n&
            &            This method uses the Prefect Parallelism scheme in which multiple MCMC chains are generated &
                        &independently of each other. In this case, multiple output MCMC chain files will also be generated.\n\n&
            &    parallelizationModel = '" // ParallelizationModelObj%singlChain // "'\n\n&
            &            This method uses the fork-style parallelization scheme. &
                        &A single MCMC chain file will be generated in this case. At each MCMC step multiple proposal steps &
                        &will be checked in parallel until one proposal is accepted.\n\n&
            &Note that in serial mode, there is no parallelism. Therefore, this option does not affect non-parallel simulations &
            &and its value is ignored. The serial mode is equivalent to either of the parallelism methods with only one simulation &
            &image (processor, core, or thread). &
            &The default value is parallelizationModel = '" // ParallelizationModelObj%def // "'. &
            &Note that the input values are case-insensitive and white-space characters are ignored."
        ! LCOV_EXCL_START
        else
            block
                use Err_mod, only: Err_type, abort
                type(Err_type) :: Err
                Err%occurred = .true.
                Err%msg = MODULE_NAME//": Catastrophic internal error occurred. The simulation method name is not recognized."
                call abort(Err)
                error stop
            end block
        ! LCOV_EXCL_STOP
        end if
    end function constructParallelizationModel

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine nullifyNameListVar(ParallelizationModelObj)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: nullifyNameListVar
#endif
        implicit none
        class(ParallelizationModel_type), intent(in) :: ParallelizationModelObj
        parallelizationModel = ParallelizationModelObj%null
    end subroutine nullifyNameListVar

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine setParallelizationModel(ParallelizationModelObj,parallelizationModel)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: setParallelizationModel
#endif
        use String_mod, only: getLowerCase, replaceStr
        implicit none
        class(ParallelizationModel_type), intent(inout) :: ParallelizationModelObj
        character(*), intent(in)                        :: parallelizationModel
        character(:), allocatable                       :: parallelizationModelLowerCase
        ParallelizationModelObj%val = trim(adjustl(replaceStr(parallelizationModel," ", "")))
        if (ParallelizationModelObj%val==trim(adjustl(ParallelizationModelObj%null))) ParallelizationModelObj%val = trim(adjustl(ParallelizationModelObj%def))
        parallelizationModelLowerCase = getLowerCase(ParallelizationModelObj%val)
        ParallelizationModelObj%isSinglChain = parallelizationModelLowerCase == getLowerCase(ParallelizationModelObj%singlChain)
        ParallelizationModelObj%isMultiChain = parallelizationModelLowerCase == getLowerCase(ParallelizationModelObj%multiChain)
    end subroutine setParallelizationModel

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine checkForSanity(ParallelizationModel,Err,methodName)
#if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
        !DEC$ ATTRIBUTES DLLEXPORT :: checkForSanity
#endif
        use Err_mod, only: Err_type
        use String_mod, only: num2str
        implicit none
        class(ParallelizationModel_type), intent(in)    :: ParallelizationModel
        character(*), intent(in)                        :: methodName
        type(Err_type), intent(inout)                   :: Err
        character(*), parameter                         :: PROCEDURE_NAME = "@checkForSanity()"
        if ( .not.(ParallelizationModel%isSinglChain .or. ParallelizationModel%isMultiChain) ) then
        ! LCOV_EXCL_START
            Err%occurred = .true.
            Err%msg =   Err%msg // &
                        MODULE_NAME // PROCEDURE_NAME // ": Error occurred. &
                        &The input requested parallelization method (" // ParallelizationModel%val // &
                        ") represented by variable parallelizationModel cannot be anything other than &
                        &'singleChain' or 'multiChain'. If you don't know an appropriate value &
                        &for ParallelizationModel, drop it from the input list. " // methodName // &
                        " will automatically assign an appropriate value to it.\n\n"
        end if
        ! LCOV_EXCL_STOP
    end subroutine checkForSanity

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module SpecBase_ParallelizationModel_mod ! LCOV_EXCL_LINE

max_stars_repo_name: cdslaborg/paramonte

max_issues_repo_name: cdslaborg/paramonte

max_forks_repo_name: cdslaborg/paramonte