! SPDX-Identifer: MIT
module test_string_intrinsic
    use stdlib_error, only : check
    use stdlib_string_type
    implicit none

contains

    subroutine test_lgt
        type(string_type) :: string
        logical :: res

        string = "bcd"
        res = lgt(string, "abc")
        call check(res .eqv. .true.)

        res = lgt(string, "bcd")
        call check(res .eqv. .false.)

        res = lgt(string, "cde")
        call check(res .eqv. .false.)
    end subroutine test_lgt

    subroutine test_llt
        type(string_type) :: string
        logical :: res

        string = "bcd"
        res = llt(string, "abc")
        call check(res .eqv. .false.)

        res = llt(string, "bcd")
        call check(res .eqv. .false.)

        res = llt(string, "cde")
        call check(res .eqv. .true.)
    end subroutine test_llt

    subroutine test_lge
        type(string_type) :: string
        logical :: res

        string = "bcd"
        res = lge(string, "abc")
        call check(res .eqv. .true.)

        res = lge(string, "bcd")
        call check(res .eqv. .true.)

        res = lge(string, "cde")
        call check(res .eqv. .false.)
    end subroutine test_lge

    subroutine test_lle
        type(string_type) :: string
        logical :: res

        string = "bcd"
        res = lle(string, "abc")
        call check(res .eqv. .false.)

        res = lle(string, "bcd")
        call check(res .eqv. .true.)

        res = lle(string, "cde")
        call check(res .eqv. .true.)
    end subroutine test_lle

    subroutine test_trim
        type(string_type) :: string
        integer :: length

        string = "Some longer sentence for this example."
        length = len_trim(string)
        call check(length == 38)

        string = "Whitespace                            "
        length = len_trim(string)
        call check(length == 10)
    end subroutine test_trim

    subroutine test_len
        type(string_type) :: string
        integer :: length

        string = "Some longer sentence for this example."
        length = len(string)
        call check(length == 38)

        string = "Whitespace                            "
        length = len(string)
        call check(length == 38)
    end subroutine test_len

    subroutine test_len_trim
        type(string_type) :: string
        integer :: length

        string = "Some longer sentence for this example."
        length = len_trim(string)
        call check(length == 38)

        string = "Whitespace                            "
        length = len_trim(string)
        call check(length == 10)
    end subroutine test_len_trim

    subroutine test_adjustl
        type(string_type) :: string

        string = "                            Whitespace"
        string = adjustl(string)
        call check(char(string) == "Whitespace                            ")
    end subroutine test_adjustl

    subroutine test_adjustr
        type(string_type) :: string

        string = "Whitespace                            "
        string = adjustr(string)
        call check(char(string) == "                            Whitespace")
    end subroutine test_adjustr

    subroutine test_scan
        type(string_type) :: string
        integer :: pos

        string = "fortran"
        pos = scan(string, "ao")
        call check(pos == 2)

        pos = scan(string, "ao", .true.)
        call check(pos == 6)

        pos = scan(string, "c++")
        call check(pos == 0)
    end subroutine test_scan

    subroutine test_verify
        type(string_type) :: string
        integer :: pos

        string = "fortran"
        pos = verify(string, "ao")
        call check(pos == 1)

        pos = verify(string, "fo")
        call check(pos == 3)

        pos = verify(string, "c++")
        call check(pos == 1)

        pos = verify(string, "c++", back=.true.)
        call check(pos == 7)

        pos = verify(string, string)
        call check(pos == 0)
    end subroutine test_verify

    subroutine test_repeat
        type(string_type) :: string
        character(len=:), allocatable :: dlc

        string = "What? "
        dlc = repeat(string, 3)
        call check(dlc == "What? What? What? ")
    end subroutine test_repeat

    subroutine test_index
        type(string_type) :: string
        integer :: pos

        string = "Search this string for this expression"
        pos = index(string, "this")
        call check(pos == 8)

        pos = index(string, "this", back=.true.)
        call check(pos == 24)

        pos = index(string, "This")
        call check(pos == 0)
    end subroutine test_index

    subroutine test_char
        type(string_type) :: string
        character(len=:), allocatable :: dlc
        character(len=1), allocatable :: chars(:)

        string = "Character sequence"
        dlc = char(string)
        call check(dlc == "Character sequence")

        dlc = char(string, 3)
        call check(dlc == "a")
        chars = char(string, [3, 5, 8, 12, 14, 15, 18])
        call check(all(chars == ["a", "a", "e", "e", "u", "e", "e"]))

        string = "Fortran"
        dlc = char(string, 1, 4)
        call check(dlc == "Fort")
    end subroutine test_char

    subroutine test_ichar
        type(string_type) :: string
        integer :: code

        string = "Fortran"
        code = ichar(string)
        call check(code == ichar("F"))
    end subroutine test_ichar

    subroutine test_iachar
        type(string_type) :: string
        integer :: code

        string = "Fortran"
        code = iachar(string)
        call check(code == iachar("F"))
    end subroutine test_iachar

end module test_string_intrinsic

program tester
    use test_string_intrinsic
    implicit none

    call test_lgt
    call test_llt
    call test_lge
    call test_lle
    call test_trim
    call test_len
    call test_len_trim
    call test_adjustl
    call test_adjustr
    call test_scan
    call test_verify
    call test_repeat
    call test_index
    call test_char
    call test_ichar
    call test_iachar

end program tester


program main
    use sim
    implicit none

    type(WaterAbsorption_)::seed
    type(FEMDomain_),target :: water,tissue,tissue2,tissue3
    type(MaterialProp_):: Permiability, YoungsModulus,PoissonRatio
    type(MaterialProp_):: density,Cohesion,phi,psi
    type(Boundary_) :: disp_x,disp_y,disp_z
    type(Boundary_) :: traction_x,traction_y,traction_z
    type(Boundary_) :: flux, const

    !  create mesh
    call water%create(Name="water",MeshType="rectangular3D",x_num=20,y_num=10,x_len=300.0d0, y_len=50.0d0,&
        thickness=50.0d0,division=5)
    call tissue%copy(water,onlyMesh=.true.)
    call tissue%rename("tissue")

    ! create material
    ! for deformation analysis
    call YoungsModulus%create(Name="YoungsModulus",ParaValue=12000.0d0,Layer=1)
    call YoungsModulus%create(Name="YoungsModulus",x_max=150.0d0,x_min=0.0d0,y_max=70.0d0,y_min=0.0d0,&
    z_max=70.0d0,z_min=0.0d0,ParaValue=6000.0d0,Layer=1)
    call PoissonRatio%create(Name="PoissonRatio",ParaValue=0.30d0,Layer=2)
    !call PoissonRatio%create(Name="PoissonRatio",x_max=100.0d0,x_min=0.0d0,y_max=50.0d0,y_min=0.0d0,&
    !z_max=50.0d0,z_min=0.0d0,ParaValue=0.10d0,Layer=2)
    call Density%create(Name="Density",ParaValue=0.00d0,Layer=3)
    call Cohesion%create(Name="Cohesion",ParaValue=100000000.0d0,Layer=4)
    call Phi%create(Name="Psi",ParaValue=0.0d0,Layer=5)
    call psi%create(Name="psi",ParaValue=0.0d0,Layer=6)

    ! for diffusion analysis
    call Permiability%create(Name="Permiability",x_max=300.0d0,x_min=100.0d0,y_max=50.0d0,y_min=0.0d0,&
    z_max=50.0d0,z_min=0.0d0,ParaValue=-0.0010d0,Layer=1)
    call Permiability%create(Name="Permiability",x_max=100.0d0,x_min=0.0d0,y_max=50.0d0,y_min=0.0d0,&
    z_max=50.0d0,z_min=0.0d0,ParaValue=-0.000010d0,Layer=1)

    ! import Materials onto FEMDomains
    call tissue%import(Materials=.true., Material=YoungsModulus)
    call tissue%import(Materials=.true., Material=PoissonRatio)
    call tissue%import(Materials=.true., Material=Density)
    call tissue%import(Materials=.true., Material=Cohesion)
    call tissue%import(Materials=.true., Material=Phi)
    call tissue%import(Materials=.true., Material=Psi)

    call water%import(Materials=.true., Material=Permiability)

    ! visualize material
    call YoungsModulus%gmsh(Name="YoungsModulus",Tag="M : YoungsModulus (kPa)")
    call PoissonRatio%gmsh(Name="PoissonRatio",Tag="M : PoissonRatio")
    call Permiability%gmsh(Name="Permiability",Tag="M : Permiability (cm/s)")

    ! createBoundary Conditions
    ! for Deformation analysis
    ! fixed boundary
    ! If multiple values are to be set for a Dirichlet/Neumann/Time Boundary condition,
    ! please use Layer (1, 2, 3...).
    call disp_x%create(Category="Dirichlet",x_max=1.0d0,x_min=-5.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=0.0d0,Layer=1,Name="disp_x")
    call disp_y%create(Category="Dirichlet",x_max=1.0d0,x_min=-5.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=0.0d0,Layer=2,Name="disp_y")
    call disp_z%create(Category="Dirichlet",x_max=1.0d0,x_min=-5.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=0.0d0,Layer=3,Name="disp_z")

    ! displacement-loading
    call disp_z%create(Category="Dirichlet",x_max=310.0d0,x_min=299.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=-100.0d0,Layer=3,Name="disp_z")

    ! traction boundary conditions
    !call traction_x%create("Neumann",x_max=300.0d0,x_min=30.0d0,y_max=120.0d0,y_min=-10.0d0,&
    !    z_max=10.0d0,z_min=-100.0d0,BoundValue=5.0d0)
    !call traction_x%create("Neumann",x_max=-300.0d0,x_min=-400.0d0,y_max=10.0d0,y_min=-1.0d0,&
    !    z_max=1.0d0,z_min=-1.0d0,BoundValue=0.0d0)
    !call traction_x%create("Neumann",x_max=100.0d0,x_min=30.0d0,y_max=520.0d0,y_min=500.0d0,&
    !    z_max=-10.0d0,z_min=-100.0d0,BoundValue=-2.0d0)

    ! for Flow analysis
    ! known value
    call const%create(category="Dirichlet",x_max=5.0d0,x_min=-1.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=0.0d0,Name="const",Layer=1)
    ! flux boundary
    call const%create(category="Dirichlet",x_max=310.0d0,x_min=299.0d0,y_max=100.0d0,y_min=-100.0d0,&
    z_max=100.0d0,z_min=-100.0d0,BoundValue=20.0d0,Name="const",Layer=1)

    ! visualize on Gmsh
    !call disp_x%gmsh(Dirichlet=.true.,Name="disp_x",Tag="B : disp_x")
    !call disp_y%gmsh(Dirichlet=.true.,Name="disp_y",Tag="B : disp_y")
    !call disp_z%gmsh(Dirichlet=.true.,Name="disp_z",Tag="B : disp_z")

    !call traction_x%gmsh(Neumann=.true.,Name="traction_x",Tag="traction_x")
    !call traction_y%gmsh(Neumann=.true.,Name="traction_y",Tag="traction_y")
    !call traction_z%gmsh(Neumann=.true.,Name="traction_z",Tag="traction_z")

    !call const%gmsh(Dirichlet=.true.,Name="Constant",Tag="B : Constant")

    !call Flux%gmsh(Neumann=.true.,Name="Flux",Tag="Flux")

    ! import boundaries onto FEMDomains
    call tissue%import(Boundaries=.true., Boundary=disp_x)
    call tissue%import(Boundaries=.true., Boundary=disp_y)
    call tissue%import(Boundaries=.true., Boundary=disp_z)
    call water%import(Boundaries=.true., Boundary=const)
    !call water%import(Boundaries=.true., Boundary=Flux)

    call tissue%show()
    call water%show()

    ! bake data by using templates
    call tissue%bake(template="FiniteDeform_")
    call water%bake(template="DiffusionEq_")

    ! visualize Domains
    call tissue%gmsh(Name="tissue",Tag="Tissue Domain")
    call water%gmsh(Name="water",Tag="Water Domain")

    call tissue%export(Name="tissue")
    call water%export(Name="water")

    ! mount data into a seed (An instance of Water-Absorption Solver)

    call seed%import(Water=water,Tissue=tissue)

    ! run simulation
    call seed%run(timestep=10,dt=0.0010d0,SolverType="BiCGSTAB",Display=.true.)

    ! visualize data
    !call seed%display()

end program main


text:
C$$$  MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM:  CWORDSH
C   PRGMMR: J. ATOR          ORG: NP12        DATE: 2005-11-29
C
C ABSTRACT: CONVERTS BINARY BYTE STREAM BUFR FILES BACK AND FORTH
C   FROM A FORTRAN BLOCKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1999-08-19  J. WOOLLEN  ORIGINAL VERSION FOR IMPLEMENTATION
C 2004-03-19  D. KEYSER   INCREASED SIZE OF ARRAY MBAY FROM 3000 WORDS
C                         TO 5000 WORDS TO ALLOW IT TO PROCESS BUFR
C                         MESSAGES WITH UP TO 20K BYTES
C 2005-11-29  J. ATOR     REWRITTEN USING BUFRLIB C I/O LOGIC TO HANDLE
C                         ANY INPUT BUFR FILES (INCLUDING FILES WHICH
C                         CONTAIN EXTRANEOUS CHARACTERS (E.G. BULLETIN
C                         HEADERS) AND/OR WHICH PREVIOUSLY REQUIRED THE
C                         USE OF APPLICATION PROGRAM GRABBUFR) AND TO
C                         REMOVE DIRECT LINKS TO BUFRLIB COMMON BLOCKS
C
C USAGE:
C   INPUT FILES:
C     UNIT 05  - STANDARD INPUT (OPERATION TYPE, INPUT FILENAME,
C                OUTPUT FILENAME)
C
C   OUTPUT FILES:
C     UNIT 06  - STANDARD OUTPUT PRINT
C     UNIT 51  - BLOCKED FORTRAN FILE OUTPUT FOR BLOCKING OPERATION
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - W3TAGB   W3TAGE   ERREXIT
C       BUFRLIB  - CCBFL    COBFL    CRBMG    CWBMG    PADMSG
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C          =   8 - INCORRECT INPUT PARAMETER
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  IBM SP
C
C$$$

      program cwordsh

      parameter(mxbufr=150000)
      parameter(mxbufrd4=mxbufr/4)

      character*80 bfile,ufile
      character*8  cword
      character*1  bufr(mxbufr)
      dimension    mbay(mxbufrd4)
      equivalence  (bufr(1),mbay(1))

c     Read and process the input arguments.

      write(6,*) 'Enter block or unblk'
      read(5,'(a)') cword
      if(cword.eq.'block') then
         write(6,*) 'Enter unblocked filename'
         read(5,'(a)') ufile
         write(6,*) 'Enter blocked filename'
         read(5,'(a)') bfile
      elseif(cword.eq.'unblk') then
         write(6,*) 'Enter blocked filename'
         read(5,'(a)') bfile
         write(6,*) 'Enter unblocked filename'
         read(5,'(a)') ufile
      else
         print*,'cword must be block or unblk'
         call exit(8)
      endif

c     Open the input and output files.

      if(cword.eq.'block') then
         print*,'blocking from: ',ufile
         print*,'           to: ',bfile
         call cobfl(ufile,'r')
         open(51,file=bfile,form='unformatted')
      else
         print*,'unblocking from: ',bfile
         print*,'             to: ',ufile
         call cobfl(bfile,'r')
         call cobfl(ufile,'w')
      endif

c     Read the next message from the input file.

      call crbmg(bufr,mxbufr,nbyt,ierr)
      do while(ierr.ge.0)
        if(ierr.eq.0) then

c         Pad the end of the message with zeroed-out bytes up to the
c         next 8-byte boundary.

          call padmsg(mbay,mxbufrd4,npbyt)
          ntbyt = nbyt + npbyt

c         Write the message plus padding to the output file...

          if(cword.eq.'block') then

c           using a FORTRAN write.

            write(51) (bufr(i),i=1,ntbyt)
          else

c           using a C write.

            call cwbmg(bufr,ntbyt,ierw)
            if(ierw.ne.0) print*,'return value from cwbmg was ',ierw
          endif
        else
          print*,'return value from crbmg was ',ierr,
     .           '; message not written to output'
        endif
        call crbmg(bufr,mxbufr,nbyt,ierr)
      enddo

c     Close the input and output files.

      call ccbfl
      if(cword.eq.'block') close(51)

      stop
      end

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


!
!  @GLOBAL.SOURCE@ - This file contains the exported functions that are
!  required for COM Server DLLs
!
!  Generated by the Intel(R) Visual Fortran COM Server Wizard on
!  @GLOBAL.DATE@ at @GLOBAL.TIME@.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

!
!  E X P O R T E D   F U N C T I O N S
!

!********************************************************************
!   ROUTINE: DllMain(HANDLE, DWORD, LPVOID)
!
!   PURPOSE:  DllMain is called by Windows when
!     the DLL is initialized, Thread Attached, and other times.
!     Refer to SDK documentation, as to the different ways this
!     may be called.
!
!     The DllMain function should perform additional initialization
!     tasks required by the DLL.  DllMain should return a value of 1
!     if the initialization is successful.
!
!*********************************************************************

integer(4) function DllMain (hInst, ul_reason_being_called, lpReserved)
    !dec$ if defined(_X86_)
    !dec$ attributes dllexport, stdcall, alias : '_DllMain@12' :: DllMain
    !dec$ else
    !dec$ attributes dllexport, stdcall, alias : 'DllMain' :: DllMain
    !dec$ end if
    use @GLOBAL.NAME@_global
    use ifcom
    implicit none

    ! Arguments
    integer(HANDLE) hInst
    integer(DWORD) ul_reason_being_called
    integer(LPVOID) lpReserved

    ! Variables
    integer(4) status

    if (ul_reason_being_called == DLL_PROCESS_ATTACH) then
      !  Save the module instance handle in a global variable
        ghinst =  hInst
        gCntLock = 0
        call InitializeCriticalSection(loc(gGlobalCriticalSection))
        ! Per Class
        @#PER CLASS
        g@CLASS.NAME@IClassFactory = NULL
        g@CLASS.NAME@ITypeInfo = NULL
        @#ENDPER
    else if (ul_reason_being_called == DLL_PROCESS_DETACH) then
        ! Release any class factories
        ! Per Class
        @#PER CLASS
        if (g@CLASS.NAME@IClassFactory /= NULL) then
            status = COMReleaseObject(g@CLASS.NAME@IClassFactory)
        end if
        if (g@CLASS.NAME@ITypeInfo /= NULL) then
            status = COMReleaseObject(g@CLASS.NAME@ITypeInfo)
        end if
        @#ENDPER
        call DeleteCriticalSection(loc(gGlobalCriticalSection))
    end if

    !  Return 1 to indicate success
    DllMain = 1
    return

end function DllMain

!********************************************************************
!   ROUTINE: DllRegisterServer(VOID)
!
!   PURPOSE:  DllRegisterServer is called to have the DLL
!             register itself.
!
!*********************************************************************

function DllRegisterServer () result (r)
    !dec$ if defined(_X86_)
    !dec$ attributes stdcall, alias : '_DllRegisterServer@0' :: DllRegisterServer
    !dec$ else
    !dec$ attributes stdcall, alias : 'DllRegisterServer' :: DllRegisterServer
    !dec$ end if
    use ifwinty
    use serverhelper
    implicit none

    integer(LONG) r

    r = RegisterServer()
    return
end function DllRegisterServer

!********************************************************************
!   ROUTINE: DllUnregisterServer(VOID)
!
!   PURPOSE:  DllUnregisterServer is called to have the DLL
!             remove its registration information.
!
!*********************************************************************

function DllUnregisterServer () result (r)
    !dec$ if defined(_X86_)
    !dec$ attributes stdcall, alias : '_DllUnregisterServer@0' :: DllUnregisterServer
    !dec$ else
    !dec$ attributes stdcall, alias : 'DllUnregisterServer' :: DllUnregisterServer
    !dec$ end if
    use ifwinty
    use serverhelper
    implicit none

    integer(long) r

    r = UnregisterServer()
    return
end function DllUnregisterServer

!********************************************************************
!   ROUTINE: DllGetClassObject(rclsid, riid, ppv)
!
!   PURPOSE:  DllGetClassObject is called to have the DLL create an
!             instance of a class supported by the server.
!
!*********************************************************************

function DllGetClassObject (rclsid, riid, ppv) result (r)
    !dec$ if defined(_X86_)
    !dec$ attributes stdcall, alias : '_DllGetClassObject@12' :: DllGetClassObject
    !dec$ else
    !dec$ attributes stdcall, alias : 'DllGetClassObject' :: DllGetClassObject
    !dec$ end if
    use @GLOBAL.NAME@_global
    @#PER CLASS
    use @CLASS.NAME@_Types
    @#ENDPER
    use IClassFactory_Types
    use IClassFactory_Methods
    use ifwinty
    use ifcom
    implicit none

    type(guid) rclsid
    !dec$ attributes reference :: rclsid
    type(guid) riid
    !dec$ attributes reference :: riid
    integer(int_ptr_kind()) ppv
    !dec$ attributes reference :: ppv
    integer(long) r

    integer(long) status

    r = S_OK
    ppv = NULL

    !  Ensure that they are requesting a supported class and
    !  the IClassFactory or IUnknown interface
    if ((.not. COMIsEqualGUID(riid, IID_IClassFactory)) .AND. &
        (.not. COMIsEqualGUID(riid, IID_IUnknown))) then
        r = E_UNEXPECTED
        return
    end if
    !  Per class - Create the class factory, if necessary
    @#PER CLASS
    if (COMIsEqualGUID(rclsid, CLSID_@CLASS.NAME@)) then
        if (g@CLASS.NAME@IClassFactory == NULL) then
            call EnterCriticalSection(loc(gGlobalCriticalSection))
            if (g@CLASS.NAME@IClassFactory == NULL) then
                !  Allocate an instance data structure and a Vtbl
                allocate (gp@CLASS.NAME@CFData)
                allocate (gp@CLASS.NAME@CFData % pVtbl)
                gp@CLASS.NAME@CFData % refCount = 1
                !  The Vtbl implementations are in ClsFact.f90
                gp@CLASS.NAME@CFData % pVtbl % QueryInterface = &
                        loc(IClassFactory_QueryInterface)
                gp@CLASS.NAME@CFData % pVtbl % AddRef = &
                        loc(IClassFactory_AddRef)
                gp@CLASS.NAME@CFData % pVtbl % Release = &
                        loc(IClassFactory_Release)
                gp@CLASS.NAME@CFData % pVtbl % CreateInstance = &
                        loc(IClassFactory_Create@CLASS.NAME@Instance)
                gp@CLASS.NAME@CFData % pVtbl % LockServer = &
                        loc(IClassFactory_LockServer)
                g@CLASS.NAME@IClassFactory  = loc(gp@CLASS.NAME@CFData)
            end if
            call LeaveCriticalSection(loc(gGlobalCriticalSection))
        end if
        ppv = loc(gp@CLASS.NAME@CFData)
        status = COMAddObjectReference (ppv)
        return
    end if
    @#ENDPER

    r = CLASS_E_CLASSNOTAVAILABLE
    return

end function DllGetClassObject

!********************************************************************
!   ROUTINE: DllCanUnloadNow(VOID)
!
!   PURPOSE:  DllCanUnloadNow is called to check whether the DLL
!             can be unloaded
!
!*********************************************************************

function DllCanUnloadNow () result (r)
    !dec$ if defined(_X86_)
    !dec$ attributes stdcall, alias : '_DllCanUnloadNow@0' :: DllCanUnloadNow
    !dec$ else
    !dec$ attributes stdcall, alias : 'DllCanUnloadNow' :: DllCanUnloadNow
    !dec$ end if
    use ifwinty
    use @GLOBAL.NAME@_global
    implicit none

    integer(LONG) r

    if (gCntLock > 0) then
        r = S_FALSE         ! "No"
    else
        r = S_OK            ! "Yes"
    endif

    return

end function DllCanUnloadNow


text:
c
c  pressure levels from heights, temperature and mosture.
c

	subroutine z2pres(pres0, z, tabs, q, p)

	implicit none
	include 'grid.inc'

! input:
	real pres0	! surface pressure
	real z(nzm)	! height
	real tabs(nzm)	! absolute temperature, K
	real q(nzm)	! vapor mixing ratio, kg/kg
!output
	real p(nzm)	! pressure levels, mB
!local
	real pi(0:nzm), tv(nzm), coef, tmp
	integer k

	coef = 2.*9.81/1004.

	do k=1,nzm
	 tv(k)=tabs(k)*(1.+0.61*q(k))
	end do

	pi(0)=(pres0/1000.)**0.28586
	pi(1)=pi(0)*tv(1)/(tv(1)+coef/2.*z(1))
	p(1) = 1000.*pi(1)**3.498278
	do k=2,nzm
	 tmp = (tv(k)-tv(k-1)+coef*(z(k)-z(k-1)))*pi(k-1)
	 pi(k)= (-tmp+sqrt(tmp**2+4.*tv(k)*tv(k-1)*pi(k-1)**2))
     &	                                            /(2.*tv(k-1))
	 p(k) = 1000.*pi(k)**3.498278
	end do

	return
	end

max_stars_repo_name: kbren/uwnet

max_issues_repo_name: kbren/uwnet

max_forks_repo_name: kbren/uwnet


text:
program fac_init
    use fac_mod
    implicit none
    integer :: i
    do i = 0, 5
        print '(A, I1, A, I6)', 'factorial(', i, ') =', factorial(i)
    end do
end program fac_init

max_stars_repo_name: Gjacquenot/training-material

max_issues_repo_name: Gjacquenot/training-material

max_forks_repo_name: Gjacquenot/training-material


text:
	SUBROUTINE ST_C2C  ( string, nexp, strarr, num, iret )
C************************************************************************
C* ST_C2C								*
C*									*
C* This subroutine breaks a string to an array of strings.  The		*
C* string separators may be any non-alphanumeric character except 	*
C* a minus sign (-), plus sign (+), asterisk (*) or period (.).		*
C*									*
C* ST_C2C  ( STRING, NEXP, STRARR, NUM, IRET )				*
C*									*
C* Input parameters:                                                   	*
C*	STRING		CHAR*		String 				*
C*	NEXP		INTEGER 	Maximum number of strings	*
C*									*
C* Output parameters:                                                  	*
C*	STRARR (*) 	CHAR*		String array			*
C*	NUM		INTEGER		Number of strings		*
C*	IRET 		INTEGER		Return code  			*
C*				   	  1 = more than NEXP strings 	*
C*				   	  0 = normal return		*
C*				  	 -1 = no strings input		*
C** 									*
C* Log:									*
C* I. Graffman/RDS    	 2/84   					*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* L. Sager/NCEP	 2/96	Increased size of strbuf		*
C************************************************************************
	CHARACTER*(*)	string, strarr (*)
C*
	CHARACTER  	strbuf*160
C------------------------------------------------------------------------
	iret = 0
	num  = 0
C
C*	Remove separators.
C
	CALL ST_RNAN  ( string, strbuf, lnstr, iret )
C
C*	Check for blank string.
C
	IF  ( lnstr .eq. 0 )  THEN
	    iret = -1
	    RETURN
	END IF
C
C*	Set up pointer.
C
	ip = 1
	DO WHILE  ( ip .le. lnstr )
C
C*	    Check for blank.
C
	    ie = INDEX  ( strbuf ( ip : lnstr ), ' ' )
	    IF  ( ie .eq. 0 )  THEN
		ie = lnstr + 1
	      ELSE
		ie = ie + ip - 1
	    ENDIF
C
C*	    If there are too many strings, flag and exit.
C
	    IF  ( num .ge. nexp )  THEN
	        iret = 1
	        RETURN
	      ELSE
		num = num + 1
		strarr ( num ) = strbuf ( ip : ie )
	    END IF
C
C*	    Increment pointer.
C
	    ip = ie + 1
	END DO
C*
	RETURN
	END


text:
module Mod_podromDriver
   use typre
   use MPI
   use Mod_BroadCastBuffer
   use Mod_Listen
   use Mod_podrom
   use Mod_caseVariables
   use Mod_PhysicalProblemDriver
   use Mod_PhysicalProblem
   use Mod_DistributedContainer
   use Mod_DC_rp
   use Mod_InChannel
   use Mod_MasterVariables
   use Mod_DriverCreator
   implicit none

   private

   public :: podromDriver, podromDriver_Const

   type, extends(DriverInterface) :: podromDriver

      class(PodromProblem), pointer :: Podrom => NULL()

      character(5) :: PhysicalType,PhysicalKey

      logical :: AreWeRunning = .false.     !false: build, true: run

      !The physical driver is MINE
      !I own it!
      class(DriverInterface), pointer :: PhysicalDriver => null()

contains

      procedure :: Lev1Reapro             => podrom_Lev1Reapro
      procedure :: Lev1ReaproMPI          => podrom_Lev1ReaproMPI
      procedure :: InitializeChannelLists => podrom_InitializeChannelLists
      procedure :: FinalizeChannelLists   => podrom_FinalizeChannelLists
      procedure :: SetInChannels          => podrom_SetInChannels
      procedure :: SetOutChannels         => podrom_SetOutChannels
      procedure :: UpdateChannels         => podrom_UpdateChannels
      procedure :: Turnon                 => podrom_Turnon
      procedure :: GetTimeStep            => podrom_GetTimeStep
      procedure :: SetTimeStep            => podrom_SetTimeStep
      procedure :: GetRefinementCriteria  => podrom_GetRefinementCriteria
      procedure :: PreRefine              => podrom_PreRefine
      procedure :: Refine                 => podrom_Refine
      procedure :: Rebalance              => podrom_Rebalance
      procedure :: Begste                 => podrom_Begste
      procedure :: MeshProjections        => podrom_MeshProjections
      procedure :: MeshAdvections         => podrom_MeshAdvections
      procedure :: Doiter                 => podrom_Doiter
      procedure :: Convergence            => podrom_Convergence
      procedure :: CoupledConvergence     => podrom_CoupledConvergence
      procedure :: Endste                 => podrom_Endste
      procedure :: Output                 => podrom_Output
      procedure :: Turnof                 => podrom_Turnof
      procedure :: WriteTimes             => podrom_WriteTimes

   end type podromDriver

   interface podromDriver_Const
      procedure constructor
   end interface

   interface
      subroutine CreateDriverFromKey(key,DriverCreator)
         use Mod_DriverCreator
         implicit none
         character(5) :: key
         type(DriverCreatorType) :: DriverCreator
      end subroutine
   end interface

contains

   function constructor()
       class(podromDriver), pointer :: constructor

       allocate(constructor)
   end function constructor

   subroutine podrom_Lev1Reapro(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      type(DriverCreatorType) :: DriverCreator

      if(a%Listener%words(1) == 'PHYSI') then
         if (a%Listener%exists('LOWMA')) then
            a%PhysicalType = 'LMACH'
            a%PhysicalKey  = 'LMACH'
         elseif (a%Listener%exists('TEMPE')) then
            a%PhysicalType = 'TEMPE'
            a%PhysicalKey  = 'TEMPE'
         elseif (a%Listener%exists('NAVIE')) then
            a%PhysicalType = 'NSTIN'
            a%PhysicalKey  = 'NSTIN'
         elseif (a%Listener%exists('SOLID')) then
            a%PhysicalType = 'SOLID'
            a%PhysicalKey  = 'SOLID'
         elseif (a%Listener%exists('IRRSP')) then
            a%PhysicalType = 'IRRSP'
            a%PhysicalKey  = 'SOLID'
         elseif (a%Listener%exists('COMPR')) then
            a%PhysicalType = 'NSCOM'
            a%PhysicalKey  = 'NSCOM'
         elseif (a%Listener%exists('BOUSS')) then
            a%PhysicalType = 'BOUSS'
            a%PhysicalKey  = 'NSTIN'
         else
            call runend('PodRom: physical Problem not ready for the ROM')
         endif

         !Now the interior physical driver is initialized
         !and told to read
         call CreateDriverFromKey(a%PhysicalKey,DriverCreator)
         if (DriverCreator%key == 'NODRI') call runend('wrong type of driver, rom')
         a%PhysicalDriver => DriverCreator%Driver
         call a%Memor%allocobj(0,'RomPhysicalDriver','podrom_turnon',1)

         a%kfl_preli = 1 ! comment this line for AMR
         a%kfl_rstar = 1

         !Initialize, driver!
         call a%PhysicalDriver%Initialize(c)

         !Read your things, driver!
         call a%PhysicalDriver%Reapro(c,DriverCreator%endword)

      endif
   end subroutine

   subroutine podrom_Lev1ReaproMPI(a,c,bb)
      class(podromDriver) :: a
      type(caseVariables) :: c
      type(BroadCastBuffer) :: bb

      type(DriverCreatorType) :: DriverCreator

      integer(ip) :: ierr

      !We need to be quick with the Driver type because we need
      !to do their reaproMPI. MPIBCAST instead of buffer.
      call MPI_BCAST(a%PhysicalType,5,MPI_CHARACTER,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%PhysicalKey,5,MPI_CHARACTER,a%MPIroot,a%MPIcomm,ierr)

      if (a%MPIrank /= a%MPIroot) then
         !Now the other processors create their drivers
         call CreateDriverFromKey(a%PhysicalKey,DriverCreator)
         a%PhysicalDriver => DriverCreator%Driver
         call a%Memor%allocobj(0,'RomPhysicalDriver','podrom_turnon',1)

         !Initialize, driver!
         call a%PhysicalDriver%Initialize(c)
      endif

      !Now we all do the reaproMPI
      call a%PhysicalDriver%ReaproMPI(c)

   end subroutine

   subroutine podrom_InitializeChannelLists(a)
      class(PodRomDriver) :: a

      !Initialize your channels, driver!
      call a%PhysicalDriver%InitializeChannelLists

      !Give me your channels, driver!
      !The Rom Channels point to the physical driver channels
      call a%PhysicalDriver%GetChannelLists(a%OutChannelList,a%InChannelList)

   end subroutine

   subroutine podrom_FinalizeChannelLists(a)
      class(PodRomDriver) :: a

      !Finalize your channels, driver!
      call a%PhysicalDriver%FinalizeChannelLists
   end subroutine

   subroutine podrom_SetOutChannels(a,task)
      class(podromDriver) :: a
      character(*) :: task

      !Set your OutChannels, driver!
      call a%PhysicalDriver%SetOutChannels(task)
   end subroutine

   subroutine podrom_SetInChannels(a)
      class(podromDriver) :: a

      !Set your inChannels, driver!
      call a%PhysicalDriver%SetInChannels
   end subroutine

   subroutine podrom_UpdateChannels(a)
      implicit none
      class(podromDriver) :: a

      !Update your channels, driver!
      call a%PhysicalDriver%UpdateChannels
   end subroutine

   subroutine podrom_Turnon(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      class(PhysicalProblem), pointer :: PhysicalPro => NULL()
      integer(ip) :: kfl_itask,PhysicalAlgor

      !Depending on the type of ROM, create a rom type
      a%PodRom => PodRomProblem_Const()

      call a%Memor%allocobj(0,'Podrom','podrom_turnon',1)

      !We turn on the rom
      !General data
      call a%PodRom%SetMPI(c%masterVars%MPIcomm,c%masterVars%MPIsize,c%masterVars%MPIroot,c%masterVars%MPIrank)
      call a%PodRom%SetReadType(c%masterVars%ReadTypeString)
      call a%PodRom%SetInputFolder(c%masterVars%BaseDataFolder)
      call a%PodRom%SetRestartFolder(c%masterVars%RestartFolder)
      call a%PodRom%SetOldRestartFile(c%masterVars%RestartFolder)
      call a%PodRom%SetInputFile(c%masterVars%namda)
      call a%PodRom%SetOutputFolder(c%masterVars%ResultsFolder)
      call a%PodRom%SetOutputFiles(c%masterVars%lun_memor,c%masterVars%lun_outpu)
      call a%PodRom%SetIOPointers(c%masterVars%Writerpr,c%masterVars%Readerpr)
      call a%PodRom%SetFlush(c%masterVars%kfl_flush)
      call a%PodRom%SetOldInputFile(c%masterVars%namda)

      !Turnon, driver!
      call a%PhysicalDriver%Turnon(c)

      !Give us your PhysicalProblem, driver!
      call a%PhysicalDriver%GetPhysicalProblem(PhysicalPro)
      call a%PhysicalDriver%GetPhysicalAlgorithm(PhysicalAlgor)

      !We will keep a pointer to it safely
      call a%PodRom%SetPhysicalProblem(PhysicalPro,a%PhysicalType,PhysicalAlgor)

      if (a%kfl_rstar==1) then
         if (a%kfl_inter==1) then
            call a%PodRom%SetInterpolation
            if (c%adaptiveVars%UpdateIO) call a%PodRom%SetUpdateFreq(c%adaptiveVars%UpdateFreq)
            call a%PodRom%SetOldRestartFile(c%masterVars%OldRestartFolder)
            call a%PodRom%SetOldInputFile(c%masterVars%oldnamda)
            call a%PodRom%SetInterp(c%masterVars%Int_Restart)
            call a%PodRom%SetOldMesh
         endif
      endif

      !Turnon operations
      call a%PodRom%Turnon

      !Adaptive Mesh Refinement
      if (c%adaptiveVars%kfl_AdaptiveRefinement == 1 .or. c%adaptiveVars%NumberOfInitialUniformRefinementSteps > 0) then
         call a%PodRom%SetAdaptiveRefiner(c%adaptiveVars%Refiner)
      endif

      call a%PodRom%GetItask(kfl_itask)
      if (kfl_itask == 1) then
         a%AreWeRunning = .true.
      else
         a%AreWeRunning = .false.
      endif

   end subroutine

   subroutine podrom_GetTimeStep(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (a%AreWeRunning) return

      !Give us the time step, driver!
      call a%PhysicalDriver%GetTimeStep(c)
   end subroutine podrom_GetTimeStep

   subroutine podrom_SetTimeStep(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      call a%PodRom%Setste(c%mastervars%dtinv,c%mastervars%ctime)

      !Here you have the time step, driver
      call a%PhysicalDriver%SetTimeStep(c)
   end subroutine podrom_SetTimeStep

   subroutine podrom_GetRefinementCriteria(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      call a%PodRom%GetRefinementCriteria(c%adaptiveVars%RefinerMarkel)
   end subroutine podrom_GetRefinementCriteria

   subroutine podrom_PreRefine(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (c%adaptiveVars%kfl_AdaptiveRefinement == 1) then
         call a%PhysicalDriver%PreRefine(c)
      end if
   end subroutine podrom_PreRefine

   subroutine podrom_Refine(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (c%adaptiveVars%kfl_AdaptiveRefinement == 1) then
         call a%PhysicalDriver%Refine(c)
         call a%PodRom%Refine('Refine')
      end if
   end subroutine podrom_Refine

   subroutine podrom_Rebalance(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (c%adaptiveVars%kfl_AdaptiveRefinement == 1) then
         call a%PhysicalDriver%Rebalance(c)
         call a%PodRom%Refine('Rebalance')
      end if
   end subroutine podrom_Rebalance

   subroutine podrom_Begste(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (a%ndela > c%masterVars%istep - 1) return

      call a%PodRom%Begste

      if (a%AreWeRunning) return

      !Begste, driver!
      call a%PhysicalDriver%Begste(c)
   end subroutine podrom_Begste

   subroutine podrom_MeshProjections(a,c,itask)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      integer(ip)         :: itask

      if (a%ndela > c%masterVars%istep - 1) return

      call runend('I do not think the rom is ready for mesh projections')

      !Mesh projections, driver!
      call a%PhysicalDriver%MeshProjections(c,itask)
   end subroutine podrom_MeshProjections

   subroutine podrom_MeshAdvections(a,c,itask)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      integer(ip)         :: itask

      if (a%ndela > c%masterVars%istep - 1) return

      call runend('I do not think the rom is ready for mesh projections')

      !Mesh projections, driver!
      call a%PhysicalDriver%MeshAdvections(c,itask)
   end subroutine podrom_MeshAdvections

   subroutine podrom_Doiter(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (a%ndela > c%masterVars%istep - 1) return

      call a%PodRom%Doiter

      if (a%AreWeRunning) return

      !DoIter, driver!
      call a%PhysicalDriver%DoIter(c)
   end subroutine podrom_Doiter

   subroutine podrom_Convergence(a,c,glres)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      real(rp)            :: glres

      glres = 0.0_rp
      if (a%ndela > c%masterVars%istep - 1) return

      !Compute the convergence, driver!
      call a%PhysicalDriver%Convergence(c,glres)
   end subroutine podrom_Convergence

   subroutine podrom_CoupledConvergence(a,c,kfl_flag,cpres)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c
      logical             :: kfl_flag
      real(rp)            :: cpres

      kfl_flag = .true.
      if (a%ndela > c%masterVars%istep - 1) return

      call a%PhysicalDriver%CoupledConvergence(c,kfl_flag,cpres)

   end subroutine podrom_CoupledConvergence

   subroutine podrom_Endste(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (a%ndela > c%masterVars%istep - 1) return

      call a%PodRom%Endste(c%masterVars%kfl_gotim)

      if (a%AreWeRunning) return

      !Do your Enste, driver!
      call a%PhysicalDriver%Endste(c)
   end subroutine podrom_Endste

   subroutine podrom_Output(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      if (a%ndela > c%masterVars%istep - 1) return
      call a%PhysicalDriver%Output(c)

   end subroutine podrom_Output

   subroutine podrom_Turnof(a,c)
      implicit none
      class(podromDriver) :: a
      type(caseVariables) :: c

      call a%PodRom%Turnof

      !deallocate(a%PodRom)
      !I do not deallocate it, I need it to be alive in Cputab
      !We should do something about this
      call a%Memor%deallocobj(0,'Podrom','podrom_turnon',1)

      !Turnof, driver!
      call a%PhysicalDriver%Turnof(c)
      call a%Memor%deallocobj(0,'RomPhysicalDriver','podrom_turnon',1)

   end subroutine podrom_Turnof

   subroutine podrom_WriteTimes(a)
      implicit none
      class(podromDriver) :: a

      !Write the times, driver!
      call a%PhysicalDriver%WriteTimes
   end subroutine podrom_WriteTimes

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


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

! CHECK-LABEL: eoshift_test1
subroutine eoshift_test1(arr, shift)
    logical, dimension(3) :: arr, res
    integer :: shift
  ! CHECK: %[[resBox:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
  ! CHECK: %[[res:.*]] = fir.alloca !fir.array<3x!fir.logical<4>> {bindc_name = "res", uniq_name = "_QFeoshift_test1Eres"}
  ! CHECK: %[[resLoad:.*]] = fir.array_load %[[res]]({{.*}}) : (!fir.ref<!fir.array<3x!fir.logical<4>>>, !fir.shape<1>) -> !fir.array<3x!fir.logical<4>>
  ! CHECK: %[[arr:.*]] = fir.embox %arg0({{.*}}) : (!fir.ref<!fir.array<3x!fir.logical<4>>>, !fir.shape<1>) -> !fir.box<!fir.array<3x!fir.logical<4>>>
  ! CHECK: %[[bits:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.logical<4>>>
  ! CHECK: %[[init:.*]] = fir.embox %[[bits]]({{.*}}) : (!fir.heap<!fir.array<?x!fir.logical<4>>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>
  ! CHECK: fir.store %[[init]] to %[[resBox]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>
  ! CHECK:  %[[boundBox:.*]] = fir.absent !fir.box<none>
  ! CHECK: %[[shift:.*]] = fir.load %arg1 : !fir.ref<i32>

    res = eoshift(arr, shift)

  ! CHECK: %[[resIRBox:.*]] = fir.convert %[[resBox]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.logical<4>>>>>) -> !fir.ref<!fir.box<none>>
  ! CHECK: %[[arrBox:.*]] = fir.convert %[[arr]] : (!fir.box<!fir.array<3x!fir.logical<4>>>) -> !fir.box<none>
  ! CHECK: %[[shiftBox:.*]] = fir.convert %[[shift]] : (i32) -> i64
  ! CHECK: %[[tmp:.*]] = fir.call @_FortranAEoshiftVector(%[[resIRBox]], %[[arrBox]], %[[shiftBox]], %[[boundBox]], {{.*}}, {{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, i64, !fir.box<none>, !fir.ref<i8>, i32) -> none
  ! CHECK: fir.array_merge_store %[[resLoad]], {{.*}} to %[[res]] : !fir.array<3x!fir.logical<4>>, !fir.array<3x!fir.logical<4>>, !fir.ref<!fir.array<3x!fir.logical<4>>>
  end subroutine eoshift_test1

  ! CHECK-LABEL: eoshift_test2
  subroutine eoshift_test2(arr, shift, bound, dim)
    integer, dimension(3,3) :: arr, res
    integer, dimension(3) :: shift
    integer :: bound, dim
  ! CHECK: %[[resBox:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xi32>>>
  ! CHECK: %[[res:.*]] = fir.alloca !fir.array<3x3xi32> {bindc_name = "res", uniq_name = "_QFeoshift_test2Eres"}
  !CHECK: %[[resLoad:.*]] = fir.array_load %[[res]]({{.*}}) : (!fir.ref<!fir.array<3x3xi32>>, !fir.shape<2>) -> !fir.array<3x3xi32>

    res = eoshift(arr, shift, bound, dim)

  ! CHECK: %[[arr:.*]] = fir.embox %arg0({{.*}}) : (!fir.ref<!fir.array<3x3xi32>>, !fir.shape<2>) -> !fir.box<!fir.array<3x3xi32>>
  ! CHECK: %[[boundBox:.*]] = fir.embox %arg2 : (!fir.ref<i32>) -> !fir.box<i32>
  ! CHECK: %[[dim:.*]] = fir.load %arg3 : !fir.ref<i32>
  ! CHECK: %[[shiftBox:.*]] = fir.embox %arg1({{.*}}) : (!fir.ref<!fir.array<3xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<3xi32>>
  ! CHECK: %[[resIRBox:.*]] = fir.convert %[[resBox]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>) -> !fir.ref<!fir.box<none>>
  ! CHECK: %[[arrBox:.*]] = fir.convert %[[arr]] : (!fir.box<!fir.array<3x3xi32>>) -> !fir.box<none>
  ! CHECK: %[[shiftBoxNone:.*]] = fir.convert %[[shiftBox]] : (!fir.box<!fir.array<3xi32>>) -> !fir.box<none>
  ! CHECK: %[[boundBoxNone:.*]] = fir.convert %[[boundBox]] : (!fir.box<i32>) -> !fir.box<none>

  ! CHECK: %[[tmp:.*]] = fir.call @_FortranAEoshift(%[[resIRBox]], %[[arrBox]], %[[shiftBoxNone]], %[[boundBoxNone]], %[[dim]], {{.*}}, {{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.box<none>, i32, !fir.ref<i8>, i32) -> none
  ! CHECK: fir.array_merge_store %[[resLoad]], {{.*}} to %[[res]] : !fir.array<3x3xi32>, !fir.array<3x3xi32>, !fir.ref<!fir.array<3x3xi32>>
  end subroutine eoshift_test2

  ! CHECK-LABEL: eoshift_test3
  subroutine eoshift_test3(arr, shift, dim)
    character(4), dimension(3,3) :: arr, res
    integer :: shift, dim

  ! CHECK: %[[resBox:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?x!fir.char<1,4>>>>
  ! CHECK: %[[arr:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
  ! CHECK: %[[array:.*]] = fir.convert %[[arr]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<3x3x!fir.char<1,4>>>
  ! CHECK: %[[res:.*]] = fir.alloca !fir.array<3x3x!fir.char<1,4>> {bindc_name = "res", uniq_name = "_QFeoshift_test3Eres"}
  ! CHECK: %[[resLoad:.*]] = fir.array_load %[[res]]({{.*}}) : (!fir.ref<!fir.array<3x3x!fir.char<1,4>>>, !fir.shape<2>) -> !fir.array<3x3x!fir.char<1,4>>
  ! CHECK: %[[arrayBox:.*]] = fir.embox %[[array]]({{.*}}) : (!fir.ref<!fir.array<3x3x!fir.char<1,4>>>, !fir.shape<2>) -> !fir.box<!fir.array<3x3x!fir.char<1,4>>>
  ! CHECK: %[[dim:.*]] = fir.load %arg2 : !fir.ref<i32>

    res = eoshift(arr, SHIFT=shift, DIM=dim)

  ! CHECK: %[[boundBox:.*]] = fir.absent !fir.box<none>
  ! CHECK: %[[shiftBox:.*]] = fir.embox %arg1 : (!fir.ref<i32>) -> !fir.box<i32>
  ! CHECK: %[[resIRBox:.*]] = fir.convert %[[resBox]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?x!fir.char<1,4>>>>>) -> !fir.ref<!fir.box<none>>
  ! CHECK: %[[arrayBoxNone:.*]] = fir.convert %[[arrayBox]] : (!fir.box<!fir.array<3x3x!fir.char<1,4>>>) -> !fir.box<none>
  ! CHECK: %[[shiftBoxNone:.*]] = fir.convert %[[shiftBox]] : (!fir.box<i32>) -> !fir.box<none>
  ! CHECK: %[[tmp:.*]] = fir.call @_FortranAEoshift(%[[resIRBox]], %[[arrayBoxNone]], %[[shiftBoxNone]], %[[boundBox]], %[[dim]], {{.*}}, {{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.box<none>, i32, !fir.ref<i8>, i32) -> none
  ! CHECK: fir.array_merge_store %[[resLoad]], {{.*}} to %[[res]] : !fir.array<3x3x!fir.char<1,4>>, !fir.array<3x3x!fir.char<1,4>>, !fir.ref<!fir.array<3x3x!fir.char<1,4>>>
  end subroutine eoshift_test3

  ! CHECK-LABEL: func @_QPeoshift_test_dynamic_optional(
  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>>
  ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32>
  ! CHECK-SAME:  %[[VAL_2:.*]]: !fir.ref<!fir.array<10xi32>>
  subroutine eoshift_test_dynamic_optional(array, shift, boundary)
    type t
      integer :: i
    end type
    integer :: array(:, :)
    integer :: shift
    integer, optional :: boundary(10)
    call next(eoshift(array, shift, boundary))
  ! CHECK:  %[[VAL_4:.*]] = arith.constant 10 : index
  ! CHECK:  %[[VAL_5:.*]] = fir.is_present %[[VAL_2]] : (!fir.ref<!fir.array<10xi32>>) -> i1
  ! CHECK:  %[[VAL_6:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1>
  ! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_2]](%[[VAL_6]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xi32>>
  ! CHECK:  %[[VAL_8:.*]] = fir.absent !fir.box<!fir.array<10xi32>>
  ! CHECK:  %[[VAL_9:.*]] = arith.select %[[VAL_5]], %[[VAL_7]], %[[VAL_8]] : !fir.box<!fir.array<10xi32>>
  ! CHECK:  %[[VAL_21:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.array<10xi32>>) -> !fir.box<none>
  ! CHECK:  fir.call @_FortranAEoshift(%{{.*}}, %{{.*}}, %{{.*}}, %[[VAL_21]], %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.box<none>, i32, !fir.ref<i8>, i32) -> none
  end subroutine

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


SUBROUTINE sparin(kv,kdiag)
!
! This subroutine performs Cholesky factorisation on a symmetric
! skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::kv(:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,kj,j,ll,m,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 kv(1)=SQRT(kv(1))
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   DO j=l,i
     x=kv(ki+j)
     kj=kdiag(j)-j
     IF(j/=1)THEN
       ll=kdiag(j-1)-kj+1
       ll=max(l,ll)
       IF(ll/=j)THEN
         m=j-1
         DO k=ll,m
           x=x-kv(ki+k)*kv(kj+k)
         END DO
       END IF
     END IF
     kv(ki+j)=x/kv(kj+j)
   END DO
   kv(ki+i)=SQRT(x)
 END DO
RETURN
END SUBROUTINE sparin


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

module elemdbg2d_test1

  use fsystem
  use genoutput
  use paramlist
  use storage
  use cubature
  use matrixfilters
  use vectorfilters
  use bcassembly
  use bcassemblybase
  use linearalgebra
  use dofmapping
  use basicgeometry
  use triangulation
  use element
  use spatialdiscretisation
  use transformation
  use elementpreprocessing
  use linearsystemscalar
  use linearsystemblock
  use discretebc
  use scalarpde
  use pprocerror
  use stdoperators
  use meshmodification
  use ucd
  use spdiscprojection
  use convection
  use collection
  use sortstrategybase
  use sortstrategy
  use bilinearformevaluation
  use linearformevaluation
  use linearsolver
  use statistics

  use elemdbg2d_callback
  use elemdbg2d_sd_aux
  use disto2d_aux

  implicit none

contains

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

!<subroutine>

  subroutine elemdbg2d_1(rparam, sConfigSection, itest)
  type(t_parlist), intent(INOUT) :: rparam
  character(LEN=*), intent(IN) :: sConfigSection
  integer, intent(IN) :: itest

!<description>
!</description>

!</subroutine>

  type(t_boundary) :: rboundary
  type(t_triangulation) :: rtriangulation
  type(t_blockDiscretisation) :: rdiscretisation
  type(t_linearForm) :: rlinform
  type(t_matrixBlock) :: rmatrix
  type(t_vectorBlock), target :: rvecSol, rvecRhs, rvectmp
  type(t_boundaryRegion) :: rboundaryRegion
  type(t_discreteBC), target :: rdiscreteBC
  type(t_linsolNode), pointer :: p_rsolver, p_rprecond
  type(t_matrixBlock), dimension(1) :: Rmatrices
  type(t_errorScVec) :: rerror
  integer :: NLMIN,NLMAX,ierror,ilvl
  real(DP), dimension(:,:), allocatable, target :: Derror
  real(DP), dimension(:,:), allocatable, target :: Dtimer
  integer, dimension(:,:), allocatable :: Istat
  integer :: isolver, ioutput, nmaxiter,ccubature,idistType,idistLevel,idistLvl
  integer(I32) :: celement, cprimaryelement, cshape
  real(DP) :: ddist, depsRel, depsAbs, drelax, daux1, daux2, daux3, daux4, daux5, ddist2
  character(LEN=32) :: selement,sprimaryelement,scubature
  type(t_bilinearForm) :: rform
  integer :: iucd
  type(t_ucdexport) :: rexport
  real(DP) :: dnu,dbeta1,dbeta2,dupsam,dgamma
  integer :: istabil, isolution, ifillin, clocalh
  type(t_convStreamlineDiffusion) :: rconfigSD
  type(t_jumpStabilisation) :: rconfigEOJ
  type(t_collection) :: rcollect
  integer, dimension(:), allocatable :: p_Iedges, p_Itemp
  integer :: iedge,ibc,nedgecount
  type(t_vectorBlock) :: rvelocityVector
  type(t_blockDiscretisation) :: rdiscretisationVel
  character(len=SYS_STRLEN) :: spredir, sucddir
  type(t_blockSortStrategy) :: rsortStrategy
  type(t_scalarCubatureInfo) :: rcubatureInfo
  type(t_timer) :: rtimer

    ! Fetch sytem variables
    if (.not. sys_getenv_string("PREDIR", spredir)) spredir = './pre'
    if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = './ucd'

    ! Fetch minimum and maximum levels
    call parlst_getvalue_int(rparam, sConfigSection, 'NLMIN', NLMIN, -1)
    call parlst_getvalue_int(rparam, sConfigSection, 'NLMAX', NLMAX, -1)

    if((NLMIN .lt. 1) .or. (NLMAX .lt. NLMIN)) then
      call output_line('Invalid NLMIN/NLMAX parameters',&
           OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end if

    ! Fetch mesh distortion type
    call parlst_getvalue_int(rparam, sConfigSection, 'IDISTTYPE', idistType, 0)

    ! Fetch mesh distortion level
    call parlst_getvalue_int(rparam, sConfigSection, 'IDISTLEVEL', idistLevel, 0)

    ! Fetch mesh distortion parameters
    call parlst_getvalue_double(rparam, sConfigSection, 'DMESHDISTORT', ddist, 0.1_DP)
    call parlst_getvalue_double(rparam, sConfigSection, 'DMESHDISTORT2', ddist2, 0.0_DP)

    ! Fetch element and cubature rule
    call parlst_getvalue_string(rparam, sConfigSection, 'SELEMENT', selement, '')
    call parlst_getvalue_string(rparam, sConfigSection, 'SCUBATURE', scubature, '')

    ! Fetch desired solution
    call parlst_getvalue_int(rparam, sConfigSection, 'ISOLUTION', isolution, 0)

    ! Fetch solver type
    call parlst_getvalue_int(rparam, sConfigSection, 'ISOLVER', isolver, 0)

    ! Fetch solver output level
    call parlst_getvalue_int(rparam, sConfigSection, 'IOUTPUT', ioutput, 0)

    ! Fetch maximum number of iterations
    call parlst_getvalue_int(rparam, sConfigSection, 'NMAXITER', nmaxiter, 100)

    ! Fetch solver tolerances
    call parlst_getvalue_double(rparam, sConfigSection, 'DEPSABS', depsAbs, 1E-11_DP)
    call parlst_getvalue_double(rparam, sConfigSection, 'DEPSREL', depsRel, 1E-8_DP)

    ! Fetch problem parameters
    call parlst_getvalue_double(rparam, sConfigSection, 'DNU', dnu, 1.0_DP)
    call parlst_getvalue_double(rparam, sConfigSection, 'DBETA1', dbeta1, 0.0_DP)
    call parlst_getvalue_double(rparam, sConfigSection, 'DBETA2', dbeta2, 0.0_DP)

    ! Fetch stabilisation parameters
    call parlst_getvalue_int(rparam, sConfigSection, 'ISTABIL', istabil, 0)
    call parlst_getvalue_int(rparam, sConfigSection, 'CLOCALH', clocalh, 0)
    call parlst_getvalue_double(rparam, sConfigSection, 'DUPSAM', dupsam, 1.0_DP)
    call parlst_getvalue_double(rparam, sConfigSection, 'DGAMMA', dgamma, 0.01_DP)

    ! Fetch relaxation parameter for CG-SSOR
    call parlst_getvalue_double(rparam, sConfigSection, 'DRELAX', drelax, 1.2_DP)

    ! Fetch fill-in level for ILU(k) preconditioner
    call parlst_getvalue_int(rparam, sConfigSection, 'IFILLIN', ifillin, 0)

    ! UCD export
    call parlst_getvalue_int(rparam, sConfigSection, 'IUCD', iucd, 0)

    ! Parse element and cubature
    celement = elem_igetID(selement)
    ccubature = cub_igetID(scubature)

    ! Get primary element
    cprimaryelement = elem_getPrimaryElement(celement)
    sprimaryelement = elem_getName(cprimaryelement)

    ! Get the shape of the element
    cshape = elem_igetShape(celement)

    ! Allocate arrays
    allocate(Derror(2,NLMIN:NLMAX))
    allocate(Dtimer(5,NLMIN:NLMAX))
    allocate(Istat(5,NLMIN:NLMAX))

    call output_separator(OU_SEP_STAR)
    call output_line('ELEMENT-DEBUGGER: 2D TEST #1')
    call output_line('============================')

    ! Print out that we are going to do:
    select case(itest)
    case(201)
      call output_line('System.............: L2-projection')
    case(202)
      call output_line('System.............: Poisson')
    case(203)
      call output_line('System.............: Convection-Diffusion')
      call output_line('DNU................: ' // trim(sys_sdEP(dnu,20,12)))
      call output_line('DBETA1.............: ' // trim(sys_sdEP(dbeta1,20,12)))
      call output_line('DBETA2.............: ' // trim(sys_sdEP(dbeta2,20,12)))
      select case(istabil)
      case(0)
        call output_line('Stabilisation......: none')
      case(1)
        call output_line('Stabilisation......: Streamline-Diffusion')
        call output_line('DUPSAM.............: ' // trim(sys_sdEP(dupsam,20,12)))
      case(2)
        call output_line('Stabilisation......: Jump-Stabilisation')
        call output_line('DGAMMA.............: ' // trim(sys_sdEP(dgamma,20,12)))
      case(3)
        call output_line('Stabilisation......: Streamline-Diffusion (kernel)')
        call output_line('DUPSAM.............: ' // trim(sys_sdEP(dupsam,20,12)))
        call output_line('CLOCALH............: ' // trim(sys_si(clocalh,4)))
      case default
        call output_line('Invalid ISTABIL parameter', &
          OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
        call sys_halt()
      end select
    case default
      call output_line('Invalid ITEST parameter', &
        OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end select
    select case(isolution)
    case(0)
      call output_line('Solution...........: u(x,y) = sin(pi*x) * sin(pi*y)')
    case(1)
      call output_line('Solution...........: u(x,y) = x')
    case(2)
      call output_line('Solution...........: u(x,y) = y')
    case(3)
      call output_line('Solution...........: u(x,y) = 16*x*(1-x)*y*(1-y)')
    case default
      call output_line('Invalid ISOLUTION parameter', &
        OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end select
    select case(cshape)
    case(BGEOM_SHAPE_TRIA)
      call output_line('Coarse Mesh........: TRIA.tri')
    case(BGEOM_SHAPE_QUAD)
      call output_line('Coarse Mesh........: QUAD.tri')
    case default
      call output_line('Element is not a valid 2D element!', &
        OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end select
    call output_line('NLMIN..............: ' // trim(sys_siL(NLMIN,4)))
    call output_line('NLMAX..............: ' // trim(sys_siL(NLMAX,4)))
    select case(idistType)
    case(0)
      ! no distortion => nothing else to print
    case(1)
      call output_line('Distortion Type....: index-based')
    case(2)
      call output_line('Distortion Type....: X-line-wise index-based')
    case(3)
      call output_line('Distortion Type....: Y-line-wise index-based')
    case default
      call output_line('Invalid IDISTTYPE parameter', &
        OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end select
    if(idistType .ne. 0) then
      call output_line('Distortion Level...: ' // trim(sys_siL(idistLevel,4)))
      call output_line('Mesh Distortion....: ' // trim(sys_sdL(ddist,8)))
    end if
    if((idistType .ge. 2) .and. (idistType .le. 3)) then
      call output_line('Mesh Distortion 2..: ' // trim(sys_sdL(ddist2,8)))
    end if
#ifdef USE_LARGEINT
    call output_line('Element............: ' // trim(selement) // &
                     ' (ID=' // trim(sys_siL(int(celement,I64),12)) // ')')
    call output_line('Primary element....: ' // trim(sprimaryelement) // &
                     ' (ID=' // trim(sys_siL(int(cprimaryelement,I64),12)) // ')')
#else
    call output_line('Element............: ' // trim(selement) // &
                     ' (ID=' // trim(sys_siL(celement,12)) // ')')
    call output_line('Primary element....: ' // trim(sprimaryelement) // &
                     ' (ID=' // trim(sys_siL(cprimaryelement,12)) // ')')
#endif
    call output_line('Cubature rule......: ' // trim(scubature) // &
                     ' (ID=' // trim(sys_siL(ccubature,12)) // ')')
    select case(isolver)
    case(0)
      call output_line('Solver.............: UMFPACK4')
    case(1)
      call output_line('Solver.............: CG-SSOR')
      call output_line('Relaxation.........: ' // trim(sys_sdL(drelax,8)))
    case(2)
      call output_line('Solver.............: BiCGStab-ILU(k)')
      if(ifillin .lt. 0) then
        call output_line('IFILLIN must not be less than 0', &
          OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg3d_1')
        call sys_halt()
      end if
      call output_line('Allowed Fill-In....: ' // trim(sys_siL(ifillin,4)))
    case default
      call output_line('Invalid ISOLVER parameter', &
        OU_CLASS_ERROR, OU_MODE_STD, 'elemdbg2d_1')
      call sys_halt()
    end select
    call output_line('Output Level.......: ' // trim(sys_siL(ioutput,4)))
    call output_line('Maximum Iter.......: ' // trim(sys_siL(nmaxiter,12)))
    call output_line('Absolute EPS.......: ' // trim(sys_sdEP(depsAbs,20,12)))
    call output_line('Relative EPS.......: ' // trim(sys_sdEP(depsRel,20,12)))
    call output_lbrk()

    ! Copy important parameters into quick-access arrays of the collection,
    ! these ones are needed by the callback functions.
    rcollect%IquickAccess(1) = itest
    rcollect%IquickAccess(2) = isolution
    rcollect%DquickAccess(1) = dnu
    rcollect%DquickAccess(2) = dbeta1
    rcollect%DquickAccess(3) = dbeta2

    ! Read in parametrisation
    select case(cshape)
    case(BGEOM_SHAPE_TRIA)
      call boundary_read_prm(rboundary, trim(spredir) // '/TRIA.prm')
    case(BGEOM_SHAPE_QUAD)
      call boundary_read_prm(rboundary, trim(spredir) // '/QUAD.prm')
    end select

    ! Loop over all levels
    do ilvl = NLMIN, NLMAX

      call output_line('Processing Level ' // trim(sys_siL(ilvl,4)) // '...')

      ! Start time measurement
      call stat_startTimer(rtimer,STAT_TIMERSHORT)

      ! Now read in the basic triangulation.
      select case(cshape)
      case(BGEOM_SHAPE_TRIA)
        call tria_readTriFile2D (rtriangulation, trim(spredir) // '/TRIA.tri', rboundary)
      case(BGEOM_SHAPE_QUAD)
        call tria_readTriFile2D (rtriangulation, trim(spredir) // '/QUAD.tri', rboundary)
      end select

      if(idistLevel .le. 0) then
        idistLvl = max(1,ilvl-idistLevel)
      else
        idistLvl = idistLevel
      end if

      if((idistLvl .le. ilvl) .and. (idistType .ne. 0)) then

        ! Refine up to distortion level
        call tria_quickRefine2LevelOrdering (idistLvl-1, rtriangulation,rboundary)

        ! Distort the mesh
        select case(idistType)
        case (1)
          ! index-based distortion
          call meshmod_disturbMesh (rtriangulation, ddist)

        case (2)
          ! X-line-wise index-based distortion
          call disto2d_distortQuadLineX(rtriangulation, ddist, ddist2)

        case (3)
          ! Y-line-wise index-based distortion
          call disto2d_distortQuadLineY(rtriangulation, ddist, ddist2)

        end select

        ! Refine up to current level
        if(idistLvl .lt. ilvl) then
          call tria_quickRefine2LevelOrdering (ilvl-idistLvl, rtriangulation,rboundary)
        end if

      else

        ! Refine up to current level
        call tria_quickRefine2LevelOrdering (ilvl-1, rtriangulation,rboundary)

      end if

      ! And create information about adjacencies and everything one needs from
      ! a triangulation.
      call tria_initStandardMeshFromRaw (rtriangulation,rboundary)

      ! Stop time measurement
      call stat_stopTimer(rtimer)
      Dtimer(1,ilvl) = rtimer%delapsedReal

      ! Start time measurement
      call stat_clearTimer(rtimer)
      call stat_startTimer(rtimer,STAT_TIMERSHORT)

      ! Set up discretisation
      call spdiscr_initBlockDiscr (rdiscretisation,1,rtriangulation, rboundary)
      call spdiscr_initDiscr_simple (rdiscretisation%RspatialDiscr(1), &
          celement, rtriangulation, rboundary)

      ! Set up a cubature info structure
      call spdiscr_createDefCubStructure(&
          rdiscretisation%RspatialDiscr(1), rcubatureInfo, int(ccubature,I32))

      ! Create matrix structure
      call lsysbl_createMatBlockByDiscr(rdiscretisation, rmatrix)
      if ((itest .eq. 203) .and. (istabil .eq. 2)) then
        ! Extended matrix stencil
        call bilf_createMatrixStructure(rdiscretisation%RspatialDiscr(1),&
                                 LSYSSC_MATRIX9,rmatrix%RmatrixBlock(1,1),&
                                 cconstrType=BILF_MATC_EDGEBASED)
      else
        call bilf_createMatrixStructure(rdiscretisation%RspatialDiscr(1),&
                                 LSYSSC_MATRIX9,rmatrix%RmatrixBlock(1,1))
      end if

      ! Create vectors
      call lsysbl_createVecBlockIndMat(rmatrix, rvecSol, .true.)
      call lsysbl_createVecBlockIndMat(rmatrix, rvecRhs, .true.)
      call lsysbl_createVecBlockIndMat(rmatrix, rvecTmp, .true.)

      ! Set up discrete BCs
      if(itest .ne. 201) then
        call bcasm_initDiscreteBC(rdiscreteBC)
        call boundary_createRegion(rboundary,1,0,rboundaryRegion)
        call bcasm_newDirichletBConRealBD (rdiscretisation,1,&
             rboundaryRegion,rdiscreteBC,getBoundaryValues2D,rcollect)

        ! Assign BCs
        rmatrix%p_rdiscreteBC => rdiscreteBC
        rvecSol%p_rdiscreteBC => rdiscreteBC
        rvecRhs%p_rdiscreteBC => rdiscreteBC
      end if

      ! Store statistics
      Istat(1,ilvl) = rmatrix%NEQ
      Istat(2,ilvl) = rmatrix%rmatrixBlock(1,1)%NA
      Istat(3,ilvl) = rtriangulation%NVT
      Istat(4,ilvl) = rtriangulation%NMT
      Istat(5,ilvl) = rtriangulation%NEL

      ! Stop time measurement
      call stat_stopTimer(rtimer)
      Dtimer(2,ilvl) = rtimer%delapsedReal

      ! Start time measurement
      call stat_clearTimer(rtimer)
      call stat_startTimer(rtimer,STAT_TIMERSHORT)

      ! Assemble system
      select case(itest)
      case(201)
        ! Assemble Mass matrix
        call stdop_assembleSimpleMatrix(rmatrix%RmatrixBlock(1,1), &
                                        DER_FUNC2D, DER_FUNC2D,&
                                        rcubatureInfo=rcubatureInfo)

      case(202)
        ! Assemble Laplace matrix
        call stdop_assembleLaplaceMatrix(rmatrix%RmatrixBlock(1,1),&
                                         rcubatureInfo=rcubatureInfo)

      case(203)
        ! Assemble Laplace matrix
        call stdop_assembleLaplaceMatrix(rmatrix%RmatrixBlock(1,1),.true.,dnu,&
                                         rcubatureInfo=rcubatureInfo)

        ! Stabilisation?
        select case (istabil)
        case (0)
          ! Assemble convective operator, sum up to the Laplace operator
          rform%itermcount = 2
          rform%Idescriptors(1,1) = DER_DERIV_X
          rform%Idescriptors(2,1) = DER_FUNC
          rform%Idescriptors(1,2) = DER_DERIV_Y
          rform%Idescriptors(2,2) = DER_FUNC
          rform%Dcoefficients(1) = dbeta1
          rform%Dcoefficients(2) = dbeta2
          call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(1,1),&
                                       rcubatureInfo)

        case (1)
          ! Assemble the convection directly including the stabilisation
          rconfigSD%dupsam = dupsam
          rconfigSD%dnu = dnu
          call elemdbg2d_sd (dbeta1,dbeta2,rconfigSD,rmatrix%RmatrixBlock(1,1))

        case (2)
          ! Assemble convective operator, sum up to the Laplace operator
          rform%itermcount = 2
          rform%Idescriptors(1,1) = DER_DERIV_X
          rform%Idescriptors(2,1) = DER_FUNC
          rform%Idescriptors(1,2) = DER_DERIV_Y
          rform%Idescriptors(2,2) = DER_FUNC
          rform%Dcoefficients(1) = dbeta1
          rform%Dcoefficients(2) = dbeta2
          call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(1,1),&
                                       rcubatureInfo)

          ! Assemble the jump stabilisation
          rconfigEOJ%dgamma = dgamma
          rconfigEOJ%dgammastar = dgamma
          rconfigEOJ%dnu = dnu
          call conv_JumpStabilisation2d (rconfigEOJ, CONV_MODMATRIX, rmatrix%RmatrixBlock(1,1))

          ! Subtract the boundary edges from the matrix.
          rconfigEOJ%dtheta = -1.0_DP

          allocate (p_Iedges(rtriangulation%NMT))
          allocate (p_Itemp(rtriangulation%NMT))

          ! Loop over the edges and boundary components
          do ibc = 1,boundary_igetNBoundComp(rboundary)
            do iedge = 1,boundary_igetNsegments(rboundary, ibc)

              ! Get a region identifying that boundary edge
              call boundary_createRegion(rboundary,ibc,iedge,rboundaryRegion)

              ! Get triangulation edges on that boundary edge
              call bcasm_getEdgesInBdRegion (rtriangulation,rboundaryRegion, &
                  nedgecount, p_Iedges, p_Itemp)

              ! Subtract the jump
              call conv_JumpStabilisation2d(rconfigEOJ,CONV_MODMATRIX,rmatrix%RmatrixBlock(1,1), &
                  InodeList=p_Iedges(1:nedgecount))

            end do
          end do

          deallocate (p_Iedges,p_Itemp)

          rconfigEOJ%dtheta = 1.0_DP

        case (3)
          ! Prepare a velocity field resembling our convection
          call spdiscr_initBlockDiscr (rdiscretisationVel,2,rtriangulation, rboundary)
          call spdiscr_duplicateDiscrSc (rdiscretisation%RspatialDiscr(1), &
              rdiscretisationVel%RspatialDiscr(1), .true.)
          call spdiscr_duplicateDiscrSc (rdiscretisation%RspatialDiscr(1), &
              rdiscretisationVel%RspatialDiscr(2), .true.)

          ! Create the velocity vector
          call lsysbl_createVectorBlock (rdiscretisationVel,rvelocityVector)
          call lsyssc_clearVector (rvelocityVector%RvectorBlock(1),dbeta1)
          call lsyssc_clearVector (rvelocityVector%RvectorBlock(2),dbeta2)

          ! Assemble the convection using the kernel stabilisation
          rconfigSD%dupsam = dupsam
          rconfigSD%dnu = dnu
          rconfigSD%clocalh = clocalh
          call conv_streamlineDiffusionBlk2d ( &
              rvelocityVector, rvelocityVector, 1.0_DP, 0.0_DP,&
              rconfigSD, CONV_MODMATRIX,rmatrix)

          ! Release all that temporary stuff.
          call lsysbl_releaseVector (rvelocityVector)
          call spdiscr_releaseBlockDiscr (rdiscretisationVel)

        end select

      end select

      ! Assemble RHS vector
      rlinform%itermCount = 1
      rlinform%Idescriptors(1) = DER_FUNC2D
      call linf_buildVectorScalar (rlinform,.true.,rvecRhs%RvectorBlock(1),&
          rcubatureInfo,coeff_RHS2D,rcollect)

      ! In any case except for L2-projection, filter the system
      if(itest .ne. 201) then
        ! Implement BCs
        call vecfil_discreteBCrhs (rvecRhs)
        call vecfil_discreteBCsol (rvecsol)
        call matfil_discreteBC (rmatrix)
      end if

      ! Stop time measurement
      call stat_stopTimer(rtimer)
      Dtimer(3,ilvl) = rtimer%delapsedReal

      ! Start time measurement
      call stat_clearTimer(rtimer)
      call stat_startTimer(rtimer,STAT_TIMERSHORT)

      ! Set up the solver
      select case(isolver)
      case (0)
        ! UMFPACK solver
        call linsol_initUMFPACK4(p_rsolver)

      case (1)
        ! CG-SSOR[1.2] solver
        nullify(p_rprecond)
        call linsol_initSSOR(p_rprecond,drelax)
        call linsol_initCG(p_rsolver, p_rprecond)

      case (2)
        ! BiCGStab-ILU(k) solver with RCMK
        nullify(p_rprecond)
        call linsol_initMILUs1x1(p_rprecond,ifillin,0.0_DP)
        call linsol_initBiCGStab(p_rsolver, p_rprecond)

        ! Calculate a RCMK permutation
        call sstrat_initBlockSorting (rsortStrategy,rdiscretisation)
        call sstrat_initRevCuthillMcKee(rsortStrategy%p_Rstrategies(1),rmatrix%RmatrixBlock(1,1))

        ! Attach the sorting strategy
        call lsysbl_setSortStrategy (rmatrix,rsortStrategy,rsortStrategy)
        call lsysbl_setSortStrategy (rvecSol,rsortStrategy)
        call lsysbl_setSortStrategy (rvecRhs,rsortStrategy)

        ! Permute matrix and vectors
        call lsysbl_sortMatrix(rmatrix,.true.)
        call lsysbl_sortVector(rvecSol,.true., rvecTmp%RvectorBlock(1))
        call lsysbl_sortVector(rvecRhs,.true., rvecTmp%RvectorBlock(1))

      end select

      p_rsolver%ioutputLevel = ioutput
      p_rsolver%depsRel = depsRel
      p_rsolver%depsAbs = depsAbs
      p_rsolver%nmaxiterations = nmaxiter

      Rmatrices = (/rmatrix/)
      call linsol_setMatrices(p_rsolver,Rmatrices)
      call linsol_initStructure (p_rsolver, ierror)
      if (ierror .ne. LINSOL_ERR_NOERROR) stop
      call linsol_initData (p_rsolver, ierror)
      if (ierror .ne. LINSOL_ERR_NOERROR) stop

      ! Solve the system
      call linsol_solveAdaptively (p_rsolver,rvecSol,rvecRhs,rvecTmp)

      ! If necessary, unsort the solution vector
      call lsyssc_sortVector (rvecSol%RvectorBlock(1), .false., rvecTmp%RvectorBlock(1))

      ! Stop time measurement
      call stat_stopTimer(rtimer)
      Dtimer(4,ilvl) = rtimer%delapsedReal

      ! Start time measurement
      call stat_clearTimer(rtimer)
      call stat_startTimer(rtimer,STAT_TIMERSHORT)

      ! Calculate the errors to the reference function
      rerror%p_RvecCoeff => rvecSol%RvectorBlock(1:1)
      rerror%p_DerrorL2 => Derror(1:1,ilvl)
      rerror%p_DerrorH1 => Derror(2:2,ilvl)
      call pperr_scalarVec(rerror, getReferenceFunction2D, rcollect, rcubatureInfo)

      ! Print the errors
      call output_line('Errors (L2/H1): ' // &
          trim(sys_sdEP(Derror(1,ilvl),20,12)) // &
          trim(sys_sdEP(Derror(2,ilvl),20,12)))

      ! Do we perform UCD output?
      if (iucd .gt. 0) then

        ! What type of output?
        select case(iucd)
        case (1)
          call ucd_startGMV (rexport,UCD_FLAG_STANDARD,rtriangulation,&
               trim(sucddir) // '/sol2d_' // trim(sys_siL(ilvl,5)) // '.gmv')

        case (2)
          call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
             trim(sucddir) // '/sol2d_' // trim(sys_siL(ilvl,5)) // '.vtk')

        end select

        ! Project the solution to the vertices
        call ucd_addVectorByVertex (rexport,'sol',UCD_VAR_STANDARD, rvecSol%RvectorBlock(1))

        ! Write and release ucd
        call ucd_write (rexport)
        call ucd_release (rexport)

      end if

      ! Stop time measurement
      call stat_stopTimer(rtimer)
      Dtimer(5,ilvl) = rtimer%delapsedReal

      ! Clean up this level
      call linsol_doneData (p_rsolver)
      call linsol_doneStructure (p_rsolver)
      call linsol_releaseSolver (p_rsolver)
      call lsysbl_releaseVector (rvecTmp)
      call lsysbl_releaseVector (rvecSol)
      call lsysbl_releaseVector (rvecRhs)
      call lsysbl_releaseMatrix (rmatrix)
      call sstrat_doneBlockSorting (rsortStrategy)
      call bcasm_releaseDiscreteBC (rdiscreteBC)
      call spdiscr_releaseBlockDiscr(rdiscretisation)
      call tria_done (rtriangulation)

    end do ! ilvl

    ! Release the domain
    call boundary_release (rboundary)

    ! Print some statistics
    call output_separator(OU_SEP_MINUS)
    call output_line('Level         NEQ        NNZE         NVT' // &
                     '         NMT         NEL')
    do ilvl = NLMIN, NLMAX
      call output_line(trim(sys_si(ilvl,5)) // &
          trim(sys_si(Istat(1,ilvl),12)) // &
          trim(sys_si(Istat(2,ilvl),12)) // &
          trim(sys_si(Istat(3,ilvl),12)) // &
          trim(sys_si(Istat(4,ilvl),12)) // &
          trim(sys_si(Istat(5,ilvl),12)))
    end do ! ilvl

    ! Print out the L2- and H1-errors on each level
    call output_separator(OU_SEP_MINUS)
    call output_line('Level     L2-error            H1-error')
    do ilvl = NLMIN, NLMAX
      call output_line(trim(sys_si(ilvl,5)) // '   ' // &
          trim(sys_sdEP(Derror(1,ilvl),20,12)) // &
          trim(sys_sdEP(Derror(2,ilvl),20,12)))
    end do ! ilvl

    ! Print out the L2- and H1- factors for each level pair
    if(NLMAX .gt. NLMIN) then
      call output_separator(OU_SEP_MINUS)
      call output_line('Level     L2-factor           H1-factor')
      do ilvl = NLMIN+1, NLMAX

        ! avoid division by zero here
        daux1 = 0.0_DP
        daux2 = 0.0_DP
        if(abs(Derror(1,ilvl)) .gt. SYS_EPSREAL_DP) &
          daux1 = Derror(1,ilvl-1)/Derror(1,ilvl)
        if(abs(Derror(2,ilvl)) .gt. SYS_EPSREAL_DP) &
          daux2 = Derror(2,ilvl-1)/Derror(2,ilvl)

        ! print out the factors
        call output_line(trim(sys_si(ilvl,5)) // '   ' // &
            trim(sys_sdEP(daux1,20,12)) // &
            trim(sys_sdEP(daux2,20,12)))
      end do ! ilvl
    end if

#ifdef USE_TIMER
    ! Print out the time measurements for each level
    call output_separator(OU_SEP_MINUS)
    call output_line('Level    CPU_Tria   CPU_Discr   CPU_Assem' // &
                     '   CPU_Solve    CPU_Post')

    do ilvl = NLMIN, NLMAX
      call output_line(trim(sys_si(ilvl,5)) // &
          trim(sys_sdEP(Dtimer(1,ilvl),12,4)) // &
          trim(sys_sdEP(Dtimer(2,ilvl),12,4)) // &
          trim(sys_sdEP(Dtimer(3,ilvl),12,4)) // &
          trim(sys_sdEP(Dtimer(4,ilvl),12,4)) // &
          trim(sys_sdEP(Dtimer(5,ilvl),12,4)))
    end do ! ilvl

    ! Print out the timing factors for each level pair
    if(NLMAX .gt. NLMIN) then
      call output_separator(OU_SEP_MINUS)
      call output_line('Level   Tria-fact  Discr-fact  Assem-fact' // &
                       '  Solve-fact   Post-fact')
      do ilvl = NLMIN+1, NLMAX

        ! avoid division by zero here
        daux1 = 0.0_DP
        daux2 = 0.0_DP
        daux3 = 0.0_DP
        daux4 = 0.0_DP
        daux5 = 0.0_DP

        if(abs(Dtimer(1,ilvl-1)) .gt. SYS_EPSREAL_DP) &
          daux1 = Dtimer(1,ilvl)/Dtimer(1,ilvl-1)
        if(abs(Dtimer(2,ilvl-1)) .gt. SYS_EPSREAL_DP) &
          daux2 = Dtimer(2,ilvl)/Dtimer(2,ilvl-1)
        if(abs(Dtimer(3,ilvl-1)) .gt. SYS_EPSREAL_DP) &
            daux3 = Dtimer(3,ilvl)/Dtimer(3,ilvl-1)
        if(abs(Dtimer(4,ilvl-1)) .gt. SYS_EPSREAL_DP) &
          daux4 = Dtimer(4,ilvl)/Dtimer(4,ilvl-1)
        if(abs(Dtimer(5,ilvl-1)) .gt. SYS_EPSREAL_DP) &
          daux5 = Dtimer(5,ilvl)/Dtimer(5,ilvl-1)

        ! print out the factors
        call output_line(trim(sys_si(ilvl,5)) // &
            trim(sys_sdEP(daux1,12,4)) // &
            trim(sys_sdEP(daux2,12,4)) // &
            trim(sys_sdEP(daux3,12,4)) // &
            trim(sys_sdEP(daux4,12,4)) // &
            trim(sys_sdEP(daux5,12,4)))
      end do ! ilvl
    end if
#endif

    ! Deallocate arrays
    deallocate(Istat)
    deallocate(Dtimer)
    deallocate(Derror)

  end subroutine

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
      subroutine dummy

c     Check translation mechanism when variable are not visible in the
c     current procedure.

c     Check that information generated by tests in transformer is
c     linked to old or new values

      common /foo/i,j,ndummy(2), m, n

      call bar

      print *, i, j, m, m

      end

      subroutine bar
      common /foo/i,j,k,l,m,n
      if(i.gt.j) then
         i = i + 1
         j = j + 2
         k = k + 3
         l = l + 4
      else
         stop
      endif

      if(m.eq.n) then
         print *, m-n
      else
         stop
      endif

      end


text:
program alloc
implicit none
integer, parameter :: n = 2
real :: x(n)
real, allocatable :: y(:)
print*,"n =",n
call random_number(x)
print*,"x =",x
allocate (y(n)) ; print "(a)","allocate (y(n))"
print*,"y =",y ! undefined
deallocate (y) ! if allocated, must deallocate before allocate
allocate (y(n),source=2.0) ! source must be scalar of have size n
print "(a)","allocate (y(n),source=2.0)"
print*,"y =",y
deallocate (y)
allocate (y(n),source=[3.0,4.0])
print "(a)","allocate (y(n),source=[3.0,4.0])"
print*,"y =",y
deallocate (y)
allocate (y,mold=x) ;  print "(a)","allocate (y,mold=x)"
print*,"y =",y ! undefined
deallocate (y)
allocate (y,source=x) ; print "(a)","allocate (y,source=x)"
print*,"y =",y ! y equals x
y = [-1.0,x] ! valid even if y is allocated
print "(a)","y = [-1.0,x]"
print*,"y =",y
associate (z => 2*x) ! allocates z to size(x), fills with 2*x
print "(a)","associate (z => 10*x)"
print*,"z =",z
end associate
end program alloc
! sample output:
!  n =           2
!  x =  0.880050063      0.891854525
!
! allocate (y(n))
!  y =   2.37091988E+36   7.53898574E-43
!
! allocate (y(n),source=2.0)
!  y =   2.00000000       2.00000000
!
! allocate (y(n),source=[3.0,4.0])
!  y =   3.00000000       4.00000000
!
! allocate (y,mold=x)
!  y =   2.37080579E+36   7.53898574E-43
!
! allocate (y,source=x)
!  y =  0.880050063      0.891854525
!
! y = [-1.0,x]
!  y =  -1.00000000      0.880050063      0.891854525
!
! associate (z => 10*x)
!  z =   1.76010013       1.78370905

max_stars_repo_name: awvwgk/FortranTip

max_issues_repo_name: awvwgk/FortranTip

max_forks_repo_name: awvwgk/FortranTip


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 09.01/01                              *
C  *    TEST TITLE : Testing the error handling mode       *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      INTEGER         POFF,      PON
      PARAMETER      (POFF=0,    PON=1)

      INTEGER    HNDMOD

      CALL INITGL ('09.01/01')

      CALL XPOPPH (ERRFIL, MEMUN)

      CALL SETMSG ('2 3', 'After opening PHIGS, <inquire error ' //
     1             'handling mode> should return ON.')

      CALL PQERHM (ERRIND, HNDMOD)
      CALL IFPF (ERRIND.EQ.0 .AND. HNDMOD.EQ.PON)
C
      CALL SETMSG ('1 3', 'After <set error handling mode> to OFF, ' //
     1             '<inquire error handling mode> should return OFF.')

      CALL PSERHM (POFF)
      CALL PQERHM (ERRIND, HNDMOD)
      CALL IFPF (ERRIND.EQ.0 .AND. HNDMOD.EQ.POFF)

      CALL SETMSG ('1 3', 'After <set error handling mode> to ON, ' //
     1             '<inquire error handling mode> should return ON.')

      CALL PSERHM (PON)
      CALL PQERHM (ERRIND, HNDMOD)
      CALL IFPF (ERRIND.EQ.0 .AND. HNDMOD.EQ.PON)

      CALL ENDIT

      END


text:
        !COMPILER-GENERATED INTERFACE MODULE: Tue May  2 15:02:02 2017
        MODULE PHY_NPZDCONT__genmod
          INTERFACE
            SUBROUTINE PHY_NPZDCONT(NO3,PAR_,TEMP_,FE,PMU,MUNET,DMUDL,  &
     &D2MUDL2,D3MUDL3,D4MUDL4,SI,FN,THETA,QN)
              REAL(KIND=8), INTENT(IN) :: NO3
              REAL(KIND=8), INTENT(IN) :: PAR_
              REAL(KIND=8), INTENT(IN) :: TEMP_
              REAL(KIND=8), INTENT(IN) :: FE
              REAL(KIND=8), INTENT(IN) :: PMU
              REAL(KIND=8), INTENT(OUT) :: MUNET
              REAL(KIND=8), INTENT(OUT) :: DMUDL
              REAL(KIND=8), INTENT(OUT) :: D2MUDL2
              REAL(KIND=8), INTENT(OUT) :: D3MUDL3
              REAL(KIND=8), INTENT(OUT) :: D4MUDL4
              REAL(KIND=8), INTENT(OUT) :: SI
              REAL(KIND=8), INTENT(OUT) :: FN
              REAL(KIND=8), INTENT(OUT) :: THETA
              REAL(KIND=8), INTENT(OUT) :: QN
            END SUBROUTINE PHY_NPZDCONT
          END INTERFACE
        END MODULE PHY_NPZDCONT__genmod

max_stars_repo_name: BingzhangChen/NPZDFeCONT

max_issues_repo_name: BingzhangChen/NPZDFeCONT

max_forks_repo_name: BingzhangChen/NPZDFeCONT


text:
c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine ewkb2(ji,vi,mm,erotvib,rin,rout,nsurf,symb,rguess)

c This subroutine is specialized for the atom-diatom initial conditions.
c It computes the WKB energy for the rovibrational state (vi,ji).
c INPUT
c ji = initial rot state of diatom
c vi = initial vib state of the diatom
c mm = masses of the atoms
c OUTPUT
c erotvib = rivibrational energy for (vi,ji) state

      implicit none
      include 'param.f'

      integer arri,nsurf
      double precision mm(mnat),erotvib,xj,ji,vi
      character*2 symb(mnat)

c     local
      integer i,j,JMAX
      double precision rmin,emin,emax,xv,f,fmid,dx,rtbis_vib,etry,
     & rin,rout,rguess,etmp

      xj = ji

c      write(6,*)"aj in ewkb2"

c Need to bracket energy for (vi,ji) state
c     find minimum of diatom with rotation
      call diamin2(rmin,emin,xj,mm,nsurf,symb,rguess)
c     get asymptotic energy
      call diapot2(30.d0,emax,0.d0,mm,nsurf,symb)
c      write(6,*)"Minimum energy for diatom ",
c     &  " is ",emin*autoev," eV at ",rmin*autoang," A",xj
c      write(6,*)"Asym energy is ",emax*autoev," eV"
c      write(6,*)

c Now determine energy of (vi,ji) state
c     compute vibrational action at E = emax
      rin=0.5d0
      rout=30.d0
      call vwkb2(mm,emin,xj,xv,rin,rout,nsurf,symb)
      f = xv - vi
c      write(6,*)"vibrational action at emin = ",xv
c     compute vibrational action at E = emin
      rin=0.5d0
      rout=30.d0
      etmp=0.99d0*emax
      call vwkb2(mm,etmp,xj,xv,rin,rout,nsurf,symb)
      fmid = xv - dble(vi)
c      write(6,*)"vibrational action at 0.99 emax = ",xv

      if (f*fmid.ge.0.d0) then
          write(6,1000)
          stop
      end if
      if (f.lt.0.d0) then
          rtbis_vib=emin
          dx=etmp-emin
      else
          rtbis_vib=etmp
          dx=emin-etmp
      end if

      JMAX=100
      do 11 j = 1, JMAX
          dx=dx*0.5d0
          etry=rtbis_vib+dx
          rin=0.5d0
          rout=30.d0
          call vwkb2(mm,etry,xj,xv,rin,rout,nsurf,symb)
c          write(6,*)"trying...",etry*27.211d0
c          write(6,*)"vibrational action at etry = ",xv,vi
          fmid = xv - vi
          if (fmid.le.0.d0) rtbis_vib=etry
          if (abs(dx).lt.1.d-10.or.fmid.eq.0.d0) go to 12
   11 continue
      write(6,1010)
      stop
 1000 format(2x,'root must be bracketed in rtbis_vib')
 1010 format(2x,'Too many bisections in rtbis_vib')

   12 continue

      erotvib = rtbis_vib

      return

      end

max_stars_repo_name: kevinmooreiii/DiNT

max_issues_repo_name: kevinmooreiii/DiNT

max_forks_repo_name: kevinmooreiii/DiNT


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine PSE_ppsi_DFT(ik)
  use global_variables
  use PSE_variables
  implicit none
  integer :: ik
  integer :: i,ix,iy,iz
  real(8) :: kAc2_2
  integer :: ilma,ia,j
  complex(8) :: uVpsi

  kAc2_2=sum(kAc_Cvec(:,ik)**2)*0.5

  do i=1,NL
    zft2(iLx(1,i),iLx(2,i),iLx(3,i))=tpsi(i)
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(cexp_x3(:,iz)*zft2(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(cexp_x2(:,iy)*zft1(ix,:,iz))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(cexp_x1(:,ix)*zft2(:,iy,iz))
  end do
  end do
  end do

  zft1(:,:,:)=( &
    -Epdir_1(1)*Grad_x_zI(:,:,:) &
    -Epdir_1(2)*Grad_y_zI(:,:,:) &
    -Epdir_1(3)*Grad_z_zI(:,:,:) &
    )*zft1(:,:,:)/dble(NL1*NL2*NL3)

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x3(:,iz)*zft1(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(exp_x2(:,iy)*zft2(ix,:,iz))
  end do
  end do
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x1(:,ix)*zft1(:,iy,iz))
  end do
  end do
  end do

  do i=1,NL
    htpsi(i)=zft2(iLx(1,i),iLx(2,i),iLx(3,i))
  end do

  htpsi=htpsi+( &
    +Epdir_1(1)*kAc_Cvec(1,ik) &
    +Epdir_1(2)*kAc_Cvec(2,ik) &
    +Epdir_1(3)*kAc_Cvec(3,ik) &
    )*tpsi
  return

  return
end subroutine PSE_ppsi_DFT
!-----------------------------------------------------------
subroutine PSE_ppsi_DFT_3d(ik)
  use global_variables
  use PSE_variables
  implicit none
  integer :: ik
  integer :: i,ix,iy,iz
  real(8) :: kAc2_2
  integer :: ilma,ia,j
  complex(8) :: uVpsi

  kAc2_2=sum(kAc_Cvec(:,ik)**2)*0.5

  do i=1,NL
    zft2(iLx(1,i),iLx(2,i),iLx(3,i))=tpsi(i)
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(cexp_x3(:,iz)*zft2(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(cexp_x2(:,iy)*zft1(ix,:,iz))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft4(ix,iy,iz)=sum(cexp_x1(:,ix)*zft2(:,iy,iz))
  end do
  end do
  end do

!== x-direction: Start==
  zft1(:,:,:)=( &
    -Grad_x_zI(:,:,:) &
    )*zft4(:,:,:)/dble(NL1*NL2*NL3)

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x3(:,iz)*zft1(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(exp_x2(:,iy)*zft2(ix,:,iz))
  end do
  end do
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x1(:,ix)*zft1(:,iy,iz))
  end do
  end do
  end do

  do i=1,NL
    pitpsi_3d(i,1)=zft2(iLx(1,i),iLx(2,i),iLx(3,i))
  end do

  pitpsi_3d(:,1)=pitpsi_3d(:,1)+kAc_Cvec(1,ik)*tpsi

!== x-direction: End==

!== y-direction: Start==
  zft1(:,:,:)=( &
    -Grad_y_zI(:,:,:) &
    )*zft4(:,:,:)/dble(NL1*NL2*NL3)

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x3(:,iz)*zft1(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(exp_x2(:,iy)*zft2(ix,:,iz))
  end do
  end do
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x1(:,ix)*zft1(:,iy,iz))
  end do
  end do
  end do

  do i=1,NL
    pitpsi_3d(i,2)=zft2(iLx(1,i),iLx(2,i),iLx(3,i))
  end do

  pitpsi_3d(:,2)=pitpsi_3d(:,2)+kAc_Cvec(2,ik)*tpsi

!== y-direction: End==

!== z-direction: Start==
  zft1(:,:,:)=( &
    -Grad_z_zI(:,:,:) &
    )*zft4(:,:,:)/dble(NL1*NL2*NL3)

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x3(:,iz)*zft1(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(exp_x2(:,iy)*zft2(ix,:,iz))
  end do
  end do
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x1(:,ix)*zft1(:,iy,iz))
  end do
  end do
  end do

  do i=1,NL
    pitpsi_3d(i,3)=zft2(iLx(1,i),iLx(2,i),iLx(3,i))
  end do

  pitpsi_3d(:,3)=pitpsi_3d(:,3)+kAc_Cvec(3,ik)*tpsi

!== z-direction: End==

  return
end subroutine PSE_ppsi_DFT_3d


text:
The Teaching and Research Winery is in the second phase of construction for the Robert Mondavi Institute for Wine and Food Science complex.

The Brewing and Food Science Laboratory is funded by a http://www.dateline.ucdavis.edu/dl_detail.lasso?id6974 $5 million donation from AnheuserBusch.

 Features

 Technology
Housed inside of the research winery are 152 research size fermenters, each wirelessly transmitting temperature and Brix data to a central computer. Each 200 liter fermenter is constructed of stainless steel and has a remote controlled, programmable pump allowing each fermenter to be programmed with a different pumpover regime. The fermenters and the wireless control system were donated by T.J. Rogers of http://www.cypress.com/ Cypress Semiconductor Corp.

 LEED Platinum Status

The winery was awarded LEED Platinum Status by the http://www.usgbc.org/ U.S Green Building Council. The Winery one of two LEED Platinum buildings managed by UC Davis (the other is the http://terc.ucdavis.edu/facilities/tces/index.html Tahoe Center for Environmental Studies) and one of only two in the UC system (the other is http://www.bren.ucsb.edu/ Bren Hall at UC Santa Barbara). The building received http://www.news.ucdavis.edu/search/news_detail.lasso?id9720 60 points, surpassing the 52 points needed for Platinum certification.

http://www.news.ucdavis.edu/search/news_detail.lasso?id8809 UC Davis News & Information Article on the final bid process
http://wineserver.ucdavis.edu/content.php?id726 Viticulture and Oenology Department Statement on the Bid Process
http://www.pressdemocrat.com/article/20110316/WIRE/103161008 Santa Rosa PressDemocrat article on the winery

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


module fv3geom_constants_mod

use, intrinsic :: iso_c_binding

implicit none

integer,              public, parameter :: kind_real = c_double
real(kind=kind_real), public, parameter :: pi = 3.1415926535897931_kind_real
real(kind=kind_real), public, parameter :: torad = pi/180.0_kind_real
real(kind=kind_real), public, parameter :: todeg = 180.0_kind_real/pi
real(kind=kind_real), public, parameter :: radius = 6.3712e+6_kind_real

end module fv3geom_constants_mod


text:
! { dg-do compile }
subroutine foo(i) ! { dg-error "DATA attribute" }
  integer i /10/
end subroutine foo

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
Library has multiple meanings.  You are probably looking for information on one of the following:

  Davis Branch Library  The local public library
  Woodland Public Library  public library in Woodland, independent from the Yolo County system.
  Yolo County Library The Yolo County Library system, which includes the Davis branch library, along with several others in smaller towns in the county.
  UC Davis Libraries
  Campus Libraries.  Open to the general public.
    Shields Library  The main campus library  all the others are pretty self explanatory.
    Health Sciences Library
    Law Library
    Physical Sciences and Engineering Library
    Agricultural and Resource Economics Library
    Music Building The Music Library
  UCDMC Sacramento Campus Library
   http://www.lib.ucdavis.edu/dept/hsl/about/maps/index.php?mapmcl Blaisdell Medical Library
  The Central Davis Library in a Box is one of multiple free, community Little Free Libraries in Davis open 24/7 where anyone can go to borrow or donate books.
  The Davis Toy Library and Woodland Toy Library lend toys
  The East Davis Library in a Box is one of multiple free, community Little Free Libraries in Davis open 24/7 where anyone can go to borrow or donate books.
  The Stevenson Bridge Library in a Box is one of multiple free, community Little Free Libraries in Yolo open 24/7 where anyone can go to borrow or donate books.
  Child Care Services Resource Library
  The Library a now departed arcade with a witty name formerly located on G Street.
  Geothermal Resources Council has one of the most comprehensive collections of geothermal journals, papers, books, and maps. Members and nonmembers alike may search the OnLine library database and request noncopyrighted documents. Visitors to the reference library located in the office are welcome. Anyone interested in geology and geothermal topics would benefit.

This is a Disambiguation disambiguation page  a navigational aid which lists other pages that might otherwise share the same title. If an article link referred you here, you might want to go back and fix it to point directly to the intended page.


text:
      MODULE el1_I
      INTERFACE
!
      SUBROUTINE EL1(JJA,JJB,JA,JB,IIRE,ICOLBREI)
      INTEGER, INTENT(IN) :: JJA,JJB,JA,JB,IIRE,ICOLBREI
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
!*robodoc*m* CGPACK/cgca_m1clock
!  NAME
!    cgca_m1clock
!  SYNOPSIS

!$Id: cgca_m1clock.f90 379 2017-03-22 09:57:10Z mexas $

module cgca_m1clock

!  DESCRIPTION
!    Module with timing clocks
!  AUTHOR
!    Luis Cebamanos, modified by Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  CONTAINS
!    Public functions:
!    cgca_benchtime
!  SOURCE

  implicit none
  private
  public :: cgca_benchtime

  integer, parameter :: dp = kind(1.0d0),                              &
    int32kind = selected_int_kind( 9),                                 &
    int64kind = selected_int_kind(18),                                 &
    intkind = int64kind

  logical,       save :: firstcall = .true.
  real(kind=dp), save :: ticktime = 0.0_dp

!
!  Select high resolution clock
!

  integer(kind = intkind) :: count, rate

contains

real(kind=dp) function benchtick()

  if (firstcall) then

     firstcall = .false.
     call system_clock(count, rate)
     ticktime = 1.0_dp / real(rate, kind=dp)

  end if

  benchtick = ticktime

end function benchtick

!*roboend*

!*robodoc*s* cgca_m1clock/cgca_benchtime
!  NAME
!    cgca_benchtime
!  SYNOPSIS

real(kind=dp) function cgca_benchtime()

!  SOURCE

  real(kind=dp) :: dummy

! Ensure clock is initialised

  if (firstcall) dummy = benchtick()

  call system_clock(count)

  cgca_benchtime  = real(count, kind=dp)*ticktime

end function cgca_benchtime

!*roboend*

end module cgca_m1clock

max_stars_repo_name: lcebaman/casup

max_issues_repo_name: lcebaman/casup

max_forks_repo_name: lcebaman/casup