text:
      subroutine tce_sort_6(u,s,a,b,c,d,e,f,i,j,k,l,m,n,factor)
      implicit none
      integer a,b,c,d,e,f
      integer i,j,k,l,m,n
      double precision s(a*b*c*d*e*f)
      double precision u(a*b*c*d*e*f)
      double precision factor
      integer id(6),jd(6)
      integer ia,ib
      integer j1,j2,j3,j4,j5,j6
      ia = 0
      jd(1) = a
      jd(2) = b
      jd(3) = c
      jd(4) = d
      jd(5) = e
      jd(6) = f
      if ((n.eq.6).or.(n.eq.5)) then
      do j1 = 1,a
       id(1) = j1
       do j2 = 1,b
        id(2) = j2
        do j3 = 1,c
         id(3) = j3
         do j4 = 1,d
          id(4) = j4
          do j5 = 1,e
           id(5) = j5
           do j6 = 1,f
            id(6) = j6
            ia = id(6)+jd(6)*(id(5)-1+jd(5)*(id(4)-1+jd(4)
     1         *(id(3)-1+jd(3)*(id(2)-1+jd(2)*(id(1)-1)))))
            ib = id(n)+jd(n)*(id(m)-1+jd(m)*(id(l)-1+jd(l)
     1         *(id(k)-1+jd(k)*(id(j)-1+jd(j)*(id(i)-1)))))
            s(ib) = u(ia) * factor
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
      else if (n.eq.4) then
      do j1 = 1,a
       id(1) = j1
       do j2 = 1,b
        id(2) = j2
        do j3 = 1,c
         id(3) = j3
         do j5 = 1,e
          id(5) = j5
          do j4 = 1,d
           id(4) = j4
           do j6 = 1,f
            id(6) = j6
            ia = id(6)+jd(6)*(id(5)-1+jd(5)*(id(4)-1+jd(4)
     1         *(id(3)-1+jd(3)*(id(2)-1+jd(2)*(id(1)-1)))))
            ib = id(n)+jd(n)*(id(m)-1+jd(m)*(id(l)-1+jd(l)
     1         *(id(k)-1+jd(k)*(id(j)-1+jd(j)*(id(i)-1)))))
            s(ib) = u(ia) * factor
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
      else if (n.eq.3) then
      do j1 = 1,a
       id(1) = j1
       do j2 = 1,b
        id(2) = j2
        do j4 = 1,d
         id(4) = j4
         do j5 = 1,e
          id(5) = j5
          do j3 = 1,c
           id(3) = j3
           do j6 = 1,f
            id(6) = j6
            ia = id(6)+jd(6)*(id(5)-1+jd(5)*(id(4)-1+jd(4)
     1         *(id(3)-1+jd(3)*(id(2)-1+jd(2)*(id(1)-1)))))
            ib = id(n)+jd(n)*(id(m)-1+jd(m)*(id(l)-1+jd(l)
     1         *(id(k)-1+jd(k)*(id(j)-1+jd(j)*(id(i)-1)))))
            s(ib) = u(ia) * factor
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
      else if (n.eq.2) then
      do j1 = 1,a
       id(1) = j1
       do j3 = 1,c
        id(3) = j3
        do j4 = 1,d
         id(4) = j4
         do j5 = 1,e
          id(5) = j5
          do j2 = 1,b
           id(2) = j2
           do j6 = 1,f
            id(6) = j6
            ia = id(6)+jd(6)*(id(5)-1+jd(5)*(id(4)-1+jd(4)
     1         *(id(3)-1+jd(3)*(id(2)-1+jd(2)*(id(1)-1)))))
            ib = id(n)+jd(n)*(id(m)-1+jd(m)*(id(l)-1+jd(l)
     1         *(id(k)-1+jd(k)*(id(j)-1+jd(j)*(id(i)-1)))))
            s(ib) = u(ia) * factor
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
      else
      do j2 = 1,b
       id(2) = j2
       do j3 = 1,c
        id(3) = j3
        do j4 = 1,d
         id(4) = j4
         do j5 = 1,e
          id(5) = j5
          do j1 = 1,a
           id(1) = j1
           do j6 = 1,f
            id(6) = j6
            ia = id(6)+jd(6)*(id(5)-1+jd(5)*(id(4)-1+jd(4)
     1         *(id(3)-1+jd(3)*(id(2)-1+jd(2)*(id(1)-1)))))
            ib = id(n)+jd(n)*(id(m)-1+jd(m)*(id(l)-1+jd(l)
     1         *(id(k)-1+jd(k)*(id(j)-1+jd(j)*(id(i)-1)))))
            s(ib) = u(ia) * factor
           enddo
          enddo
         enddo
        enddo
       enddo
      enddo
      endif
      return
      end

max_stars_repo_name: mjklemm/nwchem-tce-triples-kernels

max_issues_repo_name: mjklemm/nwchem-tce-triples-kernels

max_forks_repo_name: mjklemm/nwchem-tce-triples-kernels


text:
        subroutine csplit(line,carray,nelems,maxelems,char,istatus)

!       Routine to split a character array into segments

        character*(*) line
        character*1 char
        character*30 carray(maxelems)

        integer istart(maxelems)
        integer iend(maxelems)

        lenline = len(line)
        nelems = 0
        istatus = 1

        lenelem = len(carray(1))

!       Beginning of line might start an element
        if(line(1:1) .ne. char)then
            istart(1) = 1
        endif

        do i = 1,lenline-1

!           Check for start of string
            if(line(i:i) .eq. char .and. line(i+1:i+1) .ne. char)then
                if(nelems+1 .gt. maxelems)then
                    write(6,*)
     1              ' Error: nelems+1 > maxelems',nelems+1,maxelems,i
     1                     ,line(i:i+1)
                    write(6,*)line
                    istatus = 0
                    return
                endif
                istart(nelems+1)= i+1
            endif

!           Check for end of string
            if(line(i:i) .ne. char .and. line(i+1:i+1) .eq. char)then
                nelems = nelems + 1
                iend(nelems)= i+1

                if(iend(nelems) - istart(nelems) .ge. lenelem)then
                    write(6,*)' Error: element is too long',
     1                        istart(nelems),iend(nelems)
                    write(6,*)line
                    stop
                endif

                carray(nelems) = line(istart(nelems):iend(nelems))
            endif

        enddo ! i

        write(6,*)' Elements in csplit are:'
        do i = 1,nelems
            write(6,*)i,' ',carray(i)
        enddo ! i

        return
        end

ext: f

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text: #redirect Woodland Veterinary Hospital

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text: Fox & Goose Pub


text:
!==============================================================================!
  subroutine Save_Ini(grid)
!------------------------------------------------------------------------------!
!
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use par_mod
  use rans_mod
  use Tokenizer_Mod
  use Grid_Mod
  use Parameters_Mod
!------------------------------------------------------------------------------!
  implicit none
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer           :: c, nn
  character(len=80) :: name_out, answer
  character(len=4)  :: ext
!==============================================================================!

  ! store the name
  if(this_proc  < 2)                                                     &
  write(*,*) '# Now saving initial files [skip cancels]:'
  call Tokenizer_Mod_Read_Line(CMN_FILE)

  read(line % tokens(1), '(A80)')  name_out
  answer=name_out
  call To_Upper_Case(answer)

  if(answer == 'SKIP') return

  ! save the name
  answer = name
  name = name_out
  nn = 0
  ext = '.xyz'
  call Name_File(this_proc, name_out, ext, len_trim(ext))
  open(9,file=name_out)
  do c= 1, grid % n_cells
    nn = nn + 1
  end do    ! through centers
  write(9,'(I10)') nn
  do c= 1, grid % n_cells
    write(9,'(3E25.8)') grid % xc(c),grid % yc(c),grid % zc(c)
  end do    ! through centers
  close(9)

  ext = '.U__'
  call Name_File(this_proc, name_out, ext, len_trim(ext))
  open(9,file=name_out)
  do c= 1, grid % n_cells
    write(9,'(7E18.8)') U % n(c), U % o(c), U % a(c), U % a_o(c),  &
                        U % d_o(c), U % c(c), U % c_o(c)
  end do    ! through centers
  close(9)

  ext = '.V__'
  call Name_File(this_proc, name_out, ext, len_trim(ext))
  open(9,file=name_out)
  do c= 1, grid % n_cells
    write(9,'(7E18.8)') V % n(c), V % o(c), V % a(c), V % a_o(c),  &
                        V % d_o(c), V % c(c), V % c_o(c)
  end do    ! through centers
  close(9)

  ext = '.W__'
  call Name_File(this_proc, name_out, ext, len_trim(ext))
  open(9,file=name_out)
  do c= 1, grid % n_cells
    write(9,'(7E18.8)') W % n(c), W % o(c), W % a(c), W % a_o(c),  &
                        W % d_o(c), W % c(c), W % c_o(c)
  end do    ! through centers
  close(9)

  ext = '.P__'
  call Name_File(this_proc, name_out, ext, len_trim(ext))
  open(9,file=name_out)
  do c= 1, grid % n_cells
    write(9,'(5E18.8)') P % n(c), PP % n(c), p % x(c), p % y(c), p % z(c)
  end do    ! through centers
  close(9)

  if(HOT == YES) then
    ext = '.T__'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') T % n(c), T % o(c), T % a(c), T % a_o(c),  &
                          T % d_o(c), T % c(c), T % c_o(c)
    end do    ! through centers
    close(9)
  end if

  if(SIMULA == ZETA.or.SIMULA==K_EPS_VV) then
    ext = '.Kin'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') Kin % n(c), Kin % o(c), Kin % a(c), Kin % a_o(c),  &
                          Kin % d_o(c), Kin % c(c), Kin % c_o(c)
    end do    ! through centers
    close(9)

    ext = '.Eps'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') Eps % n(c), Eps % o(c), Eps % a(c), Eps % a_o(c),  &
                          Eps % d_o(c), Eps % c(c), Eps % c_o(c)
    end do    ! through centers
    close(9)

    ext = '.v_2'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') v_2 % n(c), v_2 % o(c), v_2 % a(c), v_2 % a_o(c),  &
                          v_2 % d_o(c), v_2 % c(c), v_2 % c_o(c)
    end do    ! through centers
    close(9)

    ext = '.f22'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') f22 % n(c), f22 % o(c),  &
                          f22 % d_o(c), f22 % c(c), f22 % c_o(c)
    end do    ! through centers
    close(9)
  end if

  if(SIMULA == K_EPS) then
    ext = '.Kin'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') Kin % n(c), Kin % o(c), Kin % a(c), Kin % a_o(c),  &
                          Kin % d_o(c), Kin % c(c), Kin % c_o(c)
    end do    ! through centers
    close(9)

    ext = '.Eps'
    call Name_File(this_proc, name_out, ext, len_trim(ext))
    open(9,file=name_out)
    do c= 1, grid % n_cells
      write(9,'(7E18.8)') Eps % n(c), Eps % o(c), Eps % a(c), Eps % a_o(c),  &
                          Eps % d_o(c), Eps % c(c), Eps % c_o(c)
    end do    ! through centers
    close(9)
  end if

  name = answer

  end subroutine

max_stars_repo_name: mhadziabdic/T-FlowS

max_issues_repo_name: mhadziabdic/T-FlowS

max_forks_repo_name: mhadziabdic/T-FlowS


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.                                    !
!------------------------------------------------------------------------------!

SUBROUTINE alloc_ctm

!-------------------------------------------------------------------------------
! Name:     Allocate Arrays for CTM Dimensions
! Purpose:  Allocate arrays based on CTM grid.
! Revised:  14 Sep 2001  Original version.  (T. Otte)
!           27 Feb 2002  Renamed SURF2 as WIND10.  Removed RIB.  (T. Otte)
!           18 Mar 2003  Removed JDRATE.  (T. Otte)
!           09 Jun 2003  Added SNOCOV to METCRO2D.  (D. Schwede)
!                        Removed extraneous variables from output.  (T. Otte)
!           09 Aug 2004  Added JACOBS, WSPD10, WDIR10, SOIM1, SOIM2, SOIT1,
!                        SOIT2, SLTYP, JACOBF, QG, TEMP2, and LAI.  Restored
!                        GRIDBDY2D file to output.  Modified code so that arrays
!                        are made available in output only if user options in
!                        MM5 generate those data.  (T. Otte and D. Schwede)
!           29 Nov 2004  Added PURB.  (T. Otte)
!           25 Feb 2005  Eliminated GRIDCRO3D for hydrostatic runs.  (T. Otte)
!           19 Aug 2005  Moved VD_C from a pointer to MC2 to an individual
!                        array that is allocated in ALLOC_DEPV.  (T. Otte)
!           14 Jul 2006  Updated condition for GRID_CRO_3D fields to reflect
!                        new vertical structure indicator for WRF.  Added
!                        new output field LWMASK.  (T. Otte)
!           25 Jul 2007  Removed TEM1P5 and TEMP10.  Write TEMP2 regardless
!                        of whether or not it is part of input meteorology.
!                        Added VEG to output, made LAI a general output field,
!                        and added WR to output to support inline dry
!                        deposition velocity calculations in CCTM.  Added
!                        fractional land use.  Removed RBNDYI and JACOBS.
!                        (T. Otte)
!           21 Apr 2008  Replaced NBNDYD with NBNDY in allocation of boundary
!                        arrays.  Added 2-m mixing ratio (Q2_C) and turbulent
!                        kinetic energy (TKE_C and TKE_B) arrays.  (T. Otte)
!           29 Oct 2009  Added potential vorticity (PVC_C and PVC_B).  Added
!                        latitude, longitude, and map-scale factors squared
!                        on U and V faces to GRIDDOT2D.  Allow output variable
!                        PURB to be created with urban model in WRF.  Remove
!                        vertical velocity (predicted by the meteorological
!                        model; WWIND) from output by default; retain user
!                        option to output 3D field.  Add user option to output
!                        u- and v-component winds (UWINDC and VWINDC) on
!                        C-staggered grid.  (T. Otte)
!           14 Dec 2010  Added sea ice.  (T. Otte)
!           11 Aug 2011  Replaced module PARMS3 with I/O API module M3UTILIO.
!                        (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!           10 Apr 2015  Added new arrays CFRAC3D_C and CFRAC3D_B to pass 3D
!                        resolved cloud fraction to output.  (T. Spero)
!           20 Aug 2015  Changed latent heat flux from QFX to LH.  (T. Spero)
!           16 Mar 2018  Added SNOWH to METCRO2D output.  Added 3d soil, land
!                        use and mosaic arrays.  (T. Spero)
!           27 Jun 2018  Consolidated output variables into a single module
!                        CTMVARS.  Allocate data structures.  (T. Spero)
!           14 Sep 2018  Removed support for MM5v3 input.  (T. Spero)
!           18 Dec 2018  Updated to use new data structures.  (T. Spero)
!           18 Jun 2019  Added new surface variables with PX LSM that can
!                        improve dust simulation in CCTM.  Changed variable
!                        LUVCOUT to LUVBOUT to reflect that the default 3D wind
!                        components are on the Arakawa-C staggered grid, and
!                        the optional additional 3D winds are on the Arakawa-B
!                        staggered grid.  Added optional variables from KF
!                        convective scheme with radiative feedbacks.  (T. Spero)
!-------------------------------------------------------------------------------

  USE coord
  USE vgrd
  USE metinfo
  USE mcipparm
  USE ctmvars

  IMPLICIT NONE

  INTEGER                      :: nn

  INTEGER                      :: nwr
  INTEGER                      :: nsoil2d
  INTEGER                      :: npxwrf41

  INTEGER                      :: ntke
  INTEGER                      :: npv
  INTEGER                      :: nwout
  INTEGER                      :: ncld3d
  INTEGER                      :: nkfrad

!-------------------------------------------------------------------------------
! Allocate grid arrays for COORD.
!-------------------------------------------------------------------------------

  ALLOCATE ( vglvs_gd  ( nlays+1 ) )
  ALLOCATE ( x3face_gd ( 0:nlays ) )

!-------------------------------------------------------------------------------
! Allocate grid arrays for VGRD.
!-------------------------------------------------------------------------------

  ALLOCATE ( x3face ( 0:nlays ) )
  ALLOCATE ( x3midl (   nlays ) )

!-------------------------------------------------------------------------------
! Time-independent 2d fields at cell centers.
!-------------------------------------------------------------------------------

  nfld2dxy = 6
  IF ( iflufrc ) THEN
    nfld2dxy = nfld2dxy + 1  ! adds PURB
  ENDIF

  ALLOCATE ( fld2dxy ( nfld2dxy ) )

  DO nn = 1, nfld2dxy
    ALLOCATE ( fld2dxy(nn)%fld(ncols,nrows) )
    ALLOCATE ( fld2dxy(nn)%bdy(nbndy)       )
  ENDDO

  g_lat     => fld2dxy( 1)
  g_lon     => fld2dxy( 2)
  g_msfx2   => fld2dxy( 3)
  g_ht      => fld2dxy( 4)
  g_dluse   => fld2dxy( 5)
  g_lwmask  => fld2dxy( 6)

  IF ( iflufrc ) THEN
    g_purb  => fld2dxy( 7)
  ENDIF

!-------------------------------------------------------------------------------
! Time-independent 2d fields at cell corners and cell faces.
!
! These arrays are all set to the dot-point dimensions to accommodate the
! false dot points in the Arakawa-C staggered grid that are output in
! Models-3 I/O API "DOT" files.  When the output is written in netCDF, the
! true dimensions of the Arakawa-C staggered fields are used.
!-------------------------------------------------------------------------------

  nfld2dxy_d = 9

  ALLOCATE ( fld2dxy_d ( nfld2dxy_d ) )

  DO nn = 1, nfld2dxy_d
    ALLOCATE ( fld2dxy_d(nn)%fld(ncols+1,nrows+1) )
  ENDDO

  g_latd   => fld2dxy_d( 1)
  g_lond   => fld2dxy_d( 2)
  g_msfd2  => fld2dxy_d( 3)
  g_latu   => fld2dxy_d( 4)
  g_lonu   => fld2dxy_d( 5)
  g_msfu2  => fld2dxy_d( 6)
  g_latv   => fld2dxy_d( 7)
  g_lonv   => fld2dxy_d( 8)
  g_msfv2  => fld2dxy_d( 9)

!-------------------------------------------------------------------------------
! Time-independent 3d fields (fractional land use) at cell centers.
!-------------------------------------------------------------------------------

  IF ( iflufrc ) THEN

    nfld3dxyl = 1
    ALLOCATE ( fld3dxyl ( nfld3dxyl ) )

    DO nn = 1, nfld3dxyl
      ALLOCATE ( fld3dxyl(nn)%fld(ncols,nrows,nummetlu) )
    ENDDO

    g_lufrac  => fld3dxyl( 1)

  ELSE

    nfld3dxyl = 0

  ENDIF

!-------------------------------------------------------------------------------
! Time-varying 2d fields at cell centers.
!-------------------------------------------------------------------------------

  IF ( ifwr ) THEN
    nwr = 1  ! WR
  ELSE
    nwr = 0
  ENDIF

  IF ( ifsoil ) THEN
    nsoil2d = 5  ! SOIM1, SOIM2, SOIT1, SOIT2, SLTYP
  ELSE
    nsoil2d = 0
  ENDIF

  IF ( ifpxwrf41 ) THEN
    npxwrf41 = 6  ! WSAT_PX, WFC_PX, WWLT_PX, CSAND_PX, FMSAND_PX, CLAY_PX
  ELSE
    npxwrf41 = 0
  ENDIF

  nfld2dxyt = 29 + nwr + nsoil2d + npxwrf41

  ALLOCATE ( fld2dxyt ( nfld2dxyt ) )

  DO nn = 1, nfld2dxyt
    ALLOCATE ( fld2dxyt(nn)%fld(ncols,nrows) )
  ENDDO

  c_prsfc    => fld2dxyt( 1)
  c_ustar    => fld2dxyt( 2)
  c_wstar    => fld2dxyt( 3)
  c_pbl      => fld2dxyt( 4)
  c_zruf     => fld2dxyt( 5)
  c_moli     => fld2dxyt( 6)
  c_hfx      => fld2dxyt( 7)
  c_lh       => fld2dxyt( 8)
  c_radyni   => fld2dxyt( 9)
  c_rstomi   => fld2dxyt(10)
  c_tempg    => fld2dxyt(11)
  c_temp2    => fld2dxyt(12)
  c_q2       => fld2dxyt(13)
  c_wspd10   => fld2dxyt(14)
  c_wdir10   => fld2dxyt(15)
  c_glw      => fld2dxyt(16)
  c_gsw      => fld2dxyt(17)
  c_rgrnd    => fld2dxyt(18)
  c_rn       => fld2dxyt(19)
  c_rc       => fld2dxyt(20)
  c_cfrac    => fld2dxyt(21)
  c_cldt     => fld2dxyt(22)
  c_cldb     => fld2dxyt(23)
  c_wbar     => fld2dxyt(24)
  c_snocov   => fld2dxyt(25)
  c_veg      => fld2dxyt(26)
  c_lai      => fld2dxyt(27)
  c_seaice   => fld2dxyt(28)
  c_snowh    => fld2dxyt(29)

  IF ( ifwr ) THEN
    c_wr => fld2dxyt(29+nwr)
  ENDIF

  IF ( ifsoil ) THEN
    c_soim1 => fld2dxyt(29+nwr+1)
    c_soim2 => fld2dxyt(29+nwr+2)
    c_soit1 => fld2dxyt(29+nwr+3)
    c_soit2 => fld2dxyt(29+nwr+4)
    c_sltyp => fld2dxyt(29+nwr+5)
  ENDIF

  IF ( ifpxwrf41 ) THEN
    c_wsat_px   => fld2dxyt(29+nwr+nsoil2d+1)
    c_wfc_px    => fld2dxyt(29+nwr+nsoil2d+2)
    c_wwlt_px   => fld2dxyt(29+nwr+nsoil2d+3)
    c_csand_px  => fld2dxyt(29+nwr+nsoil2d+4)
    c_fmsand_px => fld2dxyt(29+nwr+nsoil2d+5)
    c_clay_px   => fld2dxyt(29+nwr+nsoil2d+6)
  ENDIF

!-------------------------------------------------------------------------------
! Time-varying 3d fields at cell centers.
!-------------------------------------------------------------------------------

  IF ( iftke ) THEN
    ntke = 1  ! TKE
  ELSE
    ntke = 0
  ENDIF

  IF ( lpv > 0 ) THEN
    npv = 1  ! PV
  ELSE
    npv = 0
  ENDIF

  IF ( lwout > 0 ) THEN
    nwout = 1  ! WWIND
  ELSE
    nwout = 0
  ENDIF

  IF ( ifcld3d ) THEN
    ncld3d = 1  ! CFRAC_3D
  ELSE
    ncld3d = 0
  ENDIF

  nfld3dxyzt = 10 + ntke + npv + nwout + ncld3d

  ALLOCATE ( fld3dxyzt ( nfld3dxyzt ) )

  DO nn = 1, nfld3dxyzt
    ALLOCATE ( fld3dxyzt(nn)%fld(ncols,nrows,nlays) )
    ALLOCATE ( fld3dxyzt(nn)%bdy(nbndy,nlays) )
  ENDDO

  c_jacobf   => fld3dxyzt( 1)
  c_jacobm   => fld3dxyzt( 2)
  c_densa_j  => fld3dxyzt( 3)
  c_what_jd  => fld3dxyzt( 4)
  c_ta       => fld3dxyzt( 5)
  c_qv       => fld3dxyzt( 6)
  c_pres     => fld3dxyzt( 7)
  c_dens     => fld3dxyzt( 8)
  c_zh       => fld3dxyzt( 9)
  c_zf       => fld3dxyzt(10)

  IF ( iftke ) THEN
    c_tke => fld3dxyzt(10+ntke)
  ENDIF

  IF ( lpv > 0 ) THEN
    c_pv => fld3dxyzt(10+ntke+npv)
  ENDIF

  IF ( lwout > 0 ) THEN
    c_wwind => fld3dxyzt(10+ntke+npv+nwout)
  ENDIF

  IF ( ifcld3d ) THEN
    c_cfrac_3d => fld3dxyzt(10+ntke+npv+nwout+ncld3d)
  ENDIF

  IF ( ifkfradextras ) THEN
    nkfrad = 4
  ELSE
    nkfrad = 0
  ENDIF

  nfld3dxyzt_q = nqspecies + nkfrad

  IF ( nqspecies > 0 ) THEN

    ALLOCATE ( fld3dxyzt_q ( nfld3dxyzt_q ) )

    DO nn = 1, nfld3dxyzt_q
      ALLOCATE ( fld3dxyzt_q(nn)%fld(ncols,nrows,nlays) )
      ALLOCATE ( fld3dxyzt_q(nn)%bdy(nbndy,nlays) )
    ENDDO

    c_qc => fld3dxyzt_q(1)
    c_qr => fld3dxyzt_q(2)

    IF ( nqspecies >= 4 ) THEN
      c_qi => fld3dxyzt_q(3)
      c_qs => fld3dxyzt_q(4)
      IF ( nqspecies >= 5 ) THEN
        c_qg => fld3dxyzt_q(5)
      ENDIF
    ENDIF

    IF ( ifkfradextras ) THEN
      c_qc_cu     => fld3dxyzt_q(nqspecies+1)
      c_qi_cu     => fld3dxyzt_q(nqspecies+2)
      c_cldfra_dp => fld3dxyzt_q(nqspecies+3)
      c_cldfra_sh => fld3dxyzt_q(nqspecies+4)
    ENDIF

  ENDIF

!-------------------------------------------------------------------------------
! Time-varying 3d fields at cell corners and cell faces.
!
! These arrays are all set to the dot-point dimensions to accommodate the
! false dot points in the Arakawa-C staggered grid that are output in
! Models-3 I/O API "DOT" files.  When the output is written in netCDF, the
! true dimensions of the Arakawa-C staggered fields are used.
!-------------------------------------------------------------------------------

  IF ( luvbout > 0 ) THEN
    nfld3dxyzt_d = 6
  ELSE
    nfld3dxyzt_d = 4
  ENDIF

  ALLOCATE ( fld3dxyzt_d ( nfld3dxyzt_d ) )

  DO nn = 1, nfld3dxyzt_d
    ALLOCATE ( fld3dxyzt_d(nn)%fld(ncols+1,nrows+1,nlays) )
  ENDDO

  c_uwindc  => fld3dxyzt_d( 1)
  c_vwindc  => fld3dxyzt_d( 2)
  c_uhat_jd => fld3dxyzt_d( 3)
  c_vhat_jd => fld3dxyzt_d( 4)

  IF ( luvbout > 0 ) THEN
    c_uwind   => fld3dxyzt_d( 5)
    c_vwind   => fld3dxyzt_d( 6)
  ENDIF

!-------------------------------------------------------------------------------
! Time-varying 3d fields (soil layers) at cell centers.
!-------------------------------------------------------------------------------

  IF ( ifsoil ) THEN

    nfld3dxyst = 2

    ALLOCATE ( fld3dxyst ( nfld3dxyst ) )

    DO nn = 1, nfld3dxyst
      ALLOCATE ( fld3dxyst(nn)%fld(ncols,nrows,metsoi) )
    ENDDO

    c_soit3d   => fld3dxyst( 1)
    c_soim3d   => fld3dxyst( 2)

  ELSE

    nfld3dxyst = 0

  ENDIF

!-------------------------------------------------------------------------------
! Time-varying 3d fields (mosaic land use categories) at cell centers.
!-------------------------------------------------------------------------------

  IF ( ifmosaic ) THEN

    nfld3dxymt = 7

    ALLOCATE ( fld3dxymt ( nfld3dxymt ) )

    DO nn = 1, nfld3dxymt
      ALLOCATE ( fld3dxymt(nn)%fld(ncols,nrows,nummosaic) )
    ENDDO

    c_lufrac2  => fld3dxymt( 1)
    c_moscat   => fld3dxymt( 2)
    c_lai_mos  => fld3dxymt( 3)
    c_rai_mos  => fld3dxymt( 4)
    c_rsi_mos  => fld3dxymt( 5)
    c_tsk_mos  => fld3dxymt( 6)
    c_znt_mos  => fld3dxymt( 7)

  ELSE

    nfld3dxymt = 0

  ENDIF

END SUBROUTINE alloc_ctm

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 wrt( n, a, nu)
      integer n, nu
      real*8 a(n)
      write(nu) a
      return
      end

max_stars_repo_name: MOLFDIR/MOLFDIR

max_issues_repo_name: yingxingcheng/MOLFDIR

max_forks_repo_name: yingxingcheng/MOLFDIR


Module cairo_path
  Use ieee_arithmetic
  Use iso_c_binding
  Use cairo_surface
  IMPLICIT NONE
  PRIVATE

  Type, Public :: CairoPath
    type(c_ptr) :: path = C_NULL_PTR
  Contains
    procedure :: init => CairoPathInit
    procedure :: moveTo => Cairo_moveTo
    procedure :: lineTo => Cairo_lineTo
    procedure :: setSourceRGB => Cairo_setSourceRGB
    procedure :: setSourceRGBA => Cairo_setSourceRGBA
    procedure :: translate => Cairo_translate
    procedure :: fscale => Cairo_fscale
    procedure :: rotate => Cairo_rotate
    procedure :: arc => Cairo_arc
    procedure :: arcNegative => Cairo_arcNegative
    procedure :: curveTo => Cairo_curveTo
    procedure :: setLineWidth => Cairo_setLineWidth
    procedure :: rectangle => Cairo_rectangle
    procedure :: pushGroup => Cairo_pushGroup
    procedure :: popGroup => Cairo_popGroup
    procedure :: fill => Cairo_fill
    procedure :: paint => Cairo_paint
    procedure :: paintWithAlpha => Cairo_paintWithAlpha
    procedure :: newPath => Cairo_newPath
    procedure :: newSubPath => Cairo_newSubPath
    procedure :: closePath => Cairo_closePath
    procedure :: stroke => Cairo_stroke
    final :: CairoPathFinal
  End Type CairoPath

  Interface
    Function cairo_create(surface) Bind(C, NAME="cairo_create")
      Use iso_c_binding
      type(c_ptr), value :: surface
      type(c_ptr) :: cairo_create
    End Function cairo_create

    Subroutine cairo_destroy(path) Bind(C, NAME="cairo_destroy")
      Use iso_c_binding
      type(c_ptr), value :: path
    End Subroutine cairo_destroy

    Subroutine f_move_to(surface, x, y) &
        Bind(C, NAME="cairo_move_to")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: y, x
    End Subroutine f_move_to

    Subroutine f_line_to(surface, x, y) &
        Bind(C, NAME="cairo_line_to")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: y, x
    End Subroutine f_line_to

    Subroutine f_set_source_rgb(surface, red, green, blue) &
        Bind(C, NAME="cairo_set_source_rgb")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: blue, green, red
    End Subroutine f_set_source_rgb

    Subroutine f_set_source_rgba(surface, red, green, blue, alpha) &
        Bind(C, NAME="cairo_set_source_rgba")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: alpha, blue, green, red
    End Subroutine f_set_source_rgba

    Subroutine f_translate(surface, tx, ty) &
        Bind(C, NAME="cairo_translate")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: ty, tx
    End Subroutine f_translate

    Subroutine f_scale(surface, sx, sy) &
        Bind(C, NAME="cairo_scale")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: sy, sx
    End Subroutine f_scale

    Subroutine f_rotate(surface, angle) &
        Bind(C, NAME="cairo_rotate")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: angle
    End Subroutine f_rotate

    Subroutine f_arc(surface, xc, yc, radius, angle1, angle2) &
        Bind(C, NAME="cairo_arc")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: angle2, angle1, radius, yc, xc
    End Subroutine f_arc

    Subroutine f_arc_negative(surface, xc, yc, radius, angle1, angle2) &
        Bind(C, NAME="cairo_arc_negative")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: angle2, angle1, radius, yc, xc
    End Subroutine f_arc_negative

    Subroutine f_curve_to(surface, x1, y1, x2, y2, x3, y3) &
        Bind(C, NAME="cairo_curve_to")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: y3, x3, y2, x2, y1, x1
    End Subroutine f_curve_to

    Subroutine f_set_line_width(surface, w) &
        Bind(C, NAME="cairo_set_line_width")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: w
    End Subroutine f_set_line_width

    Subroutine f_rectangle(surface, x, y, width, height) &
        Bind(C, NAME="cairo_rectangle")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: height, width, y, x
    End Subroutine f_rectangle

    Subroutine f_push_group(surface) &
        Bind(C, NAME="cairo_push_group")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_push_group

    Subroutine f_pop_group(surface) &
        Bind(C, NAME="cairo_pop_group")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_pop_group

    Subroutine f_fill(surface) &
        Bind(C, NAME="cairo_fill")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_fill

    Subroutine f_paint(surface) &
        Bind(C, NAME="cairo_paint")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_paint

    Subroutine f_paint_with_alpha(surface, alpha) &
        Bind(C, NAME="cairo_paint_with_alpha")
      Use iso_c_binding
      type(c_ptr), value :: surface
      real(c_double), value :: alpha
    End Subroutine f_paint_with_alpha

    Subroutine f_new_path(surface) &
        Bind(C, NAME="cairo_new_path")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_new_path

    Subroutine f_new_sub_path(surface) &
        Bind(C, NAME="cairo_new_sub_path")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_new_sub_path

    Subroutine f_close_path(surface) &
        Bind(C, NAME="cairo_close_path")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_close_path

    Subroutine f_stroke(surface) &
        Bind(C, NAME="cairo_stroke")
      Use iso_c_binding
      type(c_ptr), value :: surface
    End Subroutine f_stroke
  End Interface
Contains
  Integer Function CairoPathInit(this, surface) Result(info)
    class(CairoPath), intent(inout) :: this
    class(CairoSurface), intent(inout) :: surface
    info = -1
    this%path = cairo_create(surface%surface)
    If(C_ASSOCIATED(this%path)) info = 0
  End Function CairoPathInit

  Subroutine Cairo_moveTo(this, x, y)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: y, x
    CALL f_move_to(this%path, x, y)
  End Subroutine Cairo_moveTo

  Subroutine Cairo_lineTo(this, x, y)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: y, x
    CALL f_line_to(this%path, x, y)
  End Subroutine Cairo_lineTo

  Subroutine Cairo_setSourceRGB(this, red, green, blue)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: blue, green, red
    CALL f_set_source_rgb(this%path, red, green, blue)
  End Subroutine Cairo_setSourceRGB

  Subroutine Cairo_setSourceRGBA(this, red, green, blue, alpha)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: alpha, blue, green, red
    CALL f_set_source_rgba(this%path, red, green, blue, alpha)
  End Subroutine Cairo_setSourceRGBA

  Subroutine Cairo_translate(this, tx, ty)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: ty, tx
    CALL f_translate(this%path, tx, ty)
  End Subroutine Cairo_translate

  Subroutine Cairo_fscale(this, sx, sy)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: sy, sx
    CALL f_scale(this%path, sx, sy)
  End Subroutine Cairo_fscale

  Subroutine Cairo_rotate(this, angle)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: angle
    CALL f_rotate(this%path, angle)
  End Subroutine Cairo_rotate

  Subroutine Cairo_arc(this, xc, yc, radius, angle1, angle2)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: angle2, angle1, radius, yc, xc
    CALL f_arc(this%path, xc, yc, radius, angle1, angle2)
  End Subroutine Cairo_arc

  Subroutine Cairo_arcNegative(this, xc, yc, radius, angle1, angle2)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: angle2, angle1, radius, yc, xc
    CALL f_arc_negative(this%path, xc, yc, radius, angle1, angle2)
  End Subroutine Cairo_arcNegative

  Subroutine Cairo_curveTo(this, x1, y1, x2, y2, x3, y3)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: y3, x3, y2, x2, y1, x1
    CALL f_curve_to(this%path, x1, y1, x2, y2, x3, y3)
  End Subroutine Cairo_curveTo

  Subroutine Cairo_setLineWidth(this, w)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: w
    CALL f_set_line_width(this%path, w)
  End Subroutine Cairo_setLineWidth

  Subroutine Cairo_rectangle(this, x, y, width, height)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: height, width, y, x
    CALL f_rectangle(this%path, x, y, width, height)
  End Subroutine Cairo_rectangle

  Subroutine Cairo_pushGroup(this)
    class(CairoPath), intent(inout) :: this
    CALL f_push_group(this%path)
  End Subroutine Cairo_pushGroup

  Subroutine Cairo_popGroup(this)
    class(CairoPath), intent(inout) :: this
    CALL f_pop_group(this%path)
  End Subroutine Cairo_popGroup

  Subroutine Cairo_fill(this)
    class(CairoPath), intent(inout) :: this
    CALL f_fill(this%path)
  End Subroutine Cairo_fill

  Subroutine Cairo_paint(this)
    class(CairoPath), intent(inout) :: this
    CALL f_paint(this%path)
  End Subroutine Cairo_paint

  Subroutine Cairo_paintWithAlpha(this, alpha)
    class(CairoPath), intent(inout) :: this
    real(c_double), intent(in) :: alpha
    CALL f_paint_with_alpha(this%path, alpha)
  End Subroutine Cairo_paintWithAlpha

  Subroutine Cairo_newPath(this)
    class(CairoPath), intent(inout) :: this
    CALL f_new_path(this%path)
  End Subroutine Cairo_newPath

  Subroutine Cairo_newSubPath(this)
    class(CairoPath), intent(inout) :: this
    CALL f_new_sub_path(this%path)
  End Subroutine Cairo_newSubPath

  Subroutine Cairo_closePath(this)
    class(CairoPath), intent(inout) :: this
    CALL f_close_path(this%path)
  End Subroutine Cairo_closePath

  Subroutine Cairo_stroke(this)
    class(CairoPath), intent(inout) :: this
    CALL f_stroke(this%path)
  End Subroutine Cairo_stroke

  Subroutine CairoPathFinal(this)
    type(CairoPath) :: this
    If(C_ASSOCIATED(this%path)) CALL cairo_destroy(this%path)
    this%path = C_NULL_PTR
  End Subroutine CairoPathFinal
End Module cairo_path


text:
! two_lists.f90 --
!     Program illustrating the use of several types of lists
!     in one program
!
!     $Id$
!
! Convenience module, holding all the data types
!
module DATA_MODULE

type REAL_DATA
    real :: value
end type REAL_DATA

type STRING_DATA
    character(len=20) :: string
end type STRING_DATA

end module DATA_MODULE

!
! Modules defining the individal list types
!
module REAL_LISTS
    use DATA_MODULE, ONLY: LIST_DATA => REAL_DATA

    include "linkedlist.f90"
end module REAL_LISTS

module STRING_LISTS
    use DATA_MODULE, ONLY: LIST_DATA => STRING_DATA

    include "linkedlist.f90"
end module STRING_LISTS

!
! Module uniting the two, so that we can use
! a single set of routines
!
module TWO_LIST_TYPES
    use REAL_LISTS, only: REAL_LINKED_LIST   => LINKED_LIST,   &
                          REAL_LIST_DATA     => LIST_DATA,     &
                          list_create_real   => list_create,   &
                          list_insert_real   => list_insert,   &
                          list_next_real     => list_next,     &
                          list_get_real_data => list_get_data, &
                          list_put_real_data => list_put_data, &
                          list_delete_real   => list_delete_element, &
                          list_destroy_real  => list_destroy

    use STRING_LISTS, only: STRING_LINKED_LIST   => LINKED_LIST,   &
                          STRING_LIST_DATA       => LIST_DATA,     &
                          list_create_string     => list_create,   &
                          list_insert_string     => list_insert,   &
                          list_next_string       => list_next,     &
                          list_get_string_data   => list_get_data, &
                          list_put_string_data   => list_put_data, &
                          list_delete_string     => list_delete_element, &
                          list_destroy_string    => list_destroy
    private
    public :: list_create, list_destroy, list_get_data, list_put_data, &
              list_insert, list_next, list_delete_string
    public :: REAL_LINKED_LIST, STRING_LINKED_LIST
    public :: REAL_LIST_DATA, STRING_LIST_DATA

    interface list_create
        module procedure list_create_real
        module procedure list_create_string
    end interface

    interface list_destroy
        module procedure list_destroy_real
        module procedure list_destroy_string
    end interface

    interface list_insert
        module procedure list_insert_real
        module procedure list_insert_string
    end interface

    interface list_next
        module procedure list_next_real
        module procedure list_next_string
    end interface

    interface list_get_data
        module procedure list_get_real_data
        module procedure list_get_string_data
    end interface

    interface list_put_data
        module procedure list_put_real_data
        module procedure list_put_string_data
    end interface

    interface list_delete_element
        module procedure list_delete_real
        module procedure list_delete_string
    end interface
end module TWO_LIST_TYPES

program test_list
    use TWO_LIST_TYPES

    implicit none

    type(REAL_LINKED_LIST), pointer :: real_list
    type(REAL_LINKED_LIST), pointer :: real_elem
    type(REAL_LIST_DATA)            :: real_data

    type(STRING_LINKED_LIST), pointer :: string_list
    type(STRING_LINKED_LIST), pointer :: string_elem
    type(STRING_LIST_DATA)            :: string_data

    !
    ! Add elements at the start (so we get: D, C, B, A)
    ! Elements are always added after the given element ...
    !
    string_data%string = 'D'
    call list_create( string_list, string_data )

    string_data%string = 'A'
    call list_insert( string_list, string_data )
    string_data%string = 'B'
    call list_insert( string_list, string_data )
    string_data%string = 'C'
    call list_insert( string_list, string_data )

    call print_list_string( 'Expected: D, C, B, A', string_list )

    !
    ! Do the same for a list of reals
    !
    real_data%value = 1.0
    call list_create( real_list, real_data )
    real_data%value = 2.0
    call list_insert( real_list, real_data )
    real_data%value = 3.0
    call list_insert( real_list, real_data )

    call print_list_real( 'Expected: 1.0, 3.0, 2.0 (insertion after the head)', real_list )

contains

subroutine print_list_string( text, list )
    character(len=*)                   :: text
    type(STRING_LINKED_LIST), pointer  :: list

    type(STRING_LINKED_LIST), pointer  :: elem
    type(STRING_LIST_DATA)             :: data
    integer                            :: i

    write(*,*) text
    !
    ! Loop over the list
    !
    i = 0
    elem => list
    do while( associated(elem) )
        data = list_get_data(elem)
        write(*,*) i, data%string
        elem => list_next(elem)
        i = i + 1
    enddo

end subroutine print_list_string

subroutine print_list_real( text, list )
    character(len=*)                 :: text
    type(REAL_LINKED_LIST), pointer  :: list

    type(REAL_LINKED_LIST), pointer  :: elem
    type(REAL_LIST_DATA)             :: data
    integer                          :: i

    write(*,*) text
    !
    ! Loop over the list
    !
    i = 0
    elem => list
    do while( associated(elem) )
        data = list_get_data(elem)
        write(*,*) i, data%value
        elem => list_next(elem)
        i = i + 1
    enddo

end subroutine print_list_real

end program

max_stars_repo_name: timcera/flibs

max_issues_repo_name: timcera/flibs

max_forks_repo_name: timcera/flibs


text:
      module boundaries
      use kind_spec
      integer ::  mnmax_vv, dimnow, mnmax_bd, mnmax_pl, mpol_pl, ntor_pl
      integer ::  nrad
      real(rprec), dimension(:),  allocatable  ::
     1  rmnc_vv, zmns_vv, xm_vv, xn_vv,
     1  rmnc_bd, zmns_bd, xm_bd, xn_bd,
     1  rmns_vv, zmnc_vv, rmns_bd, zmnc_bd,
     1  rmnc_pl, zmns_pl, xm_pl, xn_pl, rmns_pl, zmnc_pl
      logical vv , bd
      end module boundaries
      module Vpname1
      use kind_spec
      integer, parameter :: nthpts = 99
      integer, parameter :: nfloops = 40
      integer, parameter :: nbloops = 40
      integer, parameter :: nbsetsp = 2
      integer, parameter :: nbcoilsp = 50
      integer, parameter :: nbrbz_id = 1
      integer, parameter :: nmirnov_id = 2
      integer :: nrt
      real(kind=rprec), parameter :: dmu0 = 1.256637d-06
      end module Vpname1

      module Vpname2
      use kind_spec
      use Vpname1
      integer, dimension(:), allocatable :: ixm, ixn
      integer :: nbrbz, nmirnov,  nmirnovset
      real(kind=rprec), dimension(:), allocatable :: dbzcods, ffp, ub,
     1   iotaf, darea, iotazb, psi, itors, ipols
      real(kind=rprec), dimension(:), allocatable :: brcoil, plbrfld,
     1   brbc, bzcoil, plbzfld, bzbc
      real(kind=rprec), dimension(:), allocatable :: sqrt_phimod,
     1   phimod, dbsubudstz, bsubutz, bsubvtz
      real(kind=rprec) :: itor, ipol
      character   limpos_file*40, gmeta_file*40
      character   cdate*30, runlabel*60
      end module Vpname2

      module Vpname3
      use kind_spec
      integer, parameter :: nlimd = 50
      integer, parameter :: nlimset = 2
      integer, parameter :: nltot = nlimd*nlimset
      integer, parameter :: ndim1 = 100
      integer, parameter :: n2max = 40
      integer, parameter :: nsetsmax = 13
      integer :: initnml = 0, ltouch
      integer, dimension(nsetsmax) :: ipset
      real(kind=rprec) :: rx1sv, rx2sv, zy1sv, zy2sv, condifsv
      character :: tokid1*20
      integer :: nrgridsv, nzgridsv
      real(kind=rprec), dimension(ndim1) :: rgrid, zgrid
      real(kind=rprec), dimension(:,:), allocatable :: pfltot
      real(kind=rprec), dimension(:,:,:), allocatable :: pflcoilgr
      real(kind=rprec), dimension(nlimd,nlimset) :: xlim, ylim
      real(kind=rprec), dimension(nltot) :: xlimt, ylimt, seplimt
      integer :: nrgrid_17 = 60, nzgrid_17 = 60,
     1           nrgrid_18 = 60, nzgrid_18 = 60
      real(kind=rprec) :: rx1_17 = 1.5, rx2_17 = 4.0, zy1_17 = -1.40,
     1        zy2_17 = 1.40,
     1        rx1_18 = 0.6, rx2_18 = 5.0, zy1_18 = -2.88, zy2_18 = 2.88
      end module Vpname3

      module Vindat2
      use kind_spec
      integer   mn0
      real(kind=rprec) :: hs, ohs, twopi
      end module Vindat2

      module Vmagaxis
      use kind_spec
      real(kind=rprec) :: rmagaxis, zmagaxis
      end module Vmagaxis

      module Vplotdata
      use kind_spec
      integer :: ndata, j1
      integer, parameter :: iselect = 2
      real, parameter :: lx1 = 0.10
      real, parameter :: lx2 = 0.50
      real, parameter :: lx3 = 0.50
      real, parameter :: lx4 = 0.90
      real, parameter :: ly1 = 0.10
      real, parameter :: ly2 = 0.50
      real, parameter :: ly3 = 0.50
      real, parameter :: ly4 = 0.90
      real, dimension(4,5) :: gwnd
      real, dimension(100) :: rdata, pldata

      data (gwnd(j1,1),j1=1,4) / lx1, lx2, ly3, ly4 /
      data (gwnd(j1,2),j1=1,4) / lx3, lx4, ly3, ly4 /
      data (gwnd(j1,3),j1=1,4) / lx1, lx2, ly1, ly2 /
      data (gwnd(j1,4),j1=1,4) / lx3, lx4, ly1, ly2 /
      data (gwnd(j1,5),j1=1,4) / lx1, lx4, ly1, ly4 /

      end module Vplotdata

      module Vpltcn2
      use kind_spec
      real(kind=rprec) :: rmin, rmax, zmin, zmax
      end module Vpltcn2
      module pgplotinc
C-----------------------------------------------------------------------
C This module is simply a copy of pgplot.inc from version 5.2
C This module may need updating with future releases of PGPLOT
C Contents used for basic coordinate conversions, e.g., xyitoxys
C Ed Lazarus
C-----------------------------------------------------------------------
C PGPLOT: common block definition.
C-----------------------------------------------------------------------
C Maximum number of concurrent devices (should match GRIMAX).
C-----------------------------------------------------------------------
      INTEGER PGMAXD
      PARAMETER (PGMAXD=8)
C-----------------------------------------------------------------------
C Indentifier of currently selected device.
C-----------------------------------------------------------------------
      INTEGER PGID
C-----------------------------------------------------------------------
C Device status (indexed by device identifier).
C-----------------------------------------------------------------------
C PGDEVS  =0 if device is not open; 1 if device is open.
C PGADVS  Set to 0 by PGBEGIN, set to 1 by PGPAGE; used to suppress
C         the prompt for the first page.
C PROMPT  If .TRUE., ask user before clearing page; set by PGASK
C         and (indirectly) by PGBEGIN, used in PGENV.
C PGBLEV  Buffering level: incremented by PGBBUF, decremented by
C         PGEBUF.
C PGPFIX  TRUE if PGPAP has been called, FALSE otherwise.
C
      INTEGER PGDEVS(PGMAXD), PGADVS(PGMAXD), PGBLEV(PGMAXD)
      LOGICAL PGPRMP(PGMAXD), PGPFIX(PGMAXD)
C-----------------------------------------------------------------------
C Panel parameters (indexed by device identification).
C-----------------------------------------------------------------------
C NX      Number of panels in x direction
C NY      Number of panels in y direction
C NXC     Ordinal number of current X panel
C NYC     Ordinal number of current Y panel
C XSZ     X dimension of panel (device units)
C YSZ     Y dimension of panel (device units)
C PGROWS  TRUE if panels are used in row order, FALSE for column
C         order.
C
      INTEGER PGNX  (PGMAXD), PGNY  (PGMAXD)
      INTEGER PGNXC (PGMAXD), PGNYC (PGMAXD)
      REAL    PGXSZ (PGMAXD), PGYSZ (PGMAXD)
      LOGICAL PGROWS(PGMAXD)
C-----------------------------------------------------------------------
C Attributes (indexed by device identification).
C-----------------------------------------------------------------------
C PGCLP   clipping enabled/disabed
C PGFAS   fill-area style
C PGCHSZ  character height
C PGAHS   arrow-head fill style
C PGAHA   arrow-head angle
C PGAHV   arrow-head vent
C PGTBCI  text background color index
C PGMNCI  lower range of color indices available to PGGRAY/PGIMAG
C PGMXCI  upper range of color indices available to PGGRAY/PGIMAG
C PGITF   type of transfer function used by PGGRAY/PGIMAG
C PGHSA   hatching line angle
C PGHSS   hatching line separation
C PGHSP   hatching line phase
C
      INTEGER PGCLP (PGMAXD)
      INTEGER PGFAS (PGMAXD)
      REAL    PGCHSZ(PGMAXD)
      INTEGER PGAHS (PGMAXD)
      REAL    PGAHA (PGMAXD)
      REAL    PGAHV (PGMAXD)
      INTEGER PGTBCI(PGMAXD)
      INTEGER PGMNCI(PGMAXD)
      INTEGER PGMXCI(PGMAXD)
      INTEGER PGITF (PGMAXD)
      REAL    PGHSA (PGMAXD)
      REAL    PGHSS (PGMAXD)
      REAL    PGHSP (PGMAXD)
C-----------------------------------------------------------------------
C Viewport parameters (indexed by device identification); all are device
C coordinates:
C-----------------------------------------------------------------------
C PGXOFF  X coordinate of blc of viewport.
C PGYOFF  Y coordinate of blc of viewport.
C PGXVP   X coordinate of blc of viewport, relative to blc of subpage.
C PGYVP   Y coordinate of blc of viewport, relative to blc of subpage.
C PGXLEN  Width of viewport.
C PGYLEN  Height of viewport.
C
      REAL   PGXOFF(PGMAXD), PGYOFF(PGMAXD)
      REAL   PGXVP (PGMAXD), PGYVP (PGMAXD)
      REAL   PGXLEN(PGMAXD), PGYLEN(PGMAXD)
C-----------------------------------------------------------------------
C Scaling parameters (indexed by device identification):
C-----------------------------------------------------------------------
C PGXORG  device coordinate value corresponding to world X=0
C PGYORG  device coordinate value corresponding to world Y=0
C PGXSCL  scale in x (device units per world coordinate unit)
C PGYSCL  scale in y (device units per world coordinate unit)
C PGXPIN  device x scale in device units/inch
C PGYPIN  device y scale in device units/inch
C PGXSP   Character X spacing (device units)
C PGYSP   Character Y spacing (device units)
C
      REAL   PGXORG(PGMAXD), PGYORG(PGMAXD)
      REAL   PGXSCL(PGMAXD), PGYSCL(PGMAXD)
      REAL   PGXPIN(PGMAXD), PGYPIN(PGMAXD)
      REAL   PGXSP (PGMAXD), PGYSP (PGMAXD)
C-----------------------------------------------------------------------
C Window parameters (indexed by device identification); all are world
C coordinate values:
C-----------------------------------------------------------------------
C PGXBLC  world X at bottom left corner of window
C PGXTRC  world X at top right corner of window
C PGYBLC  world Y at bottom left corner of window
C PGYTRC  world Y at top right corner of window
C
      REAL    PGXBLC(PGMAXD), PGXTRC(PGMAXD)
      REAL    PGYBLC(PGMAXD), PGYTRC(PGMAXD)
C-----------------------------------------------------------------------
C The following parameters are used in the contouring routines to pass
C information to the action routine. They do not need to be indexed.
C-----------------------------------------------------------------------
C TRANS   Transformation matrix for contour plots; copied
C         from argument list by PGCONT and used by PGCP.
C
      INTEGER PGCINT, PGCMIN
      REAL    TRANS(6)
      CHARACTER*32 PGCLAB
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      COMMON/PGPLT1/ PGID,PGDEVS,PGADVS,PGNX,  PGNY,  PGNXC, PGNYC ,
     1        PGXPIN,PGYPIN,PGXSP, PGYSP, PGXSZ, PGYSZ,
     2        PGXOFF,PGYOFF,PGXVP, PGYVP, PGXLEN,PGYLEN,PGXORG,PGYORG,
     3        PGXSCL,PGYSCL,PGXBLC,PGXTRC,PGYBLC,PGYTRC,TRANS,
     4        PGPRMP,PGCLP, PGFAS, PGCHSZ,PGBLEV,PGROWS,
     5        PGAHS, PGAHA, PGAHV, PGTBCI,PGMNCI,PGMXCI,PGCINT,PGCMIN,
     6        PGPFIX,PGITF, PGHSA, PGHSS, PGHSP
      COMMON/PGPLT2/ PGCLAB
      SAVE    /PGPLT1/
      SAVE    /PGPLT2/
C-----------------------------------------------------------------------
      end module pgplotinc
      module grpckg1inc

C-----------------------------------------------------------------------
C      From PGPLOT V5.2 -- Be sure this is up-to-date
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C            Include file for GRPCKG
C Modifications:
C   29-Jan-1985 - add HP2648 (KS/TJP).
C   16-Sep-1985 - remove tabs (TJP).
C   30-Dec-1985 - add PS, VPS (TJP).
C   27-May-1987 - remove ARGS, NULL, PS, VPS, QMS, VQMS, HIDMP,
C                 HP7221, GRINL (TJP).
C    6-Jun-1987 - remove PRTX, TRILOG, VERS, VV (TJP).
C   11-Jun-1987 - remove remaining built-in devices (TJP).
C    5-Jul-1987 - replace GRINIT, GRPLTD by GRSTAT.
C   16-Aug-1987 - remove obsolete variables.
C    9-Sep-1989 - add SAVE statement.
C   26-Nov-1990 - remove GRCTYP.
C    5-Jan-1993 - add GRADJU.
C    1-Sep-1994 - add GRGCAP.
C   21-Dec-1995 - increase GRIMAX to 8.
C   30-Apr-1997 - remove GRC{XY}SP
C-----------------------------------------------------------------------
C
C Parameters:
C   GRIMAX : maximum number of concurrent devices
C   GRFNMX : maximum length of file names
C   GRCXSZ : default width of chars (pixels)
C   GRCYSZ : default height of chars (pixels)
C
      INTEGER   GRIMAX, GRFNMX
      REAL      GRCXSZ, GRCYSZ
      PARAMETER (GRIMAX = 8)
      PARAMETER (GRFNMX = 90)
      PARAMETER (GRCXSZ =  7.0, GRCYSZ =  9.0)
C
C Common blocks:
C   GRCIDE : identifier of current plot
C   GRGTYP : device type of current plot
C The following are qualified by a plot id:
C   GRSTAT : 0 => workstation closed
C            1 => workstation open
C            2 => picture open
C   GRPLTD :
C   GRDASH : software dashing in effect?
C   GRUNIT : unit associated with id
C   GRFNLN : length of filename
C   GRTYPE : device type
C   GRXMXA : x size of plotting surface
C   GRYMXA : y size of plotting surface
C   GRXMIN : blc of plotting window
C   GRYMIN : ditto
C   GRXMAX : trc of plotting window
C   GRYMAX : ditto
C   GRSTYL : line style (integer code)
C   GRWIDT : line width (integer code)
C   GRCCOL : current color index (integer code)
C   GRMNCI : minimum color index on this device
C   GRMXCI : maximum color index on this device
C   GRCMRK : marker number
C   GRXPRE : previous (current) pen position (x)
C   GRYPRE : ditto (y)
C   GRXORG : transformation variables (GRTRAN)
C   GRYORG : ditto
C   GRXSCL : ditto
C   GRYSCL : ditto
C   GRCSCL : character scaling factor
C   GRCFAC :
C   GRCFNT : character font
C   GRFILE : file name (character)
C   GRGCAP : device capabilities (character)
C   GRPXPI : pixels per inch in x
C   GRPYPI : pixels per inch in y
C   GRADJU : TRUE if GRSETS (PGPAP) has been called
C
      INTEGER   GRCIDE, GRGTYP
      LOGICAL   GRPLTD(GRIMAX), GRDASH(GRIMAX), GRADJU(GRIMAX)
      INTEGER   GRSTAT(GRIMAX)
      INTEGER   GRUNIT(GRIMAX), GRFNLN(GRIMAX), GRTYPE(GRIMAX),
     1          GRXMXA(GRIMAX), GRYMXA(GRIMAX),
     2          GRSTYL(GRIMAX), GRWIDT(GRIMAX), GRCCOL(GRIMAX),
     3          GRCMRK(GRIMAX), GRIPAT(GRIMAX), GRCFNT(GRIMAX),
     4          GRMNCI(GRIMAX), GRMXCI(GRIMAX)
      REAL      GRXMIN(GRIMAX), GRYMIN(GRIMAX),
     1          GRXMAX(GRIMAX), GRYMAX(GRIMAX)
      REAL      GRXPRE(GRIMAX), GRYPRE(GRIMAX), GRXORG(GRIMAX),
     1          GRYORG(GRIMAX), GRXSCL(GRIMAX), GRYSCL(GRIMAX),
     2          GRCSCL(GRIMAX), GRCFAC(GRIMAX), GRPOFF(GRIMAX),
     3          GRPATN(GRIMAX,8),GRPXPI(GRIMAX),GRPYPI(GRIMAX)
      COMMON /GRCM00/ GRCIDE, GRGTYP, GRSTAT, GRPLTD, GRUNIT,
     1                GRFNLN, GRTYPE, GRXMXA, GRYMXA, GRXMIN, GRYMIN,
     2                GRXMAX, GRYMAX, GRWIDT, GRCCOL, GRSTYL,
     3                GRXPRE, GRYPRE, GRXORG, GRYORG, GRXSCL, GRYSCL,
     4                GRCSCL, GRCFAC, GRDASH, GRPATN, GRPOFF,
     5                GRIPAT, GRCFNT, GRCMRK, GRPXPI, GRPYPI, GRADJU,
     6                GRMNCI, GRMXCI
C
      CHARACTER*(GRFNMX) GRFILE(GRIMAX)
      CHARACTER*11       GRGCAP(GRIMAX)
      COMMON /GRCM01/ GRFILE, GRGCAP
      SAVE /GRCM00/, /GRCM01/
C-----------------------------------------------------------------------
      end module grpckg1inc

      module Vpltcn6
      integer   lxc, lyc, noxc, noyc
      contains
       subroutine newframe
       use pgplotinc, only: pgnxc,pgnyc,pgnx,pgny
       pgnxc=pgnx
       pgnyc=pgny
       return
       end subroutine newframe
      end module Vpltcn6

      module Vrzarray
      use kind_spec
      real(kind=rprec), dimension(:), allocatable :: r, z
      real(kind=rprec), dimension(:), allocatable :: ru, zu
      end module Vrzarray

      module Vtraneq
      use kind_spec
      integer, parameter :: maxmom = 20
      integer, parameter :: maxpsi = 502
      integer, parameter :: maxtht = 502
      integer, parameter :: maxord = 10
      integer   itype, ieqedg, numtht, intord, ieqax, mombnd, nequil,
     1   nstep, njav, mom, ncycle, irun, isyms, ipest, npsit, kmax
      real(kind=rprec), dimension(maxmom) :: rmb, ymb
      real(kind=rprec), dimension(maxpsi) :: psi, press, dpdpsi, q,
     1 dqdpsi, g, ggp, ainvrs
      real(kind=rprec), dimension(maxtht) :: xbound, zbound
      real(kind=rprec) :: zlowp, zlowq, zlowps, zcycp, zcycq, zcycps,
     1   pfilt1, pfilt2, pfilt3, r0b, shotnm, runum, time, btor, rtor,
     2   eqcamp, times, xaxes, zmags, gzeros, apls, betas, betaps,
     3   ali2s, qsaws, psimins, psilims
      character   thdfil*80, flnmi1*80, flnmo1*80
      real(kind=rprec), dimension(maxpsi) :: jdotbc
      real(kind=rprec) :: batot, bapol, bator, baxis
      end module Vtraneq

      module Vcpmpcm1
      integer, parameter :: ntmax = 101
      real, dimension(ntmax) :: comxi, comyj
      end module Vcpmpcm1

      module Vcpmpcm2
      real, dimension(:,:), allocatable :: comxij, comyij
      end module Vcpmpcm2

      module Vcpmpinf
      integer   mxdim, nydim
      end module Vcpmpinf

      module Vthrint
      integer   ithrmj, ithrmn, ithrtx
      end module Vthrint

      module optim
      use optim_params
      implicit none
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      integer, parameter :: nxc = 300
      integer, parameter :: iout = 54
      real(kind=rprec) :: bigno = 1.e10_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: ierr_vmec, ns_booz_max, ns_surf_max
      integer, dimension(nxc) :: nbrho_opt, mbrho_opt
      integer, dimension(2*ntor1d) :: nrz0_opt
      integer :: irho_bdy, irm0_bdy, izm0_bdy,
     1   nrad, num_ai
      integer :: nfp_opt, mpol_opt, mpol1_opt, ntor_opt,
     1      ntor1_opt, mnmax_opt, iunit_opt, iunit_opt_local,
     2      nextcur_opt, nextcur_vmec
      real(kind=rprec), dimension(-ntord:ntord,0:mpol1d) :: rhobc
      real(kind=rprec) :: wp_opt, wb_opt, rmax_opt, rmin_opt, zmax_opt
      real(kind=rprec) :: aspect_opt, coil_complex_opt
      real(kind=rprec) :: chisq_min, rbtor_opt
      real(kind=rprec), dimension(nsd) ::
     1  vp_opt, iota_opt, phip_opt, buco_opt, Dmerc_opt, jdotb_opt
      real(kind=rprec), dimension(nsd) ::  pres_opt                            !!COBRA
      real(kind=rprec) :: version_opt, am0_9, am10                             !!COBRA
      real(kind=rprec) :: raxis_old(0:ntord), zaxis_old(0:ntord)

      integer, allocatable :: ns_booz(:), ns_surf(:)
      character*120 :: input_file, home_dir, min_ext
      character*130 :: output_file, min_input_file, min_wout_file
c-----------------------------------------------
      end module optim

      module cmnf1
      use kind_spec
      integer :: nmn1
      real(rprec), allocatable, dimension(:) ::  xm1, xn1, rmn1, zmn1
      real(rprec) :: q1
      end module cmnf1

      module cmnf2
      use kind_spec
      integer :: nmn2
      real(rprec), allocatable, dimension(:) ::  xm2, xn2, rmn2, zmn2
      real(rprec) :: q2
      end module cmnf2

      module geom
      use kind_spec
      real(rprec) ::  xp, yp, zp, pi2, alp
      end module geom

      module newtv
      use kind_spec
      integer, parameter :: np=40
      integer :: nn
      real(rprec) :: fvec(np)
      end module newtv


text:
! osutils.f90 --
!     Utilities to interface with the operating system
!     -- do not edit: generated code --
module osutils
    implicit none
    !
    ! Convenience interfaces
    !
! system() needs no interface
contains
end module

max_stars_repo_name: dorrabbkhan/atlnts-infrastructure

max_issues_repo_name: dorrabbkhan/atlnts-infrastructure

max_forks_repo_name: dorrabbkhan/atlnts-infrastructure


text:
#:include "errorfx.fypp"

program propagate
  use errorfx, only : fatal_error, create_error
  implicit none

  call main()

contains

  ! A routine (throw_fatal_error) is called, which may throw an error. In case an error occured
  ! it is handled

  subroutine main()

    type(fatal_error), allocatable :: error
    print "(a)", "Calling routine1"
    call routine1(error)
    print "(a)", "Handling error returned by routine1"
    #:block catch_error("error")
      print "(a,a,a,i0,a)", "Fatal error found: '", error%message, "' (code: ", error%code, ")"
    #:endblock

  end subroutine main

  subroutine routine1(error)
    type(fatal_error), allocatable, intent(out) :: error

    call routine2(error)
    ! We do not handle the error, just propagate it upwards
    @:propagate_error(error)
    print "(a)", "if you see this, routine2 returned without error"

  end subroutine routine1

  subroutine routine2(error)
    type(fatal_error), allocatable, intent(out) :: error

    @:throw_error(error, message="Routine2 experienced a fatal error")
    print "(a)", "you shoud not see this, as we returned due to an error already"

  end subroutine routine2

end program propagate

ext: fpp

max_stars_repo_name: aradi/fx-error

max_issues_repo_name: aradi/errorfx

max_forks_repo_name: aradi/errorfx


text:
C
C**************************  FVGDDS ************************************
C
C  calculate second derivative of effective saturation with respect to
C  pressure head using van Genuchten characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FVGDDS(PSI,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   BETA,B1,B1R
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. -1.0D-14) THEN
         BETA=ABS((PSI/VGPSAT(INOD)))**VGN(INOD)
         B1=BETA+1.0D0
         B1R=1.0D0/B1
         FVGDDS=VGN1(INOD)*(BETA/PSI)*(1.0D0/PSI)*
     1               ((1.0D0 + VGN(INOD)*(BETA - 1.0D0))/
     2               (ABS(B1)**VGM(INOD)))*B1R*B1R
      ELSE
         FVGDDS=0.0D0
      END IF
C
      RETURN
      END


text:
! Problem-specific Fortran routines that are designed to interact with C++

subroutine problem_checkpoint(int_dir_name, len) bind(C, name="problem_checkpoint")

  ! called by the IO processor during checkpoint

  use amrex_IO_module
  use castro_error_module, only: castro_error
  use probdata_module, only: com_P, com_S, vel_P, vel_S, mass_P, mass_S, t_ff_P, t_ff_S, &
                             T_global_max, rho_global_max, ts_te_global_max, jobIsDone, &
                             signalJobIsNotDone, num_previous_ener_timesteps, total_ener_array, &
                             relaxation_is_done
  use prob_params_module, only: center
  use meth_params_module, only: rot_period

  implicit none

  integer :: len
  integer :: int_dir_name(len)
  character (len=len) :: dir

  integer :: i, un

  ! dir will be the string name of the checkpoint directory
  do i = 1, len
     dir(i:i) = char(int_dir_name(i))
  enddo

  un = unit_new()
  open (unit=un, file=trim(dir)//"/COM", status="unknown")

100 format(1x, g30.20)
200 format(1x, g30.20, 1x, g30.20)
300 format(1x, g30.20, 1x, g30.20, 1x, g30.20)

  write (un,300) center(1), center(2), center(3)
  write (un,200) mass_P,   mass_S
  write (un,200) com_P(1), com_S(1)
  write (un,200) com_P(2), com_S(2)
  write (un,200) com_P(3), com_S(3)
  write (un,200) vel_P(1), vel_S(1)
  write (un,200) vel_P(2), vel_S(2)
  write (un,200) vel_P(3), vel_S(3)
  write (un,200) t_ff_P,   t_ff_S

  close (un)

  open (unit=un, file=trim(dir)//"/Rotation", status="unknown")

  write (un,100) rot_period

  close (un)

  open (unit=un, file=trim(dir)//"/Extrema", status="unknown")

  write (un,100) T_global_max
  write (un,100) rho_global_max
  write (un,100) ts_te_global_max

  close (un)

  open (unit=un, file=trim(dir)//"/Energy", status="unknown")

  do i = 1, num_previous_ener_timesteps

     write (un,100) total_ener_array(i)

  enddo

  close (un)

  open (unit=un, file=trim(dir)//"/Relaxation", status="unknown")

  write (un,100) relaxation_is_done

  close (un)

  ! If the job is done, write a file in the checkpoint indicating this.

  if (jobIsDone) then

     open  (unit=un, file=trim(dir)//"/jobIsDone", status="unknown")
     close (un)

  else

     if (signalJobIsNotDone .and. .not. jobIsDone) then

        open  (unit=un, file=trim(dir)//"/jobIsNotDone", status="unknown")
        close (un)

     endif

  endif

end subroutine problem_checkpoint

subroutine problem_restart(int_dir_name, len) bind(C, name="problem_restart")

  ! called by ALL processors during restart

  use amrex_fort_module, only: rt => amrex_real
  use amrex_IO_module
  use probdata_module, only: com_P, com_S, vel_P, vel_S, mass_P, mass_S, t_ff_P, t_ff_S, problem, &
                             T_global_max, rho_global_max, ts_te_global_max, &
                             jobIsDone, num_previous_ener_timesteps, total_ener_array, &
                             problem, relaxation_is_done
  use wdmerger_util_module, only: set_relaxation_damping_factor
  use problem_io_module, only: ioproc
  use prob_params_module, only: center
  use meth_params_module, only: rot_period
  use castro_error_module, only: castro_error

  implicit none

  integer :: len
  integer :: int_dir_name(len)
  character (len=len) :: dir

  integer :: i, un, stat
  logical :: fileExists

  ! dir will be the string name of the checkpoint directory
  do i = 1, len
     dir(i:i) = char(int_dir_name(i))
  enddo

  un = unit_new()
  open (unit=un, file=trim(dir)//"/COM", status="old")

100 format(1x, g30.20)
200 format(1x, g30.20, 1x, g30.20)
300 format(1x, g30.20, 1x, g30.20, 1x, g30.20)

  read (un,300) center(1), center(2), center(3)
  read (un,200) mass_P,   mass_S
  read (un,200) com_P(1), com_S(1)
  read (un,200) com_P(2), com_S(2)
  read (un,200) com_P(3), com_S(3)
  read (un,200) vel_P(1), vel_S(1)
  read (un,200) vel_P(2), vel_S(2)
  read (un,200) vel_P(3), vel_S(3)
  read (un,200) t_ff_P,   t_ff_S

  close (un)

  if (problem == 1) then

     open (unit=un, file=trim(dir)//"/Rotation", status="old", IOSTAT = stat)

     if (stat .eq. 0) then

        read (un,100) rot_period

        if (ioproc) then
           print *, ""
           write(*,1001) rot_period
           print *, ""

1001       format ("  Based on the checkpoint, updating the rotational period to ", F7.3 " s.")
        endif

        close (un)

     else

        rot_period = -1.0d0

     endif

  endif

  open (unit=un, file=trim(dir)//"/Extrema", status="old", IOSTAT = stat)

  if (stat .eq. 0) then

     read (un,100) T_global_max
     read (un,100) rho_global_max
     read (un,100) ts_te_global_max

     close(un)

  else

     T_global_max = 0.0d0
     rho_global_max = 0.0d0
     ts_te_global_max = 0.0d0

  endif

  open (unit=un, file=trim(dir)//"/Energy", status="old", IOSTAT = stat)

  if (stat .eq. 0) then

     do i = 1, num_previous_ener_timesteps

        read (un,100) total_ener_array(i)

     enddo

     close (un)

  else

     total_ener_array(:) = -1.d200

  endif

  open (unit=un, file=trim(dir)//"/Relaxation", status="old", IOSTAT = stat)

  if (stat .eq. 0) then

     read (un,100) relaxation_is_done

     close (un)

  else

     if (problem == 1) then
        call castro_error("Error: no Relaxation file found in the checkpoint.")
     endif

  endif

  if (relaxation_is_done == 1) then

     call set_relaxation_damping_factor(-1.0_rt)

  endif

  ! Pick up whether the job has been completed.

  inquire(file=trim(dir)//"/jobIsDone", EXIST = fileExists)

  if (fileExists) then

     jobIsDone = .true.

  else

     inquire(file=trim(dir)//"/jobIsNotDone", EXIST = fileExists)

     if (fileExists) then

        jobIsDone = .false.

     endif

  endif

end subroutine problem_restart

max_stars_repo_name: abigailbishop/Castro

max_issues_repo_name: abigailbishop/Castro

max_forks_repo_name: abigailbishop/Castro


text:
!version: 2d decomposition using communcator
!version: routines MPI_COMM_SPLIT
! solves the 2d Stommel Model of Ocean Circulation
! using a Five-point stencil and Jacobi iteration
!
! gamma*((d(d(psi)/dx)/dx) + (d(d(psi)/dy)/dy))
! +beta(d(psi)/dx)=-alpha*sin(pi*y/(2*ly))
!
module numz
! module defines the basic real type and pi
    integer, parameter:: b8 = selected_real_kind(14)
    real(b8), parameter :: pi = 3.141592653589793239_b8
end module
!*********************
module input
! module contains the inputs
    use numz
    integer nx,ny             ! number of interior points for our grid (50 50)
    real(b8) lx,ly            ! physical size of our grid (2000 2000)
    real(b8) alpha,beta,gamma ! parameters of the calculation (1.0e-9 2.25e-11 3.0e-6)
    integer steps             ! number of Jacobi iteration steps (60)
end module
!*********************
module constants
! this module contains the invariants (constants) of the
! calculation.  these values are determined in the main
! routine and used in the do_jacobi Jacobi iteration subroutine
! a6 is used in the force function
    use numz
    real(b8) dx,dy,a1,a2,a3,a4,a5,a6
    real(b8), allocatable:: for(:,:)     ! our force grid
end module
!*********************
module face
! this module contains the interface for the two subroutines
! that modify the grid.  an interface is a good idea in this
! case because we are passing allocatable arrays
    interface bc
        subroutine bc (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface do_jacobi
        subroutine do_jacobi (psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
            real(b8) diff
        end subroutine
    end interface
! interface for the forcing function
    interface force
        function force(y)
            use numz
            real(b8) force,y
        end function force
    end interface
! interface for setting  the force routine
    interface do_force
        subroutine do_force (i1,i2,j1,j2)
! sets the force array
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
! interface for routine to write the grid
    interface write_grid
        subroutine write_grid (psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface do_transfer
        subroutine do_transfer (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
            real(b8),dimension(i1:i2,j1:j2):: psi
        end subroutine
    end interface
    interface unique
        function unique(name)
            character (len=*) name
            character (len=20) unique
        end function
    end interface
end module
module mpi
!DEC$ NOFREEFORM
         include "mpif.h"
!DEC$ FREEFORM
    integer numnodes,myid,mpi_err
    integer, parameter::mpi_master=0
    integer status(MPI_STATUS_SIZE)
    integer nrow,ncol
    integer myrow,mycol
    integer myid_col,myid_row,nodes_row,nodes_col
    integer ROW_COMM,COL_COMM
    integer mytop,mybot,myleft,myright
end module
!*********************

module get_glob
    contains
        subroutine get_index(on_proc,proc_index)
		use mpi
		implicit none
		character (len=MPI_MAX_PROCESSOR_NAME ), allocatable :: the_names(:)
		integer on_proc,proc_index,i
	    allocate(the_names(0:numnodes-1))
	    call MPI_GET_PROCESSOR_NAME(the_names(myid),i,mpi_err)
	    call MPI_allGather(the_names(myid),MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER, &
	                       the_names      ,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER, &
	                       MPI_COMM_WORLD,mpi_err)
	    on_proc=0
	    do i=0,numnodes-1
	        if(LGE(the_names(myid),the_names(i)).and. LLE(the_names(myid),the_names(i)))then
	            on_proc=on_proc+1
	            if(i .eq. myid)proc_index=on_proc
	        endif
	    enddo
!	    write(*,*)"myid = ",myid," which is mpi task ",proc_index," on ",the_names(myid)
	    deallocate(the_names)
	    end subroutine
end module

program stommel
    use numz
    use input
    use constants
    use face
    use mpi
    use get_glob
    implicit none
    character*(MPI_MAX_PROCESSOR_NAME) name
    integer on_proc,proc_index
    real(b8) t1,t2
    real(b8)diff,mydiff
    real(b8)dx2,dy2,bottom
    real(b8), allocatable:: psi(:,:)     ! our calculation grid
    real(b8), allocatable:: new_psi(:,:) ! temp storage for the grid
    integer i,j,i1,i2,j1,j2
    integer omp_get_max_threads,omp_get_num_threads,omp_get_thread_num
    integer iout
    integer n_mpi,n_thread
    real(b8) di,dj
    character (len=80):: aline1,aline2,aline3,aline4
! do the mpi init stuff
    call MPI_INIT( mpi_err )
    call MPI_COMM_SIZE( MPI_COMM_WORLD, numnodes, mpi_err )
    call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpi_err )
    call MPI_GET_PROCESSOR_NAME(name,i,mpi_err)
!    write(*,*)"threads=",omp_get_max_threads()," on ",name
    n_thread=omp_get_num_threads()
    n_mpi=numnodes
! find a reasonable grid topology based on the number
! of processors
  nrow=nint(sqrt(float(numnodes)))
  ncol=numnodes/nrow
  do while (nrow*ncol .ne. numnodes)
      nrow=nrow+1
      ncol=numnodes/nrow
  enddo
  if(nrow .gt. ncol)then
      i=ncol
      ncol=nrow
      nrow=i
  endif
  myrow=myid/ncol+1
  mycol=myid - (myrow-1)*ncol + 1
! make the row and col communicators
! all processors with the same row will be in the same ROW_COMM
  call MPI_COMM_SPLIT(MPI_COMM_WORLD,myrow,mycol,ROW_COMM,mpi_err)
  call MPI_COMM_RANK( ROW_COMM, myid_row, mpi_err )
  call MPI_COMM_SIZE( ROW_COMM, nodes_row, mpi_err )
! all processors with the same col will be in the same COL_COMM
  call MPI_COMM_SPLIT(MPI_COMM_WORLD,mycol,myrow,COL_COMM,mpi_err)
  call MPI_COMM_RANK( COL_COMM, myid_col, mpi_err )
  call MPI_COMM_SIZE( COL_COMM, nodes_col, mpi_err )
! find id of neighbors using the communicators created above
  mytop   = myid_col-1;if( mytop    .lt. 0         )mytop   = MPI_PROC_NULL
  mybot   = myid_col+1;if( mybot    .eq. nodes_col )mybot   = MPI_PROC_NULL
  myleft  = myid_row-1;if( myleft   .lt. 0         )myleft  = MPI_PROC_NULL
  myright = myid_row+1;if( myright  .eq. nodes_row )myright = MPI_PROC_NULL
! get the input.  see above for typical values
aline1="200 200"
aline2="2000000 2000000"
aline3="1.0e-9 2.25e-11 3.0e-6"
aline4="7500"
!write(*,*)"do read"
    if(myid .eq. mpi_master)then
        read(aline1,*)nx,ny
        read(aline2,*)lx,ly
        read(aline3,*)alpha,beta,gamma
        read(aline4,*)steps
        read(*,*)nx,ny
        read(*,*)lx,ly
        read(*,*)alpha,beta,gamma
        read(*,*)steps
        write(*,*)nx,ny
        write(*,*)lx,ly
        write(*,*)alpha,beta,gamma
        write(*,*)steps
    endif
!write(*,*)"do bcast"
!send the data to other processors
    call MPI_BCAST(nx,   1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(ny,   1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(steps,1,MPI_INTEGER,         mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(lx,   1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(ly,   1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(alpha,1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(beta, 1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
    call MPI_BCAST(gamma,1,MPI_DOUBLE_PRECISION,mpi_master,MPI_COMM_WORLD,mpi_err)
!        write(*,*)nx,ny
!        write(*,*)lx,ly
!        write(*,*)alpha,beta,gamma
!        write(*,*)steps
!write(*,*)"! calculate the constants for the calculations"
    dx=lx/(nx+1)
    dy=ly/(ny+1)
    dx2=dx*dx
    dy2=dy*dy
    bottom=2.0_b8*(dx2+dy2)
    a1=(dy2/bottom)+(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a2=(dy2/bottom)-(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a3=dx2/bottom
    a4=dx2/bottom
    a5=dx2*dy2/(gamma*bottom)
    a6=pi/(ly)
!write(*,*)" ! set the indices for the interior of the grid"
! we block the grid across the processors
! for a 50 x 50 gird with 6 processors we get
! nrow=  2  ncol=  3
! myid=   0 myrow=   1 mycol=   1    (  1 <= i <=  25) ,  (  1 <= j <=  17)
! myid=   1 myrow=   1 mycol=   2    (  1 <= i <=  25) ,  ( 18 <= j <=  33)
! myid=   2 myrow=   1 mycol=   3    (  1 <= i <=  25) ,  ( 34 <= j <=  50)
! myid=   3 myrow=   2 mycol=   1    ( 26 <= i <=  50) ,  (  1 <= j <=  17)
! myid=   4 myrow=   2 mycol=   2    ( 26 <= i <=  50) ,  ( 18 <= j <=  33)
! myid=   5 myrow=   2 mycol=   3    ( 26 <= i <=  50) ,  ( 34 <= j <=  50)
    dj=real(nx,b8)/real(nodes_row,b8)
    j1=nint(1.0_b8+myid_row*dj)
    j2=nint(1.0_b8+(myid_row+1)*dj)-1
    di=real(ny,b8)/real(nodes_col,b8)
    i1=nint(1.0_b8+myid_col*di)
    i2=nint(1.0_b8+(myid_col+1)*di)-1
    if(myid == mpi_master)write(*,'("rows= ",i4," columns= ",i4)')nodes_row,nodes_col
    write(*,'("myid= ",i4," myid_row= ",i4," myid_col= ",i4)')myid,myid_row,myid_col
    write(*,101)myid,myrow,mycol,i1,i2,j1,j2
101 format("myid= ",i4," myrow= ",i4," mycol= ",i4,3x,&
           " (",i3," <= i <= ",i3,") , ",            &
           " (",i3," <= j <= ",i3,")")
! allocate the grid to (i1-1:i2+1,j1-1:j2+1) this includes boundary cells
    allocate(psi(i1-1:i2+1,j1-1:j2+1))
    allocate(new_psi(i1-1:i2+1,j1-1:j2+1))
    allocate(for(i1-1:i2+1,j1-1:j2+1))
! set initial guess for the value of the grid
    psi=1.0_b8
! set boundary conditions
    call bc(psi,i1,i2,j1,j2)
! set the force array
    call do_force(i1,i2,j1,j2)
    call do_transfer(psi,i1,i2,j1,j2)
    iout=steps/100
    if(iout == 0)iout=1
    t1=MPI_Wtime()
! do the jacobian iterations
    do i=1,steps
        call do_jacobi(psi,new_psi,mydiff,i1,i2,j1,j2)
        call do_transfer(psi,i1,i2,j1,j2)
!       write(*,*)myid,i,mydiff
	call MPI_REDUCE(mydiff,diff,1,MPI_DOUBLE_PRECISION, &
	                MPI_SUM,mpi_master,MPI_COMM_WORLD,mpi_err)
	if(myid .eq. mpi_master .and. mod(i,iout) .eq. 0)write(*,'(i6,1x,g20.10)')i,diff
    enddo
    t2=mpi_Wtime()
    if(myid .eq. mpi_master)write(*,*)"run time =",t2-t1,n_mpi,n_thread
! write out the final grid
!    call write_grid(psi,i1,i2,j1,j2)
100 continue
    call MPI_Finalize(mpi_err)
end program stommel
!*********************
subroutine bc(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use input, only : nx,ny
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
! do the top edges
    if(i1 .eq.  1) psi(i1-1,:)=0.0_b8
! do the bottom edges
    if(i2 .eq. ny) psi(i2+1,:)=0.0_b8
! do left edges
    if(j1 .eq.  1) psi(:,j1-1)=0.0_b8
! do right edges
    if(j2 .eq. nx) psi(:,j2+1)=0.0_b8
end subroutine bc
!*********************
subroutine do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
    use numz
    use mpi, only: numnodes,myid
    use constants
    implicit none
    integer,intent(in) :: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
    real(b8) diff
    integer i,j
    integer omp_get_num_threads,omp_get_thread_num
    real(b8) y
    diff=0.0_b8
!$OMP PARALLEL
!$OMP DO SCHEDULE (STATIC) private(i) firstprivate(a1,a2,a3,a4,a5) reduction(+:diff)
    do j=j1,j2
        do i=i1,i2
!            y=j*dy
            new_psi(i,j)=a1*psi(i+1,j) + a2*psi(i-1,j) + &
                         a3*psi(i,j+1) + a4*psi(i,j-1) - &
                         a5*for(i,j)
!                         a5*force(y)
            diff=diff+abs(new_psi(i,j)-psi(i,j))
         enddo
     enddo
!$OMP END  DO
     psi(i1:i2,j1:j2)=new_psi(i1:i2,j1:j2)
!$OMP END PARALLEL
end subroutine do_jacobi
!*********************
function force(y)
    use numz
    use input
    use constants
    implicit none
    real(b8) force,y
    force=-alpha*sin(y*a6)
end function force
!*********************
subroutine do_force (i1,i2,j1,j2)
! sets the force conditions
! input is the grid and the indices for the interior cells
    use numz
    use constants, only:for,dy
    use face, only : force
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8) y
    integer i,j
    do i=i1,i2
        do j=j1,j2
            y=j*dy
            for(i,j)=force(y)
        enddo
    enddo
end subroutine
!*********************
subroutine write_grid(psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use face ,only : unique
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    integer i,j
    integer istart,iend,jstart,jend
! each processor writes its section of the grid
    istart=i1-1
    iend=i2+1
    jstart=j1-1
    jend=j2+1
    open(18,file=unique("out_both"),recl=max(80,15*((jend-jstart)+3)+2))
    write(18,101)myid,istart,iend,jstart,jend

101 format("myid= ",i3,3x,                 &
           " (",i3," <= i <= ",i3,") , ", &
           " (",i3," <= j <= ",i3,")")
    do i=istart,iend
       do j=jstart,jend
           write(18,'(g14.7)',advance="no")psi(i,j)
           if(j .ne. j2)write(18,'(" ")',advance="no")
       enddo
       write(18,*)
    enddo
    close(18)
end subroutine write_grid
!*********************
subroutine do_transfer(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    use mpi
    use input
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    integer num_x,num_y
    logical even
    num_x=i2-i1+3
    num_y=j2-j1+3
    if(even(myid_col))then
! send to left
            call MPI_SEND(psi(:,j1),  num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sl",myid,psi(:,j1)
! rec from left
            call MPI_RECV(psi(:,j1-1),num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rl",myid,psi(:,j1-1)
! rec from right
            call MPI_RECV(psi(:,j2+1),num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rr",myid,psi(:,j2+1)
! send to right
            call MPI_SEND(psi(:,j2),  num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sr",myid,psi(:,j2)
    else    ! we are on an odd col processor
! rec from right
            call MPI_RECV(psi(:,j2+1),num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rr",myid,psi(:,j2+1)
! send to right
            call MPI_SEND(psi(:,j2),  num_x,MPI_DOUBLE_PRECISION,myright, &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sr",myid,psi(:,j2)
! send to left
            call MPI_SEND(psi(:,j1),  num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,mpi_err)
!	    write(*,*)"sl",myid,psi(:,j1)
! rec from left
            call MPI_RECV(psi(:,j1-1),num_x,MPI_DOUBLE_PRECISION,myleft,  &
                                      100,ROW_COMM,status,mpi_err)
!	    write(*,*)"rl",myid,psi(:,j1-1)
    endif
    if(even(myid_row))then
! send to top
        call MPI_SEND(psi(i1,:),num_y,MPI_DOUBLE_PRECISION,mytop,     &
                      10, COL_COMM,mpi_err)
! rec from top
        call MPI_RECV(psi(i1-1,:),num_y,MPI_DOUBLE_PRECISION,mytop,  &
                      10,COL_COMM,status,mpi_err)
! rec from bot
        call MPI_RECV(psi(i2+1,:),num_y,MPI_DOUBLE_PRECISION,mybot,  &
                      10,COL_COMM,status,mpi_err)
! send to bot
        call MPI_SEND(psi(i2,:),num_y,MPI_DOUBLE_PRECISION,mybot,     &
                      10, COL_COMM,mpi_err)
    else
! rec from bot
        call MPI_RECV(psi(i2+1,:),num_y,MPI_DOUBLE_PRECISION,mybot,   &
                      10,COL_COMM,status,mpi_err)
! send to bot
        call MPI_SEND(psi(i2,:),num_y,MPI_DOUBLE_PRECISION,mybot,     &
                      10,COL_COMM,mpi_err)
! send to top
        call MPI_SEND(psi(i1,:),num_y,MPI_DOUBLE_PRECISION,mytop,     &
                      10,COL_COMM,mpi_err)
! rec from top
        call MPI_RECV(psi(i1-1,:),num_y,MPI_DOUBLE_PRECISION,mytop,   &
                      10,COL_COMM,status,mpi_err)
    endif
end subroutine do_transfer
!*********************
function even(i)
  integer i
  logical even
  j=i/2
  if(j*2 .eq. i)then
      even = .true.
  else
      even = .false.
  endif
  return
end function even
!*********************
function unique(name)
    use numz
    use mpi
    character (len=*) name
    character (len=20) unique
    character (len=80) temp
    if(myid .gt. 99)then
      write(temp,"(a,i3)")trim(name),myid
    else
        if(myid .gt. 9)then
            write(temp,"(a,'0',i2)")trim(name),myid
        else
            write(temp,"(a,'00',i1)")trim(name),myid
        endif
    endif
    unique=temp
    return
end function unique

max_stars_repo_name: timkphd/examples

max_issues_repo_name: timkphd/examples

max_forks_repo_name: timkphd/examples


text:
! { dg-do run }
! { dg-options "-fcheck-array-temporaries" }
 program test
  implicit none
  integer :: a(3,3)
  call foo(a(:,1))  ! OK, no temporary created
  call foo(a(1,:))  ! BAD, temporary var created
contains
  subroutine foo(x)
    integer :: x(3)
    x = 5
  end subroutine foo
end program test

! { dg-output "At line 7 of file .*array_temporaries_2.f90(\n|\r\n|\r)Fortran runtime warning: An array temporary was created for argument 'x' of procedure 'foo'" }

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
program saturn_grv
use param
implicit none
CALL GETARG(1,arg1)

select case (arg1)
case('1')
	call test_sph
case('2')
	call test_orbit
case default
	stop
end select

end program saturn_grv

!真实轨道仿真
subroutine test_orbit

end subroutine test_orbit

!土星环的引力场与土星带谐项相关分析
subroutine test_sph
use param
use grav
use lib_array
implicit none

integer :: i,j,nr,np
!real(dp),parameter:: rs=60356000.d0 !环半径(m)
real(dp)::x(3),xbf(3),fs(3),ufs(3),fr(3),ufr(3),r1,r2,p1,p2,dtemp,dtemp1,vdot
real(dp),allocatable:: rho(:),phi(:)
!rho 	:径向
!phi	:纬向
CALL GETARG(2,arg2)
CALL GETARG(3,arg3)
CALL GETARG(4,arg4)
CALL GETARG(5,arg5)
CALL GETARG(6,arg6)
CALL GETARG(7,arg7)
CALL GETARG(8,arg8)

read(arg3,*)nr
read(arg4,*)np
read(arg5,*)r1
read(arg6,*)r2
read(arg7,*)p1
read(arg8,*)p2

r1=r1*rsat
r2=r2*rsat
p1=p1*pi/180.d0
p2=p2*pi/180.d0

allocate(rho(nr),phi(np))
!xbf(1)=-47174.707491d3
!xbf(2)=-145456.356920d3
!xbf(3)=152.790709d3
grv_file=trim(arg2)
grv_file_id=20
grv_body_id=699
grv_order=8
call getgrvp

!call linspace(66900000.d0,136775000.d0,rho)
call linspace(r1,r2,rho)
!call linspace(-pi/2,pi/2,phi)
call linspace(p1,p2,phi)
!rho=rs+rho

do i=1,nr
	do j=1,np
		xbf(1)=0.d0
		xbf(2)=rho(i)*dcos(phi(j))
		xbf(3)=rho(i)*dsin(phi(j))
!		write(*,*)rho(i)
		xbf(1)=0.d0
		xbf(2)=116775000.d0
		xbf(3)=1000.d0
		call gforcebf(xbf,fs)
		call UNORM ( fs, ufs, dtemp )
		call ringbf(xbf,fr)
		write(*,*)fr
		stop
		call UNORM ( fr, ufr, dtemp1 )
		write(*,'(5e)')rho(i)/rsat,phi(j)*180.d0/pi,dtemp,dtemp1,dabs(vdot(ufs,ufr))
	enddo
enddo

end subroutine test_sph

max_stars_repo_name: jnnccc/ring-gravity

max_issues_repo_name: jnnccc/ring-gravity

max_forks_repo_name: jnnccc/ring-gravity


text:
	SUBROUTINE SFCOPT  ( sffile, sfoutf, area, dattim, datout,
     +			     ntimes, sfparm, iret )
C************************************************************************
C* SFCOPT								*
C*									*
C* This subroutine displays a summary of the users options.		*
C*									*
C* SFCOPT  ( SFFILE, SFOUTF, AREA, DATTIM, DATOUT, NTIMES, SFPARM,      *
C*           IRET )							*
C*									*
C* Input parameters:							*
C*	SFFILE		CHAR*		Input file name			*
C*	SFOUTF		CHAR*		Output file name		*
C*	AREA		CHAR*		Area name			*
C*	DATTIM (*)	CHAR*		Input date/times   		*
C*	DATOUT (*)	CHAR*		Output date/times		*
C*	NTIMES		INTEGER		Number of times                 *
C*	SFPARM		CHAR*		Output parameters		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = exit			*
C* Log:									*
C* M. desJardins/GSFC	 6/88						*
C* S. Schotz/GSC	 5/90	Get respnd locally from IP_RESP		*
C* A. Hardy/GSC		 1/99   Added output date and time              *
C* D. Kidwell/NCEP	 3/99   Added requested output parameters;      *
C*				changed time display                    *
C************************************************************************
	CHARACTER*(*)	sffile, sfoutf, area, dattim (*), datout (*),
     +		        sfparm
	LOGICAL		respnd
C------------------------------------------------------------------------
	iret = 0
C*
	WRITE  ( 6, 1000 ) sffile, sfoutf, area, sfparm,
     +			   ( dattim (i), datout (i), i = 1, ntimes )
1000	FORMAT ( / ' SFMOD PARAMETERS: ', // ,
     +             ' Input file:        ', A, /
     +             ' Output file:       ', A, /
     +             ' Area:              ', A, /
     +             ' Output parameters: ', A, /
     +             ' Input date/time:        Output date/time:  ', /
     +             ( 1X, A, 4X, A ) )
C
C*	Wait for user input.
C
	CALL IP_RESP ( respnd, ier )
	IF  ( respnd )  THEN
	    CALL TM_ACCP  ( ier )
	    IF  ( ier .eq. 2 )  iret = -1
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
+incdir+../testbench
+incdir+../simulation
+incdir+../rtl
+incdir+../cores/orpsoc-cores/cores/wb_bfm/wb_bfm-0/
+incdir+../cores/orpsoc-cores/cores/verilog_utils/
+incdir+../cores/orpsoc-cores/cores/wb_common/
+define+VERBOSE
+define+SIM

../rtl/syscon.v
../rtl/adc_clk_gen.v
../rtl/wb_dsp_algorithm_sm.v
../rtl/wb_dsp_equations_top.v
../rtl/equation_sum.v
../rtl/wb_dsp_slave_registers.v
../rtl/wb_dsp_top.v
../rtl/wb_daq_bus_master.v
../rtl/wb_daq_slave_registers.v
../rtl/wb_daq_top.v
../rtl/wb_master_interface.v
../rtl/wb_daq_data_aggregation.v
../rtl/wb_daq_channel.v
../rtl/fifo.v
../rtl/fifo_to_sram.v
../behavioral/adc/adc.v
../testbench/testbench.v
../testbench/test_tasks.v
../testbench/arbiter.v
../testbench/wb_dsp_testbench_intercon.v
../testbench/wb_dump.v
../cores/orpsoc-cores/cores/wb_intercon/wb_mux.v
../cores/orpsoc-cores/cores/wb_intercon/wb_arbiter.v
../cores/orpsoc-cores/cores/wb_intercon/wb_data_resize.v
../cores/orpsoc-cores/cores/wb_bfm/wb_bfm-0/wb_bfm_master.v
../cores/orpsoc-cores/cores/wb_ram/rtl/verilog/wb_ram.v
../cores/orpsoc-cores/cores/wb_ram/rtl/verilog/wb_ram_generic.v