text:
      subroutine fix_small_tets(npoints,ntets,epsilon,nlsttts)
C
C#######################################################################
C
C     PURPOSE -
C
C   This routine finds tets with small volumes and tries to fix them
C   by inserting a point into the mesh at the center of the element
C
C     INPUT ARGUMENTS -
C
C   npoints -- number of nodes in the mesh
C   ntets -- number of elements in the mesh
C
C     OUTPUT ARGUMENTS -
C
C   nlsttts will contain the number of nodes to be inserted
C
C
C     CHANGE HISTORY -
C
C        $Log: fix_small_tets.f,v $
C        Revision 2.00  2007/11/05 19:45:55  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.3   08 Feb 2006 14:35:34   dcg
CPVCS    "enforce lower case - add external statements for shift routines
CPVCS    these changes needed to compile with absoft pro fortran"
CPVCS

CPVCS       Rev 1.2   30 Sep 2004 09:48:18   dcg

CPVCS    use ior in place of .or. with integers

CPVCS

CPVCS       Rev 1.1   13 Jan 2000 14:47:54   dcg

CPVCS

CPVCS       Rev 1.0   04 Jan 2000 16:47:34   dcg

CPVCS

CPVCS
CPVCS       Rev 1.7   Mon Mar 29 10:29:06 1999   dcg
CPVCS    update possible materials for node list correctly
CPVCS
CPVCS       Rev 1.6   Thu Jul 02 14:02:30 1998   dcg
CPVCS    allow more than 32 materials
CPVCS
CPVCS       Rev 1.5   Mon Nov 24 16:33:06 1997   dcg
CPVCS    use geom.h and calls to get_regions, get_mregions, get_surfaces
CPVCS    to access geometry data - start to isolate integer*8 dependencies
CPVCS
CPVCS       Rev 1.3   Wed Oct 08 15:44:20 1997   dcg
CPVCS    add logical declarations
CPVCS
CPVCS       Rev 1.2   Thu Aug 28 15:28:16 1997   dcg
CPVCS    fix memory management error with updating npoints and ntets
CPVCS
CPVCS       Rev 1.0   Mon Aug 18 14:55:24 1997   dcg
CPVCS    Initial revision.
C
C#######################################################################
C
      implicit none
      include 'search.h'
      include 'cmo.h'
      include 'geom_lg.h'
      include 'chydro.h'
C
      integer shiftl, ior
      external shiftl
      logical itsttp
      real*8 cvmgt
      integer icscode,i,matindex,itetl1,itetl2,itetl3,itetl4,iit,
     *  nmatfal1,nmatfal2,it,npoints,ntets,leni,icmotype,incpts,
     *  ier,iimt,lenvvbar,ii,n,lenmatn,nlsttts,leng,iface,imtval
      pointer (ipvvbar,vvbar)
      pointer (ipvolic,volic)
      pointer (ipmatlst,matlst)
      pointer (ipimts1,imts1)
      pointer (iplstptl,lstptl)
      pointer (ipnimts,nimts)
      pointer (iprgnum,irgnum)
      pointer (ipsrfnum,isrfnum)
      character*132 logmess
      integer irgnum(1000000),isrfnum(1000000),
     * nimts(1000000),
     * imts1(1000000),matlst(1000000),lstptl(1000000)

      real*8 vvbarmin,vvbar(1000000),volic(1000000),
     *  epsilon
      character*8 cmregion
      character*16 isubname
      data cmregion,isubname/'mregion','fix_sm_tet'/
      data vvbarmin/1.0e-07/
C
C  If big tet exists ibigtet > 0 then need to save
C  room for extra 4 points
      incpts=0
      if(ibigtet.gt.0) incpts=4
C
C  Refresh pointers
C
      call mmfindbk('matlst',nname,ipmatlst,leni,ier)
      call mmfindbk('lstptl',nname,iplstptl,leni,ier)
      call mmfindbk('lstfail',nname,iplstfal,leni,ier)
      call mmfindbk('lsttts',nname,iplsttts,leni,ier)
      call mmfindbk('vol',nname,ipvol,leni,ier)
      call cmo_get_name(cmo,ier)
      call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ier)
C
C   GET memory
C
      lenvvbar=npoints+incpts
      call mmgetblk('vvbar',isubname,ipvvbar,lenvvbar,2,icscode)
      call mmgetblk('volic',isubname,ipvolic,lenvvbar,2,icscode)
C
C    ZERO-OUT THE DESIRED ARRAYS.
C
      do  i=1,npoints+incpts
         volic(i)=0.0
         vvbar(i)=0.0
      enddo
C
C        COMPUTE  VOLUMES BY ACCUMULATING TETRAHEDRON VOLUMES
C        ASSOCIATED WITH EACH NODE.  ALSO, ACCUMULATE NUMBER OF
C        TETRAHEDRA ASSOCIATED WITH EACH MASS POINT.
C
      do  it=1,ntets
         if(itet(1,it).le.npoints.and.itet(2,it).le.npoints.and.
     $      itet(3,it).le.npoints.and.itet(4,it).le.npoints) then
            volic(itet(1,it))=volic(itet(1,it))+vol(it)
            volic(itet(2,it))=volic(itet(2,it))+vol(it)
            volic(itet(3,it))=volic(itet(3,it))+vol(it)
            volic(itet(4,it))=volic(itet(4,it))+vol(it)
C                 *** THESE VOLUMES ARE 24 TIMES THE TRUE MASS-POINT
C                 *** VOLUMES.
            vvbar(itet(1,it))=vvbar(itet(1,it))+1.0
            vvbar(itet(2,it))=vvbar(itet(2,it))+1.0
            vvbar(itet(3,it))=vvbar(itet(3,it))+1.0
            vvbar(itet(4,it))=vvbar(itet(4,it))+1.0
C                 *** NUMBER OF TETRAHEDRA ASSOCIATED WITH A MASS POINT.
         endif
      enddo
C
C        _______________________________________________________________
C
C        CALCULATE THE AVERAGE TETRAHEDRON VOLUME FOR EACH MASS POINT,
C        MULTIPLY IT BY A MINIMUM ACCEPTABLE VELUE OF VTET/VBAR, AND
C        STORE IT IN THE vvbar ARRAY.
C
      do  i=1,npoints+incpts
         vvbar(i)=vvbarmin*volic(i)/(vvbar(i)+epsilon)
C              *** SIX TIMES THE AVERAGE TETRAHEDRON VOLUME ASSOCIATED
C              *** WITH A MASS POINT, MULTIPLIED BY A MINIMUM ACCEPTABLE
C              *** RATIO OF VTET/VBAR.
      enddo
C
C        _______________________________________________________________
C
C        MAKE A LIST OF TETRAHEDRA THAT FAIL THE MINIMUM V/VBAR TEST.
C
      do  it=1,ntetexcl
         lsttts(it)=0
      enddo
      do it=itetstrt,ntets
         lsttts(it)=cvmgt(it,0,
     $     vol(it).lt.max(vvbar(itet(1,it)),vvbar(itet(2,it)),
     $                    vvbar(itet(3,it)),vvbar(itet(4,it)))
     $       .and.
     $    itet(1,it).le.npoints.and.itet(2,it).le.npoints.and.
     $    itet(3,it).le.npoints.and.itet(4,it).le.npoints
     $                      )
      enddo
      call kmprsn(ntets,lsttts(1),1,lsttts(1),1,lsttts(1),1,
     $               nlsttts)

      if(nlsttts.ne.0) then
C
C           INCREASE MEMORY, IF NECESSARY.
C
         nnodes=npoints+incpts+nlsttts
         call cmo_set_info('nnodes',cmo,nnodes,1,1,ier)
         call cmo_newlen(cmo,ier)
         call cmo_get_info('imt1',cmo,ipimt1,leni,icmotype,ier)
         call cmo_get_info('itp1',cmo,ipitp1,leni,icmotype,ier)
         call cmo_get_info('xic',cmo,ipxic,leni,icmotype,ier)
         call cmo_get_info('yic',cmo,ipyic,leni,icmotype,ier)
         call cmo_get_info('zic',cmo,ipzic,leni,icmotype,ier)
         call cmo_get_info('itet',cmo,ipitet,leni,icmotype,ier)
         call cmo_set_info('nnodes',cmo,npoints,1,1,ier)
c
         if(nlsttts.gt.lstptlen) then
            lstptlen=nlsttts
            call mmnewlen('lstptl',nname,iplstptl,lstptlen,icscode)
            call mmnewlen('lstfail',nname,iplstfal,lstptlen,icscode)
         endif
         if(npoints+incpts+nlsttts.gt.lenmatmx) then
            lenmatn=(6*(npoints+incpts+nlsttts))/5
            call mmnewlen('matlst',nname,ipmatlst,lenmatn,
     $                       icscode)
            do  n=matblks,2,-1
               do  ii=(n-1)*lenmatn+npoints,(n-1)*lenmatn+1,-1
                  matlst(ii)=matlst(ii-(n-1)*(lenmatn-lenmatmx))
               enddo
            enddo
            do n=1,matblks
               do  ii=(n-1)*lenmatn+npoints+1,n*lenmatn
                  matlst(ii)=0
               enddo
            enddo
            lenmatmx=lenmatn
         else
            do  n=1,matblks
               matindex=(n-1)*lenmatmx
               matlst(matindex+npoints+1)=0
               matlst(matindex+npoints+2)=0
               matlst(matindex+npoints+3)=0
               matlst(matindex+npoints+4)=0
            enddo
         endif
C
C           ____________________________________________________________
C
C           ADD POINTS AT SMALL-TETRAHEDRON CENTROIDS AND UPDATE THE
C           lstptl ARRAY.
C
         do  iit=1,nlsttts
            itetl1=itet(1,lsttts(iit))
            itetl2=itet(2,lsttts(iit))
            itetl3=itet(3,lsttts(iit))
            itetl4=itet(4,lsttts(iit))
            xic(npoints+iit)=0.25*(xic(itetl1)+xic(itetl2)
     $                            +xic(itetl3)+xic(itetl4))
            yic(npoints+iit)=0.25*(yic(itetl1)+yic(itetl2)
     $                            +yic(itetl3)+yic(itetl4))
            zic(npoints+iit)=0.25*(zic(itetl1)+zic(itetl2)
     $                            +zic(itetl3)+zic(itetl4))
            itp1(npoints+iit)=ifitpint
            imt1(npoints+iit)=imt1(itetl1)
C                 *** PROBABLE POINT TYPE.  THE POINT TYPE MAY GET
C                 *** CHANGED LATER ON IF THE POINT TURNS OUT TO BE
C                 *** AN INTERFACE POINT, OR IF THE POINT IS
C                 *** CONSTRAINED.  SET POINT MATERIAL FROM POINT
C                 *** ON CONTAINING TET.
            lstptl(iit)=npoints+iit
            write(logmess,8390) lstptl(iit),itetl1,itetl2,itetl3,
     $                             itetl4
 8390       format(' Adding point',i10,' in tet',4i10,'.')
            call writloga('default',0,logmess,0,ier)
         enddo
         nlstptl=nlsttts
C
C           IF NO REGIONS PRINT WARNING AND RETURN
C
         if (nmregs.eq.0) then
            write(logmess,8400) npoints+1,npoints+nlstptl
 8400       format(' No regions - material set from enclosing tet ',
     *        'for points ',i10,' to ',i10)
            call writloga('bat',0,logmess,0,ier)
            go to 9000
         endif
C
C
C           DETERMINE THE MATERIAL TYPES OF NEW POINTS, AND IF A POINT
C           TURNS OUT TO BE AN INTERFACE POINT, ALSO MODIFY ITS POINT
C           TYPE.
C
         nmatfal1=0
         call mmfindbk('irgnum',nname,iprgnum,leni,ier)
         if(ier.eq.0) then
            if(leni.lt.nlstptl)
     *        call mmnewlen('irgnum',nname,iprgnum,nlstptl,ier)
         else
            call mmgetblk('irgnum',nname,iprgnum,nlstptl,1,ier)
         endif
         call mmfindbk('isrfnum',nname,ipsrfnum,leni,ier)
         if(ier.eq.0) then
            if(leni.lt.nlstptl)
     *           call mmnewlen('isrfnum',nname,ipsrfnum,nlstptl,ier)
         else
            call mmgetblk('isrfnum',nname,ipsrfnum,nlstptl,1,ier)
         endif
         call getregv(xic(npoints+1),yic(npoints+1),
     $                     zic(npoints+1),nlstptl,
     &                     smldistp,cmregion,0,
     $                     irgnum,isrfnum,ier)
         do  i=1,nlstptl
            if(irgnum(i).gt.0) then
               imt1(npoints+i)=irgnum(i)
            elseif(isrfnum(i).gt.0) then
               imt1(npoints+i)=imatint
               itp1(npoints+i)=ifitpini
C                    *** PROBABLE POINT TYPE.  THE POINT TYPE MAY GET
C                    *** CHANGED LATER ON IF THE POINT TURNS OUT TO BE
C                    *** CONSTRAINED.
            else
               nmatfal1=nmatfal1+1
               imt1(npoints+i)=0
            endif
         enddo
         if(nmatfal1.ne.0) then
            write(logmess,8510) nlstptl,nmatfal1
 8510       format(' Out of',i10,
     $                ' new points, cannot find material for',i10,
     $                ' points.')
            call writloga('default',1,logmess,0,ier)
         endif
C
         call ifacerfl(npoints+1,nlstptl,smldistp)
C                 *** CONSTRAINTS WILL BE PACKED INTO THE FIT WORD IN
C                 *** THIS ROUTINE.
C
C           WRITE A MESSAGE ABOUT THE ADDITION OF POINTS.
C
         write(logmess,8600) lstptl(1),lstptl(nlstptl)
 8600    format(' Points',i7,' -',i7,
     *     ' are being added to fix small tets.')
         call writloga('default',1,logmess,0,ier)
C
C           MODIFY THE MATERIAL-LIST ARRAY.
C
         nmatfal1=0
         nmatfal2=0
         call mmfindbk('nimts',nname,ipnimts,leni,ier)
         if(ier.eq.0) then
            if(leni.lt.nlstptl)
     *          call mmnewlen('nimts',nname,ipnimts,nlstptl,ier)
         else
            call mmgetblk('nimts',nname,ipnimts,nlstptl,1,ier)
         endif
         call mmfindbk('imts1',nname,ipimts1,leni,ier)
         leng=nlstptl*max(imtmax,nmregs)
         if(ier.eq.0) then
            if(leni.lt.leng)
     *            call mmnewlen('imts1',nname,ipimts1,leng,ier)
         else
            call mmgetblk('imts1',nname,ipimts1,leng,1,ier)
         endif
         call ifaceregv(xic(npoints+1),yic(npoints+1),
     $                          zic(npoints+1),nlstptl,smldistp,
     *                          imts1,nimts,
     *                          ier)
          do  i=1,nlstptl
            if(itsttp('intrface',itp1(npoints+i))) then
                if(nimts(i).ne.0) then
                  do  iimt=1,nimts(i)
                     imtval=imts1(iimt+nmregs*(i-1))
                     matindex=((imtval-1)/32)*
     *                               lenmatmx
                     matlst(matindex+i+npoints)=ior(
     *                   matlst(matindex+i+npoints),
     $                   shiftl(1,imtval-((imtval-1)/32)*32-1))
                  enddo
               else
                  nmatfal1=nmatfal1+1
               endif
            else
               if(imt1(i+npoints).ne.0) then
                  matindex=((imt1(i+npoints)-1)/32)*lenmatmx
                  matlst(matindex+i+npoints)=ior(
     $                matlst(matindex+i+npoints),
     $                shiftl(1,
     $                imt1(i+npoints)-((imt1(i+npoints)-1)/32)*32-1))
               else
                  nmatfal2=nmatfal2+1
               endif
            endif
         enddo
         if(nmatfal1.ne.0) then
            write(logmess,8690) nmatfal1
 8690       format(' Cannot find materials for',i10,
     $                ' new interface points.')
            call writloga('default',1,logmess,0,ier)
         endif
         if(nmatfal2.ne.0) then
            write(logmess,8700) nmatfal2
 8700       format(' No materials associated with',i10,
     $                ' new noninterface points.')
            call writloga('default',0,logmess,0,ier)
         endif
C
C           CHANGE THE MASS-POINT NUMBERS OF POINTS ASSOCIATED WITH THE
C           BIG TETRAHEDRON.
9000     if(ibigtet.gt.0) then
C
            do  iface=ittstrt1,4*ntets
               itet1(iface)=cvmgt(itet1(iface),itet1(iface)+nlstptl,
     $                            itet1(iface).lt.ibigtet)
            enddo
            ibigtet=npoints+nlstptl+1
            xic (ibigtet  )=xbigtet(1)
            yic (ibigtet  )=ybigtet(1)
            zic (ibigtet  )=zbigtet(1)
            itp1(ibigtet  )=ifitpini
            imt1(ibigtet  )=0
            xic (ibigtet+1)=xbigtet(2)
            yic (ibigtet+1)=ybigtet(2)
            zic (ibigtet+1)=zbigtet(2)
            itp1(ibigtet+1)=ifitpini
            imt1(ibigtet+1)=0
            xic (ibigtet+2)=xbigtet(3)
            yic (ibigtet+2)=ybigtet(3)
            zic (ibigtet+2)=zbigtet(3)
            itp1(ibigtet+2)=ifitpini
            imt1(ibigtet+2)=0
            xic (ibigtet+3)=xbigtet(4)
            yic (ibigtet+3)=ybigtet(4)
            zic (ibigtet+3)=zbigtet(4)
            itp1(ibigtet+3)=ifitpini
            imt1(ibigtet+3)=0
            do n=1,matblks
               matindex=(n-1)*lenmatmx
               matlst(matindex+ibigtet  )=-1
               matlst(matindex+ibigtet+1)=-1
               matlst(matindex+ibigtet+2)=-1
               matlst(matindex+ibigtet+3)=-1
            enddo
        endif
C              *** THE BIG-TETRAHEDRON POINT TYPES ARE SET TO INTERFACE
C              *** TYPES BECAUSE THIS ALLOWS US TO EXCLUDE CONNECTIONS
C              *** ORIGINATING FROM THESE POINTS DURING THE FIRST
C              *** INTERFACE PASS.  ALSO, ALL matlst BITS FOR THE
C              *** BIG-TETRAHEDRON POINTS ARE SET, SO THAT A CONNECTION
C              *** ORIGINATING FROM THESE POINTS WILL NEVER BE
C              *** CONSIDERED A MULTIMATERIAL CONNECTION DURING THE
C              *** SECOND INTERFACE PASS, AND ALL SUBSEQUENT PASSES.
C           INCREMENT npoints.
C
         npoints=npoints+nlstptl
         call cmo_set_info('nnodes',cmo,npoints,1,1,ier)
C
C           ____________________________________________________________
C
C           RETURN  AND TRY TO CONNECT THESE POINTS.
C
         istep=1
      endif
      call mmrelprt(isubname,ier)
      return
      end

max_forks_repo_name: daniellivingston/LaGriT


text:
!-----------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in    !
!  continuous development by various groups and is based on information !
!  from these groups: Federal Government employees, contractors working !
!  within a United States Government contract, and non-Federal sources  !
!  including research institutions.  These groups give the Government   !
!  permission to use, prepare derivative works of, and distribute copies!
!  of their work in the CMAQ system to the public and to permit others  !
!  to Do so.  The United States Environmental Protection Agency         !
!  therefore grants similar permission to use the CMAQ system software, !
!  but users are requested to provide copies of derivative works or     !
!  products designed to operate in the CMAQ system to the United States !
!  Government without restrictions as to use by others.  Software       !
!  that is used with the CMAQ system but distributed under the GNU      !
!  General Public License or the GNU Lesser General Public License is   !
!  subject to their copyright restrictions.                             !
!-----------------------------------------------------------------------!

!-------------------------------------------------------------------------------
!     PROGRAM bldmake
!     Generate a Makefile for source files extracted from a git repository
!     originally written in C by Steve Thorpe
!     rewritten in Fortran by Steve Howard (for a CVS repository)
!     redone to meet CMAQ coding standards by Jeff Young (Nov 2012)
!     Sep 2013 J.Young: Increased local variables "modName" and "modFile" name
!                       lengths from 32 to 64 chars
!     Dec 2013 D.Wong: Expanded functionality to handle twoway model
!     Sep 2014 D.Wong: Setup . as the path that contains *.EXT files
!     Aug 2015 D.Wong: Modified subroutine writeOBJS to put STENEX and PARIO
!                      in front of GLOBAL_MODULES in the OBJS sequence. In
!                      this arrangement, all routines in STENEX will stay under
!                      STENEX and all routines in PARIO will stay under PARIO
!                      rather than GLOBAL_MODULES
!     Oct 2015 J.Young: Rework to make macros in the makefile for libs and
!                       compiler "I" references; get rid of the CVS option.
!     Jan 2016 D.Wong: Fixed the include path of mpif.h
!     June 2019 F. Sidi: Removed redundant IOAPI library. Makefile generated
!                        consistant with IOAPI library format.
!     July 2019 F. Sidi: Added netCDF Fortran Library Path. Makefile generated
!                        consistent with netCDF library format.
!-------------------------------------------------------------------------------

      Program bldmake

      Use ModelCFG

      Implicit None

      Character( EXT_LEN ) :: cfgFile   ! config file
      Integer :: lfn = 11               ! config file unit
      Integer status
      Integer n

! call Setup routine to process command line arguments
      Call setup( cfgFile )

! open cfgFile
      Open ( unit=lfn, file=cfgFile, status='old', iostat=status )
      If ( status .Ne. 0 ) Then
        Write( *,'(" Open error number:",i5)') status
        Call error_msg( 'Cannot open FILE [' // Trim(cfgFile) //']' )
      End If

! read CFG file
      Call readCFG( lfn )
      Close ( unit=lfn )

! GIT repository
      Call git_export( status )

! create Makefile
      Open ( unit=lfn, file='Makefile', iostat=status )
      If ( status .ne. 0 ) Call error_msg( 'Cannot create FILE [Makefile]' )

      Call makefile( lfn, cfgFile )

      Close (unit=lfn)

! Delete Stray temp.* files
      Call deletefile( 'temp.*', status )
! If not makefile only (makefo), Then run the make command to compile
      If ( .not. makefo ) Then
        Call RunMake( status )
      End If

      Stop
      End Program bldmake

!-------------------------------------------------------------------------------
!     Setup routine:  gets input file and run options from command line
!-------------------------------------------------------------------------------
      Subroutine setup( cfgFile )

      Use ModelCfg

      Implicit None

! arguments
      Character( * ) :: cfgFile

! functions
      Integer :: IARGC

! local variables
      Integer :: status
      Integer :: nargs
      Integer :: n
      Character( NAME_LEN ) :: argv

! date and time variables
      Character( 8 )  :: cdate
      Character( 10 ) :: ctime
      Character( 5 )  :: czone
      Integer         :: dateValues( 8 )

! set defaults
      verbose   = .False.
      serial    = .False.
      debug     = .False.
      debug_cctm= .False.
      isam_cctm = .False.
      checkout  = .False.
      makefo    = .False.
      twoway    = .False.
      git_local = .False.
      repo      = ' '
      reporoot  = ' '

! check number of arguments on command line
      nargs = IARGC()  ! non-standard compiler extension returns the number of arguments
      If ( nargs .Eq. 0 ) Then
        Call help_msg('No arguments on command line')
        Stop
      End If

! get last argument (the bldit-created config file) and write to cfgFile
      Call GETARG( nargs, cfgFile )  ! non-standard compiler extension returns argument
                                     ! specified - the last argumet in this case
      If ( cfgFile( 1:1 ) .Eq. '-' ) Then   ! config file not the last argument
        Call ucase( cfgFile )

        If ( cfgFile .Eq. '-HELP' ) Then
          Call help_msg(' ')
          Call cfgHelp( ); Stop
        End If

        Call help_msg('Invalid configuration file argument:' // Trim( cfgFile ) )
        Stop
      End If

 !    write( *,* ) "cfg: ", cfgfile
 !    write( *,* ) "nargs: ", nargs

! check for run options
      Do n = 1, nargs-1
        Call GETARG( n, argv )

 !      write( *,* ) "n, argv: ", n, argv

        If ( argv( 1:1 ) .Ne. '-' ) Then
          Call help_msg('Invalid arguments on command line:' // Trim( argv ) )
          Stop
        End If

        Call ucase( argv )

        If ( argv .Eq. '-HELP' ) Then
          Call help_msg('Help option:' // Trim( argv ) )
          Call cfgHelp( ); Stop
        End If

        If ( argv .Eq. '-MAKEFO' ) Then     ! Make file only
          makefo = .True.; Cycle
        End If

        If ( argv .Eq. '-SERIAL' ) Then     ! compile for serial execution
          serial = .True.; Cycle
        End If

        If ( argv .Eq. '-TWOWAY' ) Then     ! WRF-CMAQ twoway CCTM
           If ( .Not. serial ) Then
              twoway = .True.; Cycle
           Else
              stop ' TwoWay not available for Serial execution'
           End If
        End If

        If ( argv .Eq. '-GIT_LOCAL' ) Then  ! do not copy source files to BLD directory
          git_local = .True.; Cycle
        End If

        If ( argv .Eq. '-DEBUG' ) Then
          debug = .True.; Cycle
        End If

        If ( argv .Eq. '-DEBUG_CCTM' ) Then
          debug_cctm = .True.; Cycle
        End If

        If ( argv .Eq. '-ISAM_CCTM' ) Then
          isam_cctm = .True.; Cycle
        End If

        If ( argv .Eq. '-VERBOSE' ) Then
          verbose = .True.; Cycle
        End If

        Call help_msg( 'Invalid arguments [' // Trim(argv) // '] on command line' )

      End Do

! If REPOROOT is defined, use it, Else set to current directory
      Call GETENV( 'REPOROOT', reporoot )
      If ( Len_Trim( reporoot ) .Eq. 0 ) Then
        Call PWD( reporoot, status )
        If ( status.ne.0 ) reporoot = './'
      End If
      If ( debug .or. verbose ) Then
        Write( *,'(''REPOROOT set to:'',a,/)') Trim( reporoot )
      End If

! Get system date and time
      Call date_and_time( cdate, ctime, czone, dateValues )
      Write( currentDate, '(i2.2,"/",i2.2,"/",2i4.2,":",i2.2,":",i2.2)' )
     &   dateValues( 2 ), dateValues( 3 ), dateValues( 1 ),
     &   dateValues( 5 ), dateValues( 6 ), dateValues( 7 )

      Return
      End Subroutine setup

!-------------------------------------------------------------------------------
!     Help message:  Prints command line format and options and stops run
!-------------------------------------------------------------------------------
      Subroutine help_msg( msg )

      Implicit None

! arguments
      Character(*) msg

      Write( *,'(/,a)' ) Trim( msg )

      Write( *,'(/"Usage: bldmake [-<option>...] filename")' )

      Write( *,'(/"where <option> is one of the following:")' )
      Write( *,'("  -verbose    Echo actions")' )
      Write( *,'("  -debug      Echo all actions")' )
      Write( *,'("  -serial     Make for serial execution")' )
      Write( *,'("  -makefo     Creates Makefile without building")' )
      Write( *,'("  -git_local  Does NOT copy source files to BLD directory")' )
      Write( *,'("  -help       Displays help screen")' )
      Write( *,'("  -debug_cctm Execute make with DEBUG option set to TRUE")' )
      Write( *,'("  -isam_cctm  Execute make with ISAM option set to TRUE")' )
      Write( *,'(//)' )

      End Subroutine help_msg

!-------------------------------------------------------------------------------
!     Error:  Prints error string and stops run
!-------------------------------------------------------------------------------
      Subroutine error_msg( msg )

      Implicit None

! arguments
      Character( * ) :: msg

      Write( *,'(/"*** Program terminated on Error ***"/)' )
      Write( *,'(5x,a//)' ) Trim( msg )

      Stop
      End Subroutine error_msg

!-------------------------------------------------------------------------------
!     Makefile routine: creates Makefile from CFG data
!-------------------------------------------------------------------------------
      Subroutine makefile( lfn, cfgFile )

      Use ModelCfg

      Implicit None

! arguments
      Integer lfn
      Character( * ) cfgFile

      If ( verbose ) Then
        Write( *,'(/"Generating Makefile"/)' )
      End If

! print header lines
      If ( serial ) Then
         Write( lfn, '("#   Makefile generated for serial execution using program bldmake")' )
      Else
         Write( lfn, '("#   Makefile generated for parallel execution using program bldmake")' )
      End If
      Write( lfn, '("#")' )
      Write( lfn, '("#   Generation date [",a,"]")' )      Trim( currentDate )
      Write( lfn, '("#   Configuration file [",a,"]")' )   Trim( cfgFile )
      Write( lfn, '("#   Using GIT repository [",a,"]")' ) Trim( repo )
      If ( Trim( mechanism ) .Ne. 'X' )
     &   Write( lfn, '("#   With mechanism [",a,"]")' )    Trim( mechanism )

      ! Document Explicit Compiler Execution Paths if not given explicitly
      If( Trim( f_compiler ) .Ne. Trim( f_compiler_path )
     &     .Or.  Trim( c_compiler ) .Ne. Trim( c_compiler_path ) )Then
         Write( lfn, '("#   Full Compiler Paths when Makefile was Built:")' )
         Write( lfn, '("#       FC = ",a)' ) Trim( f_compiler_path )
         Write( lfn, '("#       CC = ",a)' ) Trim( c_compiler_path )
      End If

      ! Document Explicit Library Paths
      Call GETENV( 'IOAPI_INCL_DIR', ioapi_incl_dir )
      Call GETENV( 'IOAPI_LIB_DIR',  ioapi_lib_dir )
      Call GETENV( 'NETCDF_LIB_DIR', netcdf_lib_dir )
      Call GETENV( 'NETCDFF_LIB_DIR', netcdff_lib_dir )
      Call GETENV( 'MPI_LIB_DIR',    mpi_lib_dir )
      Write( lfn, '("#   Library Paths:")' )
      Write( lfn, '("#      $(LIB)/ioapi/include_files -> ",a)' ) Trim( ioapi_incl_dir )
      Write( lfn, '("#      $(LIB)/ioapi/lib -> ",a)' ) Trim( ioapi_lib_dir )
      Write( lfn, '("#      $(LIB)/mpi -> ",a)' ) Trim( mpi_lib_dir )
      Write( lfn, '("#      $(LIB)/netcdf -> ",a)' ) Trim( netcdf_lib_dir )
      Write( lfn, '("#      $(LIB)/netcdff -> ",a)' ) Trim( netcdff_lib_dir )
      Write( lfn, '("#",/,"#   Command-Line Options:      ")' )
      Write( lfn, '("#      DEBUG = TRUE or true -- turn on debug flags ")' )
      Write( lfn, '("#  OR  debug = true or TRUE -- turn on debug flags ")' )
      Write( lfn, '("#  Can set either variable by using the setenv command for")' )
      Write( lfn, '("#  a debugging session with multiple compilations")' )
      Write( lfn, '("#")' )
      Write( lfn, '("#------------------------------------------------- ")' )

      ! Begin Makefile Commands
      Write( lfn, '(/" EXEC = ",a)' ) Trim( model )

      Write( lfn, '(/" FC = ",a)' ) Trim( f_compiler )
      Write( lfn, '( " CC = ",a)' ) Trim( c_compiler )

      Write( lfn, '(/" LIB = ",a)' ) Trim( lib_base )
      Write( lfn, '( " include_path = -I $(LIB)/",a,1x,a)' ) Trim( lib_1 ), backslash
      If ( l_lib_5) Then
         Write( lfn, '( "                -I $(LIB)/",a,1x,a)' ) Trim( lib_2 ), backslash
         Write( lfn, '( "                -I $(LIB)/",a,1x,a)' ) Trim( lib_3 ), backslash
         Write( lfn, '( "                -I $(LIB)/",a)' )      Trim( lib_5 )
      Else if ( l_lib_3 ) Then
         Write( lfn, '( "                -I $(LIB)/",a,1x,a)' ) Trim( lib_2 ), backslash
         Write( lfn, '( "                -I $(LIB)/",a)' )      Trim( lib_3 )
      Else
         Write( lfn, '( "                -I $(LIB)/",a,1x,a)' ) Trim( lib_2 )
      End If

      Write( lfn, '(/" WARN = ")' )
      Write( lfn, '( " FSTD = ",a)' ) Trim( fstd )
      Write( lfn, '( " DBG  = ",a)' ) Trim( dbg )

      Write( lfn, '(/" ifneq (,$(filter $(debug), TRUE true True T ))")')
      Write( lfn, '( "     DEBUG = TRUE")' )
      Write( lfn, '( " endif")' )

      Write( lfn, '(/" ifneq (,$(filter $(DEBUG), TRUE true ))")')
      Write( lfn, '( "     f_FLAGS   = ",a)' ) Trim( f_flags ) // " $(DBG) $(include_path)"
      Write( lfn, '( "     f90_FLAGS = ",a)' ) Trim( f90_flags ) // " $(DBG) $(include_path)"

      Write( lfn, '( " else")' )
      Write( lfn, '( "     f_FLAGS   = ",a)' ) Trim( f_flags ) // " $(FSTD) $(include_path)"
      Write( lfn, '( "     f90_FLAGS = ",a)' ) Trim( f90_flags ) // " $(FSTD) $(include_path)"

      Write( lfn, '( " endif")' )

      Write( lfn, '(/" F_FLAGS   = $(f_FLAGS)")' )
      Write( lfn, '( " F90_FLAGS = $(f90_FLAGS)")' )

      If ( serial ) Then
         Write( lfn, '( " C_FLAGS   = ",a)' ) Trim( c_flags ) // "-I."
      Else
         Write( lfn, '( " C_FLAGS   = ",a)' ) Trim( c_flags ) // "$(LIB)/mpi/include -I."
      End If

      If ( verbose ) Then
        Write( *, '("  Compilers defined")' )
      End If

      Write( lfn, '(/" LINKER     = ",a)' ) Trim( linker )
      Write( lfn, '( " LINK_FLAGS = ",a)' ) Trim( link_flags )

      If ( Len_Trim( reporoot ) .Gt. 0 ) Then
        Write( lfn, '(/" REPOROOT = ",a)' ) Trim( reporoot )
      End If

      If ( Len_Trim( VPATH ) .Gt. 0 ) Then
        Call writeVPATH( lfn )
      End If

      Call writeCPP( lfn )
      If ( verbose ) Then
        Write( *, '("  CPP Flags defined")' )
      End If

      Write( lfn, '(/" IOAPI  = -L$(LIB)/",a,1x,a)' ) Trim( lib_4 ), Trim( ioapi )
      Write( lfn, '( " NETCDF = -L$(LIB)/",a,1x,a, " -L$(LIB)/",a,1x,a)' )
     &  ,"netcdff/lib", Trim( netcdff ), "netcdf/lib", Trim(netcdf)

      If ( serial ) Then
         Write( lfn, '( " LIBRARIES = $(IOAPI) $(NETCDF)")' )
      Else
!         Write( lfn, '( " MPICH  = -L$(LIB)/",a,1x,a)' ) "mpich/lib", Trim( mpich )
!         Write( lfn, '( " MPICH  = -L$(LIB)/",a,1x,a)' ) "mpi/lib", Trim( mpich )
         Write( lfn, '( " LIBRARIES = $(IOAPI) $(NETCDF) ")' )
      End If

!     Call writeLIB( lfn )
      If ( verbose ) Then
        Write( *, '("  Libraries defined")' )
      End If

      Call writeINC( lfn )
      If ( verbose ) Then
        Write( *, '("  Includes defined")' )
      End If

      Call writeOBJS( lfn )
      If ( verbose ) Then
        Write( *, '("  Objects defined")' )
      End If

      Call writeRules( lfn )
      If ( verbose ) Then
        Write( *, '("  Make rules defined")' )
      End If

      Call writeDEP( lfn )
      If ( verbose ) Then
        Write( *, '("  USE/MODULE dependencies defined")' )
      End If

      Write( *, '(/"Makefile generated")' )

      Return
      End Subroutine makefile

!-------------------------------------------------------------------------------
!     WriteVPATH routine:  Writes each directory on its own line
!-------------------------------------------------------------------------------
      Subroutine writeVPATH( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getFieldCount

! local variables
      Integer nfields
      Integer n
      Character( EXT_LEN ) field

      Write( lfn, '(/,"#   Search PATH for source files")' )

      nfields = getFieldCount( VPATH, ':' )

      Call getField( VPATH, ':', 1, field )
      Write( lfn, '(" VPATH = ",a,":",$)' ) Trim( field )

! print each field at a time
      Do n = 2, nfields
        Call getField( VPATH, ':', n, field )
        If ( Len_Trim(field) .Gt. 0 )
     &     Write( lfn, '(1x,a,/,2x,a,":",$)' ) backslash, Trim( field )
      End Do

      Write( lfn, '(1x)' )

      Return
      End Subroutine writeVPATH

!-------------------------------------------------------------------------------
!     WriteCPP routine:  Writes each '-D' on its own line
!-------------------------------------------------------------------------------
      Subroutine writeCPP( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getFieldCount

! local variables
      Integer nfields
      Integer n
      Character( EXT_LEN ) :: field

      Write( lfn, '(/" CPP = "a)' ) Trim( cpp )

      nfields = getFieldCount( cpp_flags, ' ' )

      If ( nfields .Le. 1 ) Then
        Write( lfn, '(" cpp_flags = "a)' ) Trim( cpp_flags )
      Else

        Write( lfn, '(" cpp_flags =",$)')

        ! print each field at a time
        Do n = 1, nfields
          Call getField( cpp_flags, ' ', n, field )
          Write( lfn, '(1x,a,/,2x,a,$)' ) backslash, Trim( field )
        End Do
        Write( lfn, '(1x)' )

      End If

      Write( lfn, '(/" ifneq (,$(filter $(isam), TRUE true True T ))")')
      Write( lfn, '( "     CPP_FLAGS   = $(cpp_flags) -Disam" )' )
      Write( lfn, '( " else")' )
      Write( lfn, '( "     CPP_FLAGS   = $(cpp_flags)" )' )
      Write( lfn, '( " endif")' )

      Return
      End Subroutine writeCPP

!-------------------------------------------------------------------------------
!     WriteLIB routine:  Writes libraries line to Makefile
!-------------------------------------------------------------------------------
      Subroutine writeLIB( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getFieldCount

! local variables
      Integer nfields
      Integer n
      Integer pos
      Character( EXT_LEN ) :: field
      Character( EXT_LEN ) :: librec
      Character( EXT_LEN ) :: libname
      Character( EXT_LEN ) :: libs

!     Write( lfn, '(/,"#   Library paths")' )
      Write( lfn, '(1x)' )

   !  nfields = getFieldCount( libraries, ' ' )

      If ( nfields .Le. 1 ) Then
   !    Write( lfn, '("LIBRARIES  = ",a)' ) Trim( libraries )
        Return
      End If

      libs = 'LIBRARIES ='

! parse library fields
      librec = ' '
      libname = ' '
      Do n = 1, nfields
   !    Call getField( libraries, ' ', n, field )

        If ( n .Gt. 1 .And. field(1:2) .Eq. '-L' ) Then
          If ( libname .Eq. ' ' ) Write( libname, '(''LIB'',i2.2)' ) n/2

          Write( lfn, '(a)' ) Trim( libname ) // ' = ' // Trim( librec )
          libs = Trim( libs ) // ' $(' // Trim( libname ) // ')'
          librec = ' '
          libname = ' '
        End If

        librec = Trim( librec ) // ' ' // Trim( field )

        pos = Index( librec, '-l' )
        If ( libname .Eq. ' ' .And. pos .Gt. 0 ) Then
           libname = librec( pos+2: )
           Call ucase( libname )
        End If

      End Do

      If ( libname .Eq. ' ' ) Write( libname, '("LIB",i2.2)' ) n/2
      Write( lfn, '(a)' ) Trim( libname ) // ' = ' // Trim( librec )
      libs = Trim( libs ) // ' $(' // Trim( libname ) // ')'

  !   Write( lfn, '(/,''#   Libraries'')' )
      Write( lfn, '(/,a)' ) Trim( libs )

      Return
      End Subroutine writeLIB

!-------------------------------------------------------------------------------
!     WriteINC routine:  Writes include lines to Makefile
!-------------------------------------------------------------------------------
      Subroutine writeINC( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getNumberOfFields

! parameters
!     Integer, Parameter :: n_Mac = 4
!     Integer            :: pathInd( n_Mac ) = (/ 2, 1, 1, 1 /)
!     Integer, Parameter :: n_Inc = 8
!     Integer, Parameter :: pathMap( n_Inc ) = (/ 1, 1, 1, 1, 3, 3, 3, 4 /)
      Integer, Parameter :: n_Mac = 3
      Integer            :: pathInd( n_Mac ) = (/ 2, 1, 1 /)
  !   parallel & serial
      Integer, Parameter :: n_Inc = 8
      Integer, Parameter :: pathMap( n_Inc ) = (/ 1, 1, 1, 1, 3, 2, 2, 3 /)
  !   Integer, Parameter :: n_Inc = 6
  !   Integer, Parameter :: pathMap( n_Inc ) = (/ 1, 1, 1, 2, 2, 2 /)

! local variables
      Integer i, j, n
      Integer Map
      Integer pos, pos2
      Integer n_M
      Character( 8 ) :: pathMacro( n_Mac ) =
     &                         (/'BASE_INC',
     &                           'PA_INC  ',
     &                           'MPI_INC '/)
      Character( EXT_LEN ) :: pathChk( n_Mac ) =
     &                         (/'SUBST_PE_COMM ',
     &                           'SUBST_PACTL_ID',
     &                           'SUBST_MPI     '/)
 !    Character( EXT_LEN ) :: pathInc( n_Inc ) =
 !   &                         (/'SUBST_PE_COMM ',
 !   &                           'SUBST_CONST   ',
 !   &                           'SUBST_FILES_ID',
 !   &                           'SUBST_EMISPRM ',
 !   &                           'SUBST_PACTL_ID',
 !   &                           'SUBST_PACMN_ID',
 !   &                           'SUBST_PADAT_ID',
 !   &                           'SUBST_MPI     '/)
      Character( EXT_LEN ) :: pathStr( n_Mac )
      Logical              :: hasPaths

      Character( EXT_LEN ) :: path
      Integer :: adjustment         ! for the twoway model

      If ( n_includes .Eq. 0 ) Return

      pathStr = ' '
      hasPaths = .False.

      If ( serial ) Then
         n_M = n_Mac - 1
      Else
         n_M = n_Mac
      End If

      If ( twoway ) Then

! find path strings
        Do n = 1, n_includes
          Do i = 1, n_Mac
            If ( include( n )%name .Eq. pathChk( i ) ) Then
              path = include( n )%path
              If ( pathInd( i ) .Gt. 1 ) Then
                adjustment = 1
              Else
                adjustment = 0
              End If
              Do j = 1, pathInd( i ) - adjustment
                pos = Index( path, '/', .True.)
                If ( pos .Le. 0 ) Exit
                path = path( 1:pos-1 )
              End Do
              pathStr( i ) = path
              hasPaths = .True.
            End If
          End Do   ! n_Mac loop
        End Do   ! n_includes loop

        If ( hasPaths ) Then
          Write( lfn, '(1x)' )
          Do i = 1, n_Mac
            If ( pathStr( i ) .Ne. ' ' ) Then
!             Write( lfn, '(a," = ",a)' ) Trim( pathMacro( i ) ), '.'
              Write( lfn, '(a," = ",a)' ) pathMacro( i ), '.'
            End If
          End Do
        End If

      Else

! find path strings
        Do n = 1, n_includes
          Do i = 1, n_M
  !       write( *,* ) "%name, chk: ", n, i, trim( include( n )%name ), ' ', trim( pathChk( i ) )
            If ( include( n )%name .Eq. pathChk( i ) ) Then
              path = include( n )%path
              pos = Index( path, '/', .True.) ! find char index of last "/" in "path"
  !           write( *,* ) " path, pos: ", n, i, trim( path ), pos
              If ( pos .Le. 0 ) Exit
              path = path( 1:pos-1 )
              pathStr( i ) = path
              hasPaths = .True.
            End If
          End Do  ! n_Mac loop
        End Do  ! n_includes loop

        If ( hasPaths ) Then
          Write( lfn, '(1x)' )
          Do i = 1, n_M
            If ( pathStr( i ) .Ne. ' ' ) Then
              If ( pathMacro( i ) .EQ. "MPI_INC " ) Then
                  Write( lfn, '(1x,a," = ",a)' ) pathMacro( i ), "$(LIB)/mpi/include"
              Else
                  Write( lfn, '(1x,a," = ",a)' ) pathMacro( i ), Trim( pathStr( i ) )
              End If
            End If
          End Do
        End If

      End If

! write include lines
      Write( lfn, '(/" INCLUDES = ",$)' )

!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!  include(n)%name  include(n)%path
!  SUBST_PE_COMM = ./PE_COMM.EXT             <- BASE_INC
!  SUBST_CONST = ./CONST.EXT                 <- BASE_INC
!  SUBST_FILES_ID = ./FILES_CTM.EXT          <- BASE_INC
!  SUBST_EMISPRM = ./EMISPRM.EXT             <- BASE_INC
!  SUBST_PACTL_ID = ./PA_CTL.EXT             <- PA_INC
!  SUBST_PACMN_ID = ./PA_CMN.EXT             <- PA_INC
!  SUBST_PADAT_ID = ./PA_DAT.EXT             <- PA_INC
!  SUBST_MPI = /home/wdx/lib_sol/x86_64/intel/mpich/include/mpif.h
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      Do n = 1, n_includes
        path = include( n )%path
        Map = pathMap( n )

        Do i = 1, Size( pathMacro )
          pos = Index( path, Trim( pathStr( i ) ) )
          If ( pos .Gt. 0 .And. pathStr( i ) .Ne. ' ' ) Then
            pos2 = pos + Len_Trim( pathStr( i ) )
            If ( pos .Eq. 1 ) Then
              path = '$(' // Trim( pathMacro( Map ) ) // ')' // path( pos2: )
              Exit
            Else
              If ( twoway ) Then
                path = path( 1:pos-1 ) // '$('
     &                                 // Trim( pathMacro( i ) ) // ')'
              Else
                path = path( 1:pos-1 ) // '$('
     &                               // Trim( pathMacro( Map ) ) // ')' // path( pos2: )
              End If
            End If
          End If
        End Do

!!! BUT IF pathStr(i) is NOT unique for i = 1, 3, then path gets overwritten.
!!! The algorithm assumes different pathStr's for diff i's.
!!! For CopySrc option, pathStr(1) = pathStr(3) = '.'

        Write( lfn, '(1x,a,/,''  -D'',a,''='',a,''"'',a,a,''"'',$)' ) backslash,
     &         Trim( include( n )%name ), backslash, Trim( path ), backslash

! define include(n)%path2 to path with macro subsitutions
        include( n )%path2 = path

      End Do

      Write( lfn,'(1x)' )

      Return
      End Subroutine writeINC

!-------------------------------------------------------------------------------
!     WriteOBJS routine:  Writes objects files by modules to Makefile
!-------------------------------------------------------------------------------
      Subroutine writeOBJS( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getNumberOfFields

! local variables
      Integer :: nfiles
      Integer :: nfields
      Integer :: n
      Integer :: i
      Integer :: pos
      Character( FLD_LEN ) :: filename( MAX_FILES )
      Character( FLD_LEN ) :: modname
      Character( FLD_LEN ) :: modname1
      Character( FLD_LEN ) :: modname2
      Character( FLD_LEN ) :: obj
      Character( FLD_LEN ) :: objStr = ' '
      Character( FLD_LEN ) :: tobjStr = ' '

! get list of all global modules
                                  ! global
      Call orderfiles( module(1), .True., nfiles, filename )
      modname = 'GLOBAL_MODULES'

      If ( nfiles .Gt. 0 ) Then
        tobjStr = Trim( modname )
        Write( lfn, '(//a," =",$)' ) Trim( tobjStr )
        Do i = 1, nfiles
          pos = Index( filename(i), '.' )
          If ( pos .Le. 0 ) Cycle
          obj = filename(i)(1:pos) // 'o'
          Write( lfn, '(1x,a/2x,a,$)' ) backslash, Trim( obj )
        End Do
      End If

! The $(GLOBAL_MODULES) macro has to follow the $(STENEX) macro if serial, and the
! $(PARIO) macro, if parallel.
! assumes cfg module order for CCTM is:
!  -parallel-      -serial-
!   STENEX (se)     STENEX (noop)
!   PARIO           driver or other (If PARIO does not follow STENEX: assume serial CCTM)

      modname1 = module(1)%name; Call ucase( modname1 )
      modname2 = module(2)%name; Call ucase( modname2 )

      If ( Trim( modname1 ) .Eq. 'STENEX' .And. Trim( modname2 ) .Eq. 'PARIO' ) Then
        Do n = 1, n_modules
          Call orderfiles( module(n), .False., nfiles, filename )
          If ( nfiles .Gt. 0 ) Then
            modname = module(n)%name
            Call ucase( modname )
            Write( lfn, '(//a," =",$)' ) Trim( modname )
            objStr = Trim( objStr ) // ' $(' // Trim( modname ) // ')'
            If ( n .Eq. 2 ) Then
            objStr = Trim( objStr ) // ' $(' // Trim( tobjStr ) // ')'
            End If

            Do i = 1, nfiles
              pos = Index( filename(i), '.' )
              If ( pos .Le. 0 ) Cycle
              obj = filename(i)(1:pos) // 'o'
              Write( lfn, '(1x,a/2x,a,$)' ) backslash, Trim( obj )
            End Do

          End If
        End Do

      Else If ( Trim( modname1 ) .Eq. 'STENEX' .And. Trim( modname2 ) .Ne. 'PARIO' ) Then
        Do n = 1, n_modules
          Call orderfiles( module(n), .False., nfiles, filename )
          If ( nfiles .Gt. 0 ) Then
            modname = module(n)%name
            Call ucase( modname )
            Write( lfn, '(//a," =",$)' ) Trim( modname )
            objStr = Trim( objStr ) // ' $(' // Trim( modname ) // ')'
            If ( n .Eq. 1 ) Then
              objStr = Trim( objStr ) // ' $(' // Trim( tobjStr ) // ')'
            End If

            Do i = 1, nfiles
              pos = Index( filename(i), '.' )
              If ( pos .Le. 0 ) Cycle
              obj = filename(i)(1:pos) // 'o'
              Write( lfn, '(1x,a/2x,a,$)' ) backslash, Trim( obj )
            End Do

          End If
        End Do

      Else If ( Trim( modname1 ) .Ne. 'STENEX' .And. Trim( modname2 ) .Ne. 'PARIO' ) Then
        Do n = 1, n_modules
          Call orderfiles( module(n), .False., nfiles, filename )
          If ( nfiles .Gt. 0 ) Then
            modname = module(n)%name
            Call ucase( modname )
            Write( lfn, '(//a," =",$)' ) Trim( modname )
            If ( n .Eq. 1 ) Then
              objStr = ' $(' // Trim( tobjStr ) // ')'
            End If
            objStr = Trim( objStr ) // ' $(' // Trim( modname ) // ')'

            Do i = 1, nfiles
              pos = Index( filename(i), '.' )
              If ( pos .Le. 0 ) Cycle
              obj = filename(i)(1:pos) // 'o'
              Write( lfn, '(1x,a/2x,a,$)' ) backslash, Trim( obj )
            End Do

          End If
        End Do
      End If

      Write( lfn, '(//"OBJS =",$)' )

      nfields = getNumberOfFields( objStr, ' ' )
      Do n = 1, nfields
        Call getField( objStr, ' ', n, obj )
        Write( lfn, '(1x,a/2x,a,$)' ) backslash, Trim( obj )
      End Do
      Write( lfn,'(1x)' )

      Return
      End Subroutine writeOBJS

!-------------------------------------------------------------------------------
!     WriteDEP routine:  Writes USE/MODULE and INCLUDE dependencies lines to Makefile
!-------------------------------------------------------------------------------
      Subroutine writeDEP( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer lfn

! functions
      Integer getNumberOfFields

! local variables
      Character( FLD_LEN ) :: objname
      Character( FLD_LEN ) :: reqStr
      Character( NAME_LEN ) :: modName
      Character( NAME_LEN ) :: modFile
      Integer :: nfields
      Integer :: n
      Integer :: i
      Integer :: j
      Integer :: pos
      Character( 1 )       :: tab = char(9)

      Logical :: incdep( n_includes )
      Integer :: ndep
      Character( FLD_LEN ) :: depFile( MAX_FILES+n_includes )

      Write( lfn, '("# dependencies"/)' )

! loop thru each archive module and write list of source file dependencies
      Do n = 1, n_modules
        Do i = 1, module(n)%nfiles
          ndep = 0
          depFile = ''

! build object filename
          objname = module(n)%file(i)%name
          pos = Index( objname, '.' )
          If ( pos .Gt. 0 ) objname = objname( 1:pos ) // 'o'

! parse USEs string to get module names
          nfields = getNumberOfFields( module(n)%file(i)%uses, ':' )
          write( *,* ) ' '
          If ( nfields .Gt. 2 ) Then
            write( *,* ) 'file,nfields-1 ', Trim( module( n )%file( i )%name ),
     &                   ' ', nfields-1
            Do j = 2, nfields-1
              Call getField( module( n )%file( i )%uses, ':', j, modName )
              Call getModFile( modName, modFile )
              If ( Len_Trim( modFile ) .Gt. 0 ) Then
                write( *,* ) 'modName,modFile ', j, trim( modName ),
     &                       ' ', trim( modFile )
                ndep = ndep+ 1
! change dependency file to object file
                pos = Index( ModFile, '.' )
                If ( pos .Gt. 0 ) DepFile( ndep ) = ModFile( 1:pos ) // 'o'
              Else
                write( *,* ) 'modName         ', j, trim( modName ),
     &                       '  -------------'
              End If
            End Do
          End If   ! has USEs files

! check for include file dependencies
          Call getIncDep( module( n )%file( i )%path, incdep )
          Do j = 1, n_includes
            If ( incdep( j ) ) Then
! Do not include mpif.h dependency
              pos = Index( include( j )%path2, 'mpif' )
              If ( pos .Eq. 0 ) Then
                ndep = ndep + 1
                depFile( ndep ) = include( j )%path2
              End If
  !         write( *,'(a,3i3,1x,a)' ) 'depend: ', n, j, ndep, trim( depFile( ndep ) )
            End If
          End Do

! write dependencies string
          reqStr = ''
          Do j = 1, ndep
            If ( Len_Trim( reqStr ) .Eq. 0 ) Then
              reqStr = Trim( objName ) // ':' // tab // depFile( j )
            Else If ( Len_Trim( reqStr ) .Le. 60 ) Then
              reqStr = Trim( reqStr ) // ' ' // depFile( j )
            Else
              Write( lfn,'(a,1x,a)' ) Trim( reqStr ), backslash
              reqStr = tab // tab // depFile( j )
            End If
          End Do

          If ( Len_Trim( reqStr ) .Gt. 0 ) Write( lfn,'(a)' ) Trim( reqStr )

        End Do    ! file loop
      End Do    ! module loop

      Return
      End Subroutine writeDEP

!-------------------------------------------------------------------------------
!     WriteRules routine:  Writes rules to Makefile
!-------------------------------------------------------------------------------
      Subroutine writeRules( lfn )

      Use ModelCFG

      Implicit None

! arguments
      Integer              :: lfn

! local variables
      Integer              :: n
      Character( FLD_LEN ) :: record
      Character( 1 )       :: tab = char( 9 )

! build SUFFIXES record
      record = '.SUFFIXES:'

      Do n = 1, Size( extension )
        record = Trim( record ) // ' ' // extension( n )
      End Do

      Write( lfn, '(/,a)') Trim( record )

      Write( lfn, '(/"$(EXEC): $(OBJS)")' )
      Write( lfn, '(a,"$(LINKER) $(LINK_FLAGS) $(OBJS) $(LIBRARIES) -o $@"/)' ) tab

      Write( lfn, '(".F.o:")' )
      Write( lfn, '(a,"$(FC) -c $(F_FLAGS) $(CPP_FLAGS) $(INCLUDES) $<"/)' ) tab

      Write( lfn, '(".f.o:")' )
      Write( lfn, '(a,"$(FC) -c $(F_FLAGS) $<"/)' ) tab

      Write( lfn, '(".F90.o:")' )
      Write( lfn, '(a,"$(FC) -c $(F90_FLAGS) $(CPP_FLAGS) $(INCLUDES) $<"/)' ) tab

      Write( lfn, '(".f90.o:")' )
      Write( lfn, '(a,"$(FC) -c $(F90_FLAGS) $<"/)' ) tab

      Write( lfn, '(".c.o:")' )
      Write( lfn, '(a,"$(CC) -c $(C_FLAGS) $<"/)' ) tab

      Write( lfn, '("clean:")' )
  !   Write( lfn, '(a,"rm -f $(OBJS) $(MODEL) *.mod"/)' ) tab
      Write( lfn, '(a,"rm -f $(OBJS) *.mod"/)' ) tab

      Write( lfn, '(1x)' )

      Return
      End Subroutine writeRules

ext: f

max_stars_repo_name: Simeng-unique/CMAQ-changed

max_issues_repo_name: Simeng-unique/CMAQ-changed

max_forks_repo_name: Simeng-unique/CMAQ-changed


text:
      SUBROUTINE AMPTSETDEF
c
cgsfs added following line to match C++ call
      double precision xmp, xmu, alpha, rscut2, cutof2
      double precision smearp,smearh,dpcoal,drcoal,ecritl
      character*25 amptvn
      COMMON/HMAIN1/EATT,JATT,NATT,NT,NP,N0,N01,N10,N11
      COMMON /HPARNT/HIPR1(100), IHPR2(50), HINT1(100), IHNT2(50)
      COMMON/LUDAT1A/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON /ARPRNT/ ARPAR1(100), IAPAR2(50), ARINT1(100), IAINT2(50)
      COMMON /AROUT/ IOUT
      COMMON /AREVT/ IAEVT, IARUN, MISS
      COMMON /smearz/smearp,smearh
      COMMON/RNDF77/NSEED
      common/anim/nevent,isoft,isflag,izpc
c     parton coalescence radii in case of string melting:
      common /coal/dpcoal,drcoal,ecritl
      common/snn/efrm,npart1,npart2
c     initialization value for parton cascade:
      common /para2/ xmp, xmu, alpha, rscut2, cutof2
      common /para7/ ioscar,nsmbbbar,nsmmeson
      common /para8/ idpert,npertd,idxsec
      common /rndm3/ iseedp
c     initialization value for hadron cascade:
      COMMON /RUN/ NUM
      common/input1/ MASSPR,MASSTA,ISEED,IAVOID,DT
      COMMON /INPUT2/ ILAB, MANYB, NTMAX, ICOLL, INSYS, IPOT, MODE,
     &   IMOMEN, NFREQ, ICFLOW, ICRHO, ICOU, KPOTEN, KMUL
      common/oscar1/iap,izp,iat,izt
      common/oscar2/FRAME,amptvn
      common/resdcy/NSAV,iksdcy,ikstardcy
clin-6/2009:
c      common/phidcy/iphidcy
      common/phidcy/iphidcy,pttrig,ntrig,maxmiss
      common/embed/iembed,pxqembd,pyqembd,xembd,yembd
      common/popcorn/ipop

      EXTERNAL HIDATA, PYDATA, LUDATA, ARDATA, PPBDAT, zpcbdt
      SAVE
c****************

c     flag to select default AMPT or string melting:
      isoft    = 4		! ISOFT (D=1): select Default AMPT or String Melting(see below)
c     read initialization value for hadron cascade:
      NTMAX    = 150		! NTMAX: number of timesteps (D=150), see below
      DT       = 0.2		! DT: timestep in fm (hadron cascade time= DT*NTMAX) (D=0.2)
c     parj(41) and (42) are a and b parameters in Lund string fragmentation:
      PARJ(41) = 0.5		! PARJ(41): parameter a in Lund symmetric splitting function
      PARJ(42) = 0.9      	! PARJ(42): parameter b in Lund symmetric splitting function
c     IHPR2(11)=3 (or 2) allows the popcorn mechanism in PYTHIA and
c     increase the net-baryon stopping in rapidity (value HIJING is 1):
      ipop      = 1	      	! (D=1,yes;0,no) flag for popcorn mechanism(netbaryon stopping)
c     PARJ(5) controls the fraction of BMBbar vs BBbar in popcorn:
      PARJ(5)   = 1.0	      	! PARJ(5) to control BMBbar vs BBbar in popcorn (D=1.0)
c     shadowing flag in HIJING:
      IHPR2(6)  = 1		! shadowing flag (Default=1,yes; 0,no)
c     quenching flag in HIJING:
      IHPR2(4)  = 0		! quenching flag (D=0,no; 1,yes)
c     quenching rate when quenching flag is on (=1.0 GeV/fm):
      HIPR1(14) = 2.0		! quenching parameter -dE/dx (GeV/fm) in case quenching flag=1
c     Minimum pt of hard or semihard scatterings in HIJING: D=2.0 GeV.
      HIPR1(8) = 2.0		! p0 cutoff in HIJING for minijet productions (D=2.0)
c     read initialization value for parton cascade:
      xmu      = 3.2264d0	! parton screening mass in fm^(-1) (D=3.2264d0), see below
      izpc     = 0		! IZPC: (D=0 forward-angle parton scatterings; 100,isotropic)
      alpha    = 0.3333d0	! alpha in parton cascade
c     quark coalescence radii in momentum and space for string melting:
      dpcoal   = 1d6		! dpcoal in GeV
      drcoal   = 1d6		! drcoal in fm
c     flag: read in HIJING random # seed at runtime(1) or from input.ampt(D=0):
      ihjsed   = 11		! ihjsed: take HIJING seed from below (D=0)or at runtime(11)
c     2 seeds for random number generators in HIJING/hadron cascade and ZPC:
      nseed    = 53153511	! random seed for HIJING
      iseedp   = 8		! random seed for parton cascade
      iksdcy   = 0		! flag for Ks0 weak decays (D=0,no; 1,yes)
      ikstardcy   = 0		! flag for K* weak decays (D=0,no; 1,yes)
      iphidcy  = 0		! flag for phi decays at end of hadron cascade (D=1,yes; 0,no)
c     flag for OSCAR output for final partons and hadrons:
      ioscar   = 0		! optional OSCAR output (D=0,no; 1,yes; 2&3,more parton info)
clin-5/2008     flag for perturbative treatment of deuterons:
      idpert   = 0		! flag for perturbative deuteron calculation (D=0,no; 1or2,yes)
      npertd   = 1		! integer factor for perturbative deuterons(>=1 & <=10000)
      idxsec   = 1		! choice of cross section assumptions for deuteron reactions
clin-6/2009 To select events that have at least 1 high-Pt minijet parton:
      pttrig   = -7.		! Pt in GeV: generate events with >=1 minijet above this value
      maxmiss  = 1000		! maxmiss (D=1000): maximum # of tries to repeat a HIJING event
      IHPR2(2) = 3		! flag to turn off initial and final state radiation (D=3)
      IHPR2(5) = 1		! flag to turn off Kt kick (D=1)
clin-6/2009 To embed a back-to-back q/qbar pair into each event:
      iembed   = 0		! flag to turn on quark pair embedding (D=0,no; 1to4:yes)
      pxqembd  = 7.             ! Initial Px and Py values (GeV) of the embedded quark (u or d)
      pyqembd  = 0.
      xembd    = 0.             ! Initial x & y values (fm) of the embedded back-to-back q/qbar
      yembd    = 0.
      nsembd   = 1              ! nsembd(D=0), psembd (in GeV),tmaxembd (in radian).
      psembd   = 5.
      tmaxembd = 0.
clin-7/2009 Allow modification of nuclear shadowing:
      ishadow  = 0 		! Flag to enable users to modify shadowing (D=0,no; 1,yes)
      dshadow  = 1.d0		! Factor used to modify nuclear shadowing
c
      RETURN
      END

c$$$%%%%%%%%%% Further explanations:
c$$$ISOFT:  1 Default,
c$$$        4 String Melting.
c$$$PARJ(41) & (42): 2.2 & 0.5/GeV^2 used for heavy ion (Au+Au, Pb+Pb) collisions,
c$$$        while the HIJING values (0.5 & 0.9/GeV^2) describe well
c$$$        Nch in pp collisions and are used for d-Au collisions.
c$$$NTMAX:	number of time-steps for hadron cascade.
c$$$	Use a large value (e.g. 1000) for HBT studies in heavy ion collisions.
c$$$	Using NTMAX=3 effectively turns off hadronic cascade.
c$$$parton screening mass (in 1/fm): its square is inversely proportional to
c$$$	the parton cross section. Use D=3.2264d0 for 3mb cross section,
c$$$	and 2.2814d0 for 6mb. Using 1d4 effectively turns off parton cascade.
c$$$ihjsed: if =11, take HIJING random seed at runtime so that
c$$$	every run may be automatically different (see file 'exec').
c$$$iksdcy: flag for Ks0 weak decays for comparison with data.
c$$$ikstardcy: flag for K* weak decays for comparison with data.
c$$$iphidcy: flag for phi meson decays at the end of hadron cascade for comparison
c$$$	with data; default is yes; use 0 to turn off these decays.
c$$$	Note: phi meson decay during hadron cascade is always enabled.
c$$$ioscar:	0 Dafault,
c$$$	1 Write output in the OSCAR format,
c$$$	2 Write out the complete parton information
c$$$		(ana/parton-initial-afterPropagation.dat)
c$$$        	right after string melting (before parton cascade),
c$$$	3 Write out several more files on parton information (see readme).
c$$$idpert:	flag for perturbative deuteron and antideuteron calculations
c$$$	with results in ana/ampt_pert.dat:
c$$$	0 No perturbative calculations,
c$$$	1 Trigger a production of NPERTD perturbative deuterons
c$$$		in each NN collision,
c$$$	2 Trigger a production of NPERTD perturbative deuterons only in
c$$$		an NN collision where a conventional deuteron is produced.
c$$$	Note: conventional deuteron calculations are always performed
c$$$		with results in ana/ampt.dat.
c$$$NPERTD:	number of perturbative deuterons produced in each triggered collision;
c$$$	setting it to 0 turns off perturbative deuteron productions.
c$$$idxsec: choose a cross section model for deuteron inelastic/elastic collisions:
c$$$	1: same |matrix element|**2/s (after averaging over initial spins
c$$$		and isospins) for B+B -> deuteron+meson at the same sqrt(s);
c$$$	2: same |matrix element|**2/s for B+B -> deuteron+meson
c$$$		at the same sqrt(s)-threshold;
c$$$	3: same |matrix element|**2/s for deuteron+meson -> B+B
c$$$		at the same sqrt(s);
c$$$ 	4: same |matrix element|**2/s for deuteron+meson -> B+B
c$$$		at the same sqrt(s)-threshold;
c$$$	1 or 3 also chooses the same cross section for deuteron+meson or baryon
c$$$		elastic collision at the same sqrt(s);
c$$$	2 or 4 also chooses the same cross section for deuteron+meson or baryon
c$$$		elastic collision at the same sqrt(s)-threshold.
c$$$%%%%%%%%%% For jet studies:
c$$$pttrig:	generate events with at least 1 initial minijet parton above this Pt
c$$$	value, otherwise repeat HIJING event until reaching maxmiss tries;
c$$$	use a negative value to disable this requirement and get normal events.
c$$$maxmiss: maximum number of tries for the repetition of a HIJING event to obtain
c$$$	a minijet above the Pt value of pttrig;	increase maxmiss if some events
c$$$	fail to generate at least 1 initial minijet parton above pttrig.
c$$$	it is safer to set a large value for high pttrig and/or large b value
c$$$	and/or smaller colliding nuclei.
c$$$IHPR2(2): flag to turn off initial and final state radiation:
c$$$	0 both radiation off, 1 only final off, 2 only initial off, 3 both on.
c$$$IHPR2(5): flag to turn off Pt kick due to soft interactions: 0 off, 1 on.
c$$$	Setting both IHPR2(2) and IHPR2(5) to zero makes it more likely to
c$$$	have two high-Pt minijet partons that are close to back-to-back.
c$$$%%%%%%%%%% To embed a back-to-back light q/qbar jet pair
c$$$%%%%%%%%%%  and a given number of soft pions along each jet into each event:
c$$$iembed: flag to turn on quark pair embedding:
c$$$        1: on with fixed position(xembd,pembd) and Pt(pxqembd,pyqembd);
c$$$        2: on with fixed position(xembd,pembd) and random azimuthal angle
c$$$         with Pt-magnitude given by sqrt(pxqembd^2+pyqembd^2);
c$$$        3: on with random position and fixed Pt(pxqembd,pyqembd);
c$$$        4: on with random position and random random azimuthal angle
c$$$         with Pt-magnitude given by sqrt(pxqembd^2+pyqembd^2);
c$$$	 for iembed=3 or 4: need a position file "embed-jet-xy.txt";
c$$$	Other integers: off.
c$$$pxqembd, pyqembd: sqrt(pxqembd^2+pyqembd^2) > 70MeV/c is required;
c$$$	the embedded quark and antiquark have pz=0.
c$$$xembd, yembd: the embedded quark and antiquark jets have z=0 initially. Note:
c$$$	the x-axis is defined as the direction along the impact parameter.
c$$$nsembd:	number of soft pions to be embedded with each high-Pt parton
c$$$	in the embedded jet pair.
c$$$psembd: Momentum of each embedded soft pion in GeV.
c$$$tmaxembd: maximum angle(rad) of embedded soft pions relative to high-Pt parton.
c$$$%%%%%%%%%% User modification of nuclear shadowing:
c$$$ishadow: set to 1 to enable users to adjust nuclear shadowing
c$$$	provided the shadowing flag IHPR2(6) is turned on; default value is 0.
c$$$dshadow: valid when ishadow=1; this parameter modifies the HIJING shadowing
c$$$	parameterization Ra(x,r)==1+fa(x,r) via Ra(x,r)==1+fa(x,r)*dshadow,
c$$$	so the value of 0.d0 turns off shadowing
c$$$	and the value of 1.d0 uses the default HIJING shadowing;
c$$$	currently limited to 0.d0<=dshadow<=1.d0 to make sure Ra(x,r)>0.

max_stars_repo_name: AllaMaevskaya/AliRoot

max_issues_repo_name: AllaMaevskaya/AliRoot

max_forks_repo_name: AllaMaevskaya/AliRoot


text:
module git2_types
    use, intrinsic :: iso_c_binding
    implicit none
    private

    integer, parameter, public :: c_unsigned_int    = c_int

    integer, parameter, public :: git_off_t         = c_int64_t
    integer, parameter, public :: git_time_t        = c_int64_t
    integer, parameter, public :: git_object_size_t = c_int64_t

    ! git_object_t
    integer(kind=c_int), parameter, public :: GIT_OBJECT_ANY       = -2
    integer(kind=c_int), parameter, public :: GIT_OBJECT_INVALID   = -1
    integer(kind=c_int), parameter, public :: GIT_OBJECT_COMMIT    =  1
    integer(kind=c_int), parameter, public :: GIT_OBJECT_TREE      =  2
    integer(kind=c_int), parameter, public :: GIT_OBJECT_BLOB      =  3
    integer(kind=c_int), parameter, public :: GIT_OBJECT_TAG       =  4
    integer(kind=c_int), parameter, public :: GIT_OBJECT_OFS_DELTA =  6
    integer(kind=c_int), parameter, public :: GIT_OBJECT_REF_DELTA =  7

    ! git_time
    type, bind(c), public :: git_time
        integer(kind=git_time_t) :: time
        integer(kind=c_int)      :: offset
        character(kind=c_char)   :: sign
    end type git_time

    ! git_signature
    type, bind(c), public :: git_signature
        type(c_ptr)              :: name
        type(c_ptr)              :: email
        integer(kind=git_time_t) :: when
    end type git_signature

    ! git_reference_t
    integer(kind=c_int), parameter, public :: GIT_REFERENCE_INVALID  = 0
    integer(kind=c_int), parameter, public :: GIT_REFERENCE_DIRECT   = 1
    integer(kind=c_int), parameter, public :: GIT_REFERENCE_SYMBOLIC = 2
    integer(kind=c_int), parameter, public :: GIT_REFERENCE_ALL      = ior(GIT_REFERENCE_DIRECT, &
                                                                           GIT_REFERENCE_SYMBOLIC)

    ! git_branch_t
    integer(kind=c_int), parameter, public :: GIT_BRANCH_LOCAL  = 1
    integer(kind=c_int), parameter, public :: GIT_BRANCH_REMOTE = 2
    integer(kind=c_int), parameter, public :: GIT_BRANCH_ALL    = ior(GIT_BRANCH_LOCAL, &
                                                                      GIT_BRANCH_REMOTE)

    ! git_filemode_t
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_UNREADABLE      = int(o'0000000')
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_TREE            = int(o'0040000')
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_BLOB            = int(o'0100644')
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_BLOB_EXECUTABLE = int(o'0100755')
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_LINK            = int(o'0120000')
    integer(kind=c_int), parameter, public :: GIT_FILEMODE_COMMIT          = int(o'0160000')

    ! git_submodule_update_t
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_UPDATE_CHECKOUT = 1
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_UPDATE_REBASE   = 2
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_UPDATE_MERGE    = 3
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_UPDATE_NONE     = 4

    ! git_submodule_ignore_t
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_IGNORE_UNSPECIFIED = -1
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_IGNORE_NONE        =  1
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_IGNORE_UNTRACKED   =  2
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_IGNORE_DIRTY       =  3
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_IGNORE_ALL         =  4

    ! git_submodule_recurse_t
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_RECURSE_NO       = 0
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_RECURSE_YES      = 1
    integer(kind=c_int), parameter, public :: GIT_SUBMODULE_RECURSE_ONDEMAND = 2

    ! git_writestream
    type, bind(c), public :: git_writestream
        type(c_funptr) :: write_callback
        type(c_funptr) :: close_callback
        type(c_funptr) :: free_callback
    end type git_writestream
end module git2_types

max_stars_repo_name: interkosmos/fortran-git

max_issues_repo_name: interkosmos/fortran-git

max_forks_repo_name: interkosmos/fortran-git


text:
SUBMODULE (VTK_element) VTK_element_procedures
    USE Precision, ONLY : i4k
    IMPLICIT NONE
    !! author: Ian Porter
    !! date: 05/06/2019
    !!
    !! This is the basic file for a serial VTK file
    !!

    CONTAINS

        MODULE PROCEDURE vtk_element_setup
        USE File_utility, ONLY : is_little_endian
        IMPLICIT NONE
        !! author: Ian Porter
        !! date: 05/06/2019
        !!
        !! This writes the header for a VTK file
        !!
        !! Example:
        !! <VTKFile type=”ImageData” version=”0.1” byte_order=”LittleEndian”>
        CHARACTER(LEN=*), PARAMETER   :: name = 'VTKFile'
        CHARACTER(LEN=:), ALLOCATABLE :: string
        CHARACTER(LEN=:), ALLOCATABLE :: type_string
        CHARACTER(LEN=*), PARAMETER   :: version_string = ' version="' // def_version // '"'
        CHARACTER(LEN=:), ALLOCATABLE :: byte_order_string
        CHARACTER(LEN=:), ALLOCATABLE :: compression_string

        IF (ALLOCATED(me%type)) THEN
            ALLOCATE(type_string,source=' type="' // me%type // '"')
        ELSE
            ERROR STOP "Error. Can't create VTK file without a known type. Terminated in vtk_element_setup"
        END IF
        IF (is_little_endian()) THEN
            ALLOCATE(byte_order_string,source=' byte_order="LittleEndian"')
        ELSE
            ALLOCATE(byte_order_string,source=' byte_order="BigEndian"')
        END IF
        IF (ALLOCATED(me%compression)) THEN
            ALLOCATE(compression_string,source=' compression="' // me%compression // '"')
        ELSE
            ALLOCATE(compression_string,source='')
        END IF

        ALLOCATE(string, source=type_string // version_string // byte_order_string // compression_string)

        CALL me%setup(name=name,string=string,offset=4)

        END PROCEDURE vtk_element_setup

        MODULE PROCEDURE initialize
        IMPLICIT NONE
        !! author: Ian Porter
        !! date: 05/07/2019
        !!
        !! This is an external interface to allow the user or other routines to set the internal variables
        !!

        IF (PRESENT(type))           ALLOCATE(me%type,source=type)
        IF (PRESENT(compression))    ALLOCATE(me%compression,source=compression)
        IF (PRESENT(file_extension)) ALLOCATE(me%file_extension,source=file_extension)

        CALL me%vtk_element_setup()

        END PROCEDURE initialize

        MODULE PROCEDURE finalize
        IMPLICIT NONE
        !! author: Ian Porter
        !! date: 05/07/2019
        !!
        !!
        !!
        IF (ALLOCATED(me%vtk_element)) THEN
            CALL me%vtk_element%finalize()
            CALL me%add(me%vtk_element)
        END IF

        END PROCEDURE finalize

        MODULE PROCEDURE gcc_bug_workaround_deallocate_vtk_element_single
        IMPLICIT NONE
        !! gcc Work-around for deallocating a multi-dimension derived type w/ allocatable character strings

        IF (ALLOCATED(foo%type))           DEALLOCATE(foo%type)
        IF (ALLOCATED(foo%version))        DEALLOCATE(foo%version)
        IF (ALLOCATED(foo%compression))    DEALLOCATE(foo%compression)
        IF (ALLOCATED(foo%file_extension)) DEALLOCATE(foo%file_extension)
        IF (ALLOCATED(foo%filename))       DEALLOCATE(foo%filename)
        !CALL foo%piece%deallocate_piece_dt()
        IF (ALLOCATED(foo%vtk_element)) THEN
            CALL foo%vtk_element%me_deallocate()
            CALL foo%vtk_element%deallocate()
        END IF
        CALL foo%deallocate()

        END PROCEDURE gcc_bug_workaround_deallocate_vtk_element_single

END SUBMODULE VTK_element_procedures

max_stars_repo_name: zbeekman/vtkmofo

max_issues_repo_name: zbeekman/vtkmofo

max_forks_repo_name: zbeekman/vtkmofo


text:
C Copyright (c) 2007-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C========================================================================
      SUBROUTINE EXTQ(IGLND,INVCN,MAXLN,NOD,INVLEN,XA,YA,CNTRA,SOLEA,
     &                SOLENA,ITT,iblk)
C
C************************************************************************
C
C Subroutine EXTQ sets up the matrix and vectors for a least squares
C linear interpolation/extrapolation of element variable data to the
C nodes for a 4-node quad element. In the special case of data from
C only 3 elements, the result is not least squares fit but a
C triangularization.
C
C Calls subroutines FRGE & BS
C
C Called by ELTON3
C
C************************************************************************
C
C  IGLND  INT   The global node number being processed
C  INVCN  INT   The inverse connectivity (1:maxln,1:numnda)
C  MAXLN  INT   The maximum number of elements connected to any node
C  NOD    INT   The node used to get the elements from INVCN
C  INVLEN INT   The number of elements connected to NOD
C  XA,etc REAL  Vectors containing nodal coordinates
C  CNTRA  REAL  Array containing the coordinates of the element
C               centroids (1:3)
C  SOLEA  REAL  The element variables
C  SOLENA REAL  Element variables at nodes
C               number with the global mesh node number (1:numnda)
C  ITT    INT   truth table
C  IM     INT   element block being processed (not ID)
C  S      REAL  The coefficient matrix for the least squares fit
C  L      INT   Dummy vector - used in FRGE and BS
C  X      REAL  The solution vector - used in BS
C  G      REAL  Dummy vector - used in FRGE
C  F      REAL  The load vector for the least squares fit
C
C************************************************************************
C
      include 'aexds1.blk'
      include 'amesh.blk'
      include 'ebbyeb.blk'
      include 'tapes.blk'
C
      DIMENSION INVCN(MAXLN,*),XA(*),YA(*)
      DIMENSION CNTRA(NUMEBA,*),SOLEA(NUMEBA,*)
      DIMENSION SOLENA(NODESA,NVAREL), ITT(NVAREL,*)
      DOUBLE PRECISION S(3,3),G(3),F(3),X(3)
      INTEGER L(3)
C
C************************************************************************
C
C  Zero matrix
C
      DO I = 1,3
         DO J = 1,3
            S(I,J) = 0.D+00
         end do
      end do
C
C  Set up matrix for linear fit
C
      S(1,1) = DBLE(INVLEN)
      DO I = 1, INVLEN
        S(1,2) = S(1,2) + DBLE(XA(IGLND) - CNTRA(INVCN(I,NOD),1))
        S(1,3) = S(1,3) + DBLE(YA(IGLND) - CNTRA(INVCN(I,NOD),2))
        S(2,2) = S(2,2) + DBLE((XA(IGLND) - CNTRA(INVCN(I,NOD),1)) *
     &                    (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
        S(2,3) = S(2,3) + DBLE((YA(IGLND) - CNTRA(INVCN(I,NOD),2)) *
     &                    (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
        S(3,3) = S(3,3) + DBLE((YA(IGLND) - CNTRA(INVCN(I,NOD),2)) *
     &                    (YA(IGLND) - CNTRA(INVCN(I,NOD),2)))
      end do
      S(2,1) = S(1,2)
      S(3,1) = S(1,3)
      S(3,2) = S(2,3)
C
C  Forward Gauss elimination (Kincaid pg. 220) (double precision)
C
      CALL FRGE(3,S,L,G)
C
C  Set up load vectors - number of element variables
C
      DO IVAR = 1, NVAREL
        IF (ITT(IVAR,iblk) .EQ. 0)GO TO 30
        F(1) = 0.D+00
        F(2) = 0.D+00
        F(3) = 0.D+00
        DO I = 1, INVLEN
          F(1) = F(1) + DBLE(SOLEA(INVCN(I,NOD),IVAR))
          F(2) = F(2) + DBLE(SOLEA(INVCN(I,NOD),IVAR) *
     &                  (XA(IGLND) - CNTRA(INVCN(I,NOD),1)))
          F(3) = F(3) + DBLE(SOLEA(INVCN(I,NOD),IVAR) *
     &                  (YA(IGLND) - CNTRA(INVCN(I,NOD),2)))
       end do
C
C  Back substitution (Kincaid pg. 223) (double precision)
C
        CALL BS(3,S,F,L,X)
C
C  Fill in nodal element value array (SOLENA)
C  Note: X and Y distances in S and F are centered on node being
C        interpolated to (IGLND), thus X and Y are zero in the eq.
C        Value = X(1) + X(2) * X + X(3) * Y
C
        SOLENA(IGLND,IVAR) = SNGL(X(1))
      end do
   30 CONTINUE
      RETURN
      END

max_stars_repo_name: brian-kelley/seacas

max_issues_repo_name: brian-kelley/seacas

max_forks_repo_name: brian-kelley/seacas


text:
      SUBROUTINE TRLGB (USETD,AP,GMD,GOD,PHIDH,AS,AD,AH,IFLAG1,SCR1,
     1                  SCR2,SCR3,SCR4)
C
C     THE PURPOSE OF THIS ROUTINE IS TO REDUCE THE SCALE FACTOR MATRIX
C     AP TO  A TRANS FORMATION MATRIX  AS, AD, AH
C
C     INPUTS (5)
C         USETD
C         AP     SCALE MATRIX --P SIZE
C         GMD    M- SET TRASNFORMATION MATRIX
C         GOD    0- SET TRASNFORMATION MATRIX
C         PHIDH  H- SET TRASNFORMATION MATRIX
C
C     OUTPUTS(3)
C         AS     SCALE MATRIX --S SET
C         AD     SCALE MATRIX --D SET
C         AH     SCALE MATRIX --H SET
C
C     NOTE  IFLAG1 WILL BE SET  TO -1  IF  AP = AD (N0 M,S,O)
C
C
      EXTERNAL        ANDF
      INTEGER         USETD,AP,GMD,GOD,PHIDH,AS,AD,AH,MCB(7),SCR1,
     1                USET1,ANBAR,AM,AN,AF,ADBAR,AO,ANDF,MULTI,SINGLE,
     2                OMIT,SIGN,TRNSP,PREC,SCR2,SCR3,SCR4,UM,US,UO
      COMMON /BITPOS/ UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG,UE,UP,UNE,UFE,
     1                UD
      COMMON /ZZZZZZ/ IZ(1)
      COMMON /SYSTEM/ ISKIP(54),IPREC
      COMMON /PATX  / NZ,N1,N2,N3,USET1
      COMMON /TWO   / TWO1(32)
C
C
      ANBAR = SCR2
      AM    = SCR3
      AN    = SCR4
      AF    = SCR2
      ADBAR = SCR3
      AO    = SCR4
C
C     SET FLAGS FOR PRESCENCE OF SETS
C
      MCB(1) = USETD
      CALL RDTRL (MCB)
      USET1  = USETD
      MULTI  = ANDF(MCB(5),TWO1(UM))
      SINGLE = ANDF(MCB(5),TWO1(US))
      OMIT   = ANDF(MCB(5),TWO1(UO))
      MODAL  = 0
      MCB(1) = PHIDH
      CALL RDTRL (MCB)
      IF (MCB(1) .LE. 0) MODAL = 1
      NZ     = KORSZ(IZ)
      SIGN   = 1
      TRNSP  = 1
      PREC   = IPREC
C
C     REMOVE EACH CONSTRAINT
C
      IF (MULTI .EQ. 0) GO TO 10
      IF (SINGLE.EQ.0 .AND. OMIT.EQ.0) AN = AD
      CALL CALCV (SCR1,UP,UNE,UM,IZ)
      CALL SSG2A (AP,ANBAR,AM,SCR1)
      CALL SSG2B (GMD,AM,ANBAR,AN,TRNSP,PREC,SIGN,SCR1)
      GO TO 20
C
C     NO MULTI-POINT CONSTRAINTS
C
   10 AN = AP
C
C     REMOVE SINGLES
C
   20 IF (SINGLE .EQ. 0) GO TO 30
      IF (OMIT  .EQ.  0) AF = AD
      CALL CALCV (SCR1,UNE,UFE,US,IZ)
      CALL SSG2A (AN,AF,AS,SCR1)
      GO TO 40
C
C     NO SINGLES
C
   30 AF = AN
   40 IF (OMIT .EQ. 0) GO TO 50
C
C     REMOVE OMITS
C
      CALL CALCV (SCR1,UFE,UD,UO,IZ)
      IF (AF .EQ. AO) AO = SCR2
      CALL SSG2A (AF,ADBAR,AO,SCR1)
      CALL SSG2B (GOD,AO,ADBAR,AD,TRNSP,PREC,SIGN,SCR1)
      GO TO 60
C
C     NO OMITS
C
   50 AD = AF
C
C     REMOVE TO H SET
C
   60 IF (MODAL .NE. 0) GO TO 70
      CALL SSG2B (PHIDH,AD,0,AH,TRNSP,PREC,SIGN,SCR1)
   70 IFLAG1 = MULTI + SINGLE + OMIT
      IF (IFLAG1 .EQ. 0) IFLAG1 = -1
      RETURN
      END


text:
! This Source Code Form is subject to the terms of the Mozilla Public
! License, v. 2.0. If a copy of the MPL was not distributed with this
! file, You can obtain one at http://mozilla.org/MPL/2.0/.
module initial_davidson_struct
  use global_var_mod
  use sparse_mod
  use davidson_io_mod
  implicit none

  type initial_dav_guess
     logical :: from_disk
     integer :: nroots, unit_num
     type(sparse_vector), dimension(:), allocatable :: vecs
     real(kind=real8), dimension(:), allocatable :: energies
  end type initial_dav_guess

contains

  !> \brief Returns the reference energy
  real(kind=real8) function get_reference_energy( obj, root )
    implicit none
    type(initial_dav_guess) :: obj
    integer :: root
    if ( .not. allocated(obj%energies) ) then
       write(*,*) "fatal error ... I never computed the reference energies "
       stop
    else if ( size(obj%energies) < root ) then
       write(*,*) "fatal error"
       write(*,*) "you asked for the energy of root = " , root
       write(*,*) "but I only have ", size(obj%energies), "roots"
       stop
    end if
    if ( allocated(user_ref_energy)) then
       get_reference_energy = user_ref_energy(root)
    else
       get_reference_energy = obj%energies(root)
    end if
  end function get_reference_energy

  !> \brief Returns true if we are using a user provided reference energy
  logical function using_user_reference_energy()
    using_user_reference_energy =  allocated(user_ref_energy)
  end function using_user_reference_energy

  !> \brief Copies the initial vector (for the given root) into the given array
  !> \param guess The initial_dav_guess storing the initial guess
  !> \param dest  The destination for the initial guess
  !> \param root  The root I want the initial guess for
  subroutine pull_initial_guess(guess, dest, root)
    implicit none

    ! inputs
    type(initial_dav_guess) :: guess
    real(kind=real8), dimension(:) :: dest
    integer, intent(in) :: root

    ! Two options, either the guess is in memory (as a sparse vector) or on disk
    if ( guess%from_disk ) then
       call davidson_io_read(dest, ci_final, root)
   else
       if (size(dest) <= 0 ) call cause_floating_point_exception
       call inflate_sparse_vector(guess%vecs(root), dest)
    end if
  end subroutine pull_initial_guess

  !> \brief Frees the memory associated with an initial_dav_guess type
  subroutine deallocate_initial_dav_guess(guess)
    implicit none

    ! inputs
    type(initial_dav_guess) :: guess

    ! local variables
    integer :: i , n

    if ( allocated(guess%vecs) ) then
       n = size(guess%vecs)
       do i = 1, n
          call destroy_sparse_vector(guess%vecs(i))
       end do
       deallocate(guess%vecs)
    end if

    if ( allocated(guess%energies) ) then
       deallocate(guess%energies)
    end if

  end subroutine deallocate_initial_dav_guess
end module initial_davidson_struct

max_stars_repo_name: EACcodes/TigerCI

max_issues_repo_name: EACcodes/TigerCI

max_forks_repo_name: EACcodes/TigerCI


text: #redirect Vietnamese Student Association

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine bvalus(n,knot,coef,nk,x,s,order)
C Args
      integer n, nk, order
      double precision knot(*),coef(*),x(*),s(*)
C Local
      double precision bvalue
      integer i

      do 10 i=1,n
         s(i)=bvalue(knot,coef,nk,4,x(i),order)
 10   continue
      return
      end

max_stars_repo_name: lifebit-ai/exomedepth

max_issues_repo_name: lifebit-ai/exomedepth

max_forks_repo_name: lifebit-ai/exomedepth


text:
!#########################################################################
!# ***********************************************************************
!# <name> sortstrategybase </name>
!# ***********************************************************************
!#
!# <purpose>
!# This module contains basic structures to support the sorting of
!# matrices and vectors.
!# A sorting strategy is simply a permutation of the numbers 1..NEQ
!# how to permute a scalar vector and its inverse permutation.
!# Both permutations are usually assigned as one large array
!# to a (scalar) vector to indicate how it is resorted.
!#
!# The following routines can be found here:
!#
!# 1.) sstrat_getUnsortedPosInfo
!#     -> Returns a permutation that describes for a sorted vector
!#        the positions in the unsorted vector
!#
!# 2.) sstrat_getSortedPosInfo
!#     -> Returns a permutation that describes for an unsorted vector
!#        the positions in the sorted vector
!#
!# </purpose>
!#########################################################################

module sortstrategybase

  use fsystem
  use storage
  use genoutput

  implicit none

  private

!<constants>

!<constantblock description="Sort strategy identifiers.">

  ! No sort strategy; this must be =0!
  integer, parameter, public :: SSTRAT_UNSORTED     = 0

  ! Cuthill-McKee sort strategy
  integer, parameter, public :: SSTRAT_CM           = 1

  ! Reverse Cuthill-McKee sort strategy
  integer, parameter, public :: SSTRAT_RCM          = 2

  ! Row-wise sorting for point coordinate.
  ! (As calculated by sstrat_initXYZsorting with idirection=0.)
  ! Only for special type of discretisations (<tex>$Q_1$</tex>, <tex>$\tilde Q_1$</tex>), where
  ! the DOF`s can be identified with X/Y/Z coordinates.
  ! Coincides with the sorting strategy of FEAST for simple-type domains
  ! like the unit square.
  integer, parameter, public :: SSTRAT_XYZCOORD     = 3

  ! Column-wise sorting for point coordinate.
  ! (As calculated by sstrat_initXYZsorting with idirection=1.)
  ! Only for special type of discretisations (<tex>$Q_1$</tex>, <tex>$\tilde Q_1$</tex>), where
  ! the DOF`s can be identified with X/Y/Z coordinates.
  integer, parameter, public :: SSTRAT_ZYXCOORD     = 4

  ! General FEAST renumbering.
  ! The DOF`s are numbered rowwise, independent of the geometrical
  ! structure of the domain.
  ! Only for special type of discretisations (<tex>$Q_1$</tex>) and tensor product meshes.
  integer, parameter, public :: SSTRAT_FEAST        = 5

  ! Stochastic renumbering / Random permutation.
  ! The permutation is completely random.
  integer, parameter, public :: SSTRAT_STOCHASTIC   = 6

  ! Hierarchical renumbering: The permutation is calculated by a sequence of meshes,
  ! regularly refined.
  integer, parameter, public :: SSTRAT_HIERARCHICAL = 7

  ! Random permutation.
  ! The permutation is completely random.
  integer, parameter, public :: SSTRAT_RANDOM       = 8

!</constantblock>

!</constants>

!<types>

!<typeblock>

  ! Encapsules a sorting strategy which can be used
  ! to resort matrices/vectors etc.
  type t_sortStrategy

    ! Type of the sorting strategy. One of the SSTRAT_xxxx constants.
    integer :: ctype = SSTRAT_UNSORTED

    ! Size of the permutation.
    integer :: nsize = 0

    ! TRUE if the structure is a copy of another sorting strategy structure.
    ! Prevents memory from being deallocated more than once.
    logical :: bisCopy = .false.

    ! Handle to the permutation. The calculated
    ! permutation Ipermutation given as a parameter to the routines
    ! has length 2*nsize for nsize numbers. It contains the permutation in the
    ! first N and its inverse at the second nsize entries. Here, the
    ! exact meaning of the word "permutation" is as follows:
    !
    !  Ipermutation (position in sorted vector) = position in unsorted vector.
    !  Ipermutation (nsize+position in unsorted vector) = position in sorted vector.
    integer :: h_Ipermutation = ST_NOHANDLE

  end type

!</typeblock>

  public :: t_sortStrategy

!<typeblock>

  ! A set of sorting strategies for multiple blocks (e.g., of block vectors).
  type t_blockSortStrategy

    ! Number of blocks
    integer :: nblocks = 0

    ! List of sorting strategies for all the blocks.
    type(t_sortStrategy), dimension(:), pointer :: p_Rstrategies => null()

  end type

!</typeblock>

  public :: t_blockSortStrategy

!</types>

  public :: sstrat_getUnsortedPosInfo
  public :: sstrat_getSortedPosInfo

contains

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

!<subroutine>

  subroutine sstrat_getUnsortedPosInfo (rsortStrategy,p_Ipermutation)

!<description>
  ! Returns a pointer to a permutation with
  !   Ipermutation (position in sorted vector) = position in unsorted vector.
!</description>

!<input>
  ! The sorting strategy structure to be released.
  type(t_sortStrategy), intent(in) :: rsortStrategy
!</input>

!<output>
  ! Pointer to the array.
  integer, dimension(:), pointer :: p_Ipermutation
!</output>

!</subroutine>

    if (rsortStrategy%h_Ipermutation .eq. ST_NOHANDLE) then
      call output_line ("Sort strategy not initialised.", &
          OU_CLASS_ERROR,OU_MODE_STD,"sstrat_getUnsortedPosInfo")
      call sys_halt()
    end if

    ! Get the permutation
    call storage_getbase_int (rsortStrategy%h_Ipermutation,p_Ipermutation)

    ! Only the first part.
    p_Ipermutation => p_Ipermutation(1:rsortStrategy%nsize)

  end subroutine

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

!<subroutine>

  subroutine sstrat_getSortedPosInfo (rsortStrategy,p_Ipermutation)

!<description>
  ! Returns a pointer to a permutation with
  !   Ipermutation (nsize+position in unsorted vector) = position in sorted vector
!</description>

!<input>
  ! The sorting strategy structure to be released.
  type(t_sortStrategy), intent(in) :: rsortStrategy
!</input>

!<output>
  ! Pointer to the array.
  integer, dimension(:), pointer :: p_Ipermutation
!</output>

!</subroutine>

    if (rsortStrategy%h_Ipermutation .eq. ST_NOHANDLE) then
      call output_line ("Sort strategy not initialised.", &
          OU_CLASS_ERROR,OU_MODE_STD,"sstrat_getSortedPosInfo")
      call sys_halt()
    end if

    ! Get the permutation
    call storage_getbase_int (rsortStrategy%h_Ipermutation,p_Ipermutation)

    ! Only the second part.
    p_Ipermutation => p_Ipermutation(rsortStrategy%nsize+1:2*rsortStrategy%nsize)

  end subroutine

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
module mod_data
    implicit none
    type T_DATA
        real*8, pointer :: oHz(:,:,:)
        real*8, pointer :: Huon(:,:,:)
        real*8, pointer :: Hvom(:,:,:)
        real*8, pointer :: W(:,:,:)
        real*8, pointer :: Ta(:,:,:)
        integer, pointer :: Uind(:)
        real*8, pointer :: Dn(:)
        real*8, pointer :: Dm(:)
        real*8, pointer :: Ua(:,:,:)
    end type

    type(T_DATA) :: MYDATA

    integer :: LBi, UBi, LBj, UBj, N, ND
    real*8, parameter :: dt=86.0

contains
subroutine allocate_init_data()
    integer :: i, j
    integer :: seed
    real*8, allocatable :: rndtmp(:)

    seed = 35*16
    N = 300
    ND = 2500
    LBi = 10
    UBi = 960
    LBj = 28
    UBj = 2016

    allocate (MYDATA % oHz(LBi:UBi,LBj:UBj,N))
    allocate (MYDATA % Huon(LBi:UBi,LBj:UBj,N))
    allocate (MYDATA % Hvom(LBi:UBi,LBj:UBj,N))
    allocate (MYDATA % W(LBi:UBi,LBj:UBj,N))
    allocate (MYDATA % Ta(LBi:UBi,LBj:UBj,N))
    allocate (MYDATA % Uind(1:ND))
    allocate (MYDATA % Dn(1:ND))
    allocate (MYDATA % Dm(1:ND))
    allocate (MYDATA % Ua(LBi:UBi,LBj:UBj,N))
    allocate (rndtmp(1:ND))

    call random_seed(seed)

    call random_number(MYDATA%oHz)
    call random_number(MYDATA%Huon)
    call random_number(MYDATA%Hvom)
    call random_number(MYDATA%W)
    call random_number(MYDATA%Ta)
    call random_number(MYDATA%Dn)
    call random_number(MYDATA%Dm)
    call random_number(MYDATA%Ua)
    call random_number(rndtmp)

    MYDATA%Uind(1) = rndtmp(1)*0.1*(UBi-LBi-4)+LBi+2
    DO i=2, ND
    IF(rndtmp(i).gt.0.75) THEN
        MYDATA%Uind(i) = MYDATA%Uind(i-1-MOD(int(rndtmp(i-1)*0.5*i),4))
    ELSE
        MYDATA%Uind(i) = MYDATA%Uind(i-1)+rndtmp(i)*10+0.5
        IF(MYDATA%Uind(i).gt.UBi-2) THEN
            MYDATA%Uind(i) = MOD(MYDATA%Uind(i), UBi-2)+LBi+2
        END IF
    END IF
    END DO
    deallocate (rndtmp)
end subroutine

subroutine flush_cache(t1)
    real*8, allocatable, dimension(:) :: dummyi
    real*8 :: t1

    allocate (dummyi(104857600))
    call random_number(dummyi)
    t1 = dummyi(104857600)
    deallocate (dummyi)

end subroutine

subroutine verify_data()
    real*8, allocatable, dimension(:,:,:) :: Ub
    real*8 :: vmax
    integer :: i,j,k
    allocate (Ub(LBi:UBi,LBj:UBj,N))

    call mpdata_adiff_tile_ver(LBi, UBi, LBj, UBj, MYDATA%oHz, MYDATA%Huon, MYDATA%Hvom, MYDATA%W, MYDATA%Ta, &
                         & MYDATA%Uind, MYDATA%Dn, MYDATA%Dm, Ub)
    vmax = 0.0
    do k=1, N
    do j=LBj+2, UBj-2
    do i=LBi+2, UBi-2
        if(ABS(Ub(i,j,k).gt.1E-6)) THEN
        if(ABS((MYDATA%Ua(i,j,k)-Ub(i,j,k))/Ub(i,j,k)).gt.vmax) THEN
            vmax = (MYDATA%Ua(i,j,k)-Ub(i,j,k))/Ub(i,j,k)
        endif
        elseif (ABS(MYDATA%Ua(i,j,k)-Ub(i,j,k)).gt.vmax) THEN
            vmax = Ub(i,j,k)-MYDATA%Ua(i,j,k)
        endif
    enddo
    enddo
    enddo
    write (*,'(a, f, \)') "          Max error: ", vmax
    if (vmax.le.1E-6) THEN
        write (*,*) "       PASS!"
    else
        write (*,*) "       FAILED..."
    endif
    deallocate (Ub)
end subroutine

subroutine mpdata_adiff_tile_ver (LBi, UBi, LBj, UBj, oHz, Huon, Hvom, W, Ta, Uind, Dn, Dm, Ua)
    implicit none
    integer, intent(in) :: LBi, UBi, LBj, UBj
    real*8, intent(in) :: oHz(LBi:,LBj:,:)
    real*8, intent(in) :: Huon(LBi:,LBj:,:)
    real*8, intent(in) :: Hvom(LBi:,LBj:,:)
    real*8, intent(in) :: W(LBi:,LBj:,:)
    real*8, intent(in) :: Ta(LBi:,LBj:,:)
    integer, intent(in) :: Uind(:)
    real*8, intent(in) :: Dn(:)
    real*8, intent(in) :: Dm(:)

    real*8, intent(out) :: Ua(LBi:,LBj:,:)

    integer :: Istr, Iend, Jstr, Jend

    Istr = LBi+2
    Iend = UBi-2
    Jstr = LBj+2
    Jend = UBj-2

    call stencil_ver (Istr, Iend, Jstr, Jend, LBi, UBi, LBj, UBj, oHz, Huon, Hvom, W, Ta, Uind, Dn, Dm, Ua)
end subroutine

subroutine deallocate_data()
    deallocate (MYDATA % oHz)
    deallocate (MYDATA % Huon)
    deallocate (MYDATA % Hvom)
    deallocate (MYDATA % W)
    deallocate (MYDATA % Ta)
    deallocate (MYDATA % Uind)
    deallocate (MYDATA % Dn)
    deallocate (MYDATA % Dm)
    deallocate (MYDATA % Ua)
end subroutine

end module

max_stars_repo_name: sspeng/ocean

max_issues_repo_name: sspeng/ocean

max_forks_repo_name: sspeng/ocean


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:16 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE NUM_9__genmod
          INTERFACE
            FUNCTION NUM_9(I,J,NX,NZ)
              INTEGER(KIND=4) :: I
              INTEGER(KIND=4) :: J
              INTEGER(KIND=4) :: NX
              INTEGER(KIND=4) :: NZ
              INTEGER(KIND=4) :: NUM_9
            END FUNCTION NUM_9
          END INTERFACE
        END MODULE NUM_9__genmod


text:
module Mod_plcd_SIMPData
   use typre
   use Mod_MPIObject
   use Mod_Listen
   use Mod_Element
   implicit none

   type, extends(MPIObject) :: SIMPDataType
      real(rp) :: p = 4.0_rp
      real(rp) :: eta = 0.5_rp   !Default value 0.5  -> larger -> more dynamic, less safe
      real(rp) :: xi = 0.2_rp    !Default value 0.2  -> larger -> more dynamic, less safe
      real(rp) :: VolumeFraction = 0.2_rp
      real(rp) :: chimin = 1e-5_rp, chimax = 1.0_rp
      integer(ip) :: ChiSpaceChoice = 1 !0: ElementWise, 1: PointWise

      !Auxiliary to be used during the iterative process
      !secant method for the volume restriction condition
      real(rp) :: HistoryMeanChi(3), HistoryObjectiveVolumeFraction(3)

      real(rp), pointer :: NodalChi(:) => NULL()

contains
      procedure :: ReadData
      procedure :: ScatterData
    end type

contains

   subroutine ReadData(a,Listener)
   implicit none
      class(SIMPDataType) :: a
      type(ListenFile) :: Listener

      do while(Listener%words(1)/='ENDTO')
         call Listener%listen('plcd_reaphy')
         if(Listener%words(1) == 'P    ') then
            a%p = Listener%param(1)
         elseif(Listener%words(1) == 'ETA  ')   then
            a%eta = Listener%param(1)
         elseif(Listener%words(1) == 'XI   ')   then
            a%xi = Listener%param(1)
         elseif(Listener%words(1) == 'VOLUM')   then
            a%VolumeFraction = Listener%param(1)
         elseif(Listener%words(1) == 'CHIMI')   then
            a%chimin = Listener%param(1)
         elseif(Listener%words(1) == 'CHIMA')   then
            a%chimax = Listener%param(1)
         elseif(Listener%words(1) == 'CHISP')   then
            a%ChiSpaceChoice = Listener%param(1)
         endif
       enddo
       !This is just so that in the external loop there are no problems
       Listener%words(1) = '     '
   end subroutine

   subroutine ScatterData(a)
      use MPI
      implicit none
      class(SIMPDataType) :: a

      integer(ip) :: ierr

      call MPI_BCAST(a%p,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%eta,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%xi,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%VolumeFraction,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%chimin,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%chimax,1,MPI_REAL8,a%MPIroot,a%MPIcomm,ierr)
      call MPI_BCAST(a%ChiSpaceChoice,1,MPI_INTEGER4,a%MPIroot,a%MPIcomm,ierr)
   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM