text:
SUBROUTINE fc2d_geoclaw_fort_tag4refinement(mx,my,mbc,meqn,maux,xlower,ylower, &
    dx,dy,t,blockno,q,aux,level,maxlevel,init_flag,tag_patch)

    IMPLICIT NONE

    INTEGER :: mx,my, mbc, meqn, maux, tag_patch, init_flag
    INTEGER :: blockno, level, maxlevel
    DOUBLE PRECISION :: xlower, ylower, dx, dy, t
    DOUBLE PRECISION, intent(in) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    DOUBLE PRECISION, INTENT(in) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    !! Local variables
    INTEGER :: i,j, mq,m
    DOUBLE PRECISION :: xc,yc,xupper, yupper, qvec(meqn), auxvec(maux)
    logical :: is_coarsening

!!    INTEGER :: tag_patch_regions, fc2d_geoclaw_refine_using_regions
    INTEGER :: fc2d_geoclaw_flag2refine, flag_patch

!!    xupper = xlower + mx*dx
!!    yupper = ylower + my*dy
!!
!!    tag_patch_regions = fc2d_geoclaw_refine_using_regions(level,xlower,ylower,xupper,yupper,t)
!!
!!    if (tag_patch_regions .ge. 0) then
!!        !! # Tagging based on regions is conclusive
!!        tag_patch = tag_patch_regions
!!        return
!!    endif

    !! We are not refining based on regions and so will use other criteria
    tag_patch = 0

    is_coarsening = .false.   !! Don't loop over ghost cells.
    DO j = 1,my
        DO i = 1,mx
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            do m = 1,meqn
                qvec(m) = q(m,i,j)
            end do
            do m = 1,maux
                auxvec(m) = aux(m,i,j)
            enddo
            flag_patch = fc2d_geoclaw_flag2refine( &
                    blockno, meqn,maux, qvec, auxvec, dx,dy,xc,yc,t,level, &
                    maxlevel, init_flag, is_coarsening)

!!          # -1 : Not conclusive (possibly ghost cell); don't tag for refinement
!!          # 0  : Does not pass threshold (don't tag for refinement)
!!          # 1  : Passes threshold (tag for refinement)
            if (flag_patch .gt. 0) then
                tag_patch = 1
                return
            endif
        end do
    enddo

END SUBROUTINE fc2d_geoclaw_fort_tag4refinement

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
      SUBROUTINE fileout_par(iseq, ictrl_flag, ier_flag, lscreen)
      USE vmec_main, ONLY: ns, ntheta1, ntheta2, nzeta, bdamp,
     &                     lfreeb
      USE parallel_include_module
      USE xstuff, ONLY: pxc, pgc, pxsave, pscalxc
      USE xstuff, ONLY: xc, gc, xsave, scalxc
      USE vmec_main, ONLY: vp, iotas, phips, chips, mass, icurv
      USE vmec_main, ONLY: ireflect, nznt, phipf, specw, sp, sm
      USE vmec_params, ONLY: uminus, output_flag, cleanup_flag,
     &                       more_iter_flag
      USE realspace, ONLY: phip, sqrts, shalf, wint
      USE realspace, ONLY: pphip, psqrts, pshalf, pwint
      USE vacmod, ONLY: bsqvac, brv, bphiv, bzv, nv, nuv3,
     &                  bsupu_sur, bsupv_sur, bsubu_sur, bsubv_sur
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: iseq, ictrl_flag
      INTEGER, INTENT(inout) :: ier_flag
      LOGICAL :: lscreen
      LOGICAL :: loutput !SAL 070719
      INTEGER :: i, j, ij, k, js, jk, lk, lt, lz, jcount
      REAL(dp) :: tfileon, tfileoff
      REAL(dp), ALLOCATABLE :: buffer(:,:), tmp(:,:)
C-----------------------------------------------
      CALL second0(tfileon)

      loutput = (IAND(ictrl_flag, output_flag) .ne. 0) !SAL 070719

      IF (lfreeb .AND. vlactive .AND. loutput) THEN !SAL070719
         ALLOCATE(buffer(numjs_vac, 7), tmp(nznt, 7),stat=i)
         IF (i .NE. 0) CALL STOPMPI(440)
         buffer(:,1) = brv(nuv3min:nuv3max)
         buffer(:,2) = bphiv(nuv3min:nuv3max)
         buffer(:,3) = bzv(nuv3min:nuv3max)
         buffer(:,4) = bsupu_sur(nuv3min:nuv3max)
         buffer(:,5) = bsupv_sur(nuv3min:nuv3max)
         buffer(:,6) = bsubu_sur(nuv3min:nuv3max)
         buffer(:,7) = bsubv_sur(nuv3min:nuv3max)

         DO i = 1, 7
            CALL MPI_Allgatherv(buffer(:,i), numjs_vac, MPI_REAL8,
     &                          tmp(:,i), counts_vac, disps_vac,
     &                          MPI_REAL8, VAC_COMM,MPI_ERR)
         END DO
         DEALLOCATE(buffer)

         brv = tmp(:,1);
         bphiv = tmp(:,2);
         bzv = tmp(:,3)
         bsupu_sur = tmp(:,4);
         bsupv_sur = tmp(:,5)
         bsubu_sur = tmp(:,6);
         bsubv_sur = tmp(:,7)
         DEALLOCATE(tmp)
      END IF
!
!     COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym)
!
      jcount = 0
      DO k = 1, nzeta
         jk = nzeta + 2 - k
         IF (k .eq. 1) jk = 1
         DO js = 1,ns
            jcount = jcount + 1
            ireflect(jcount) = js+ns*(jk - 1)           !Index for -zeta[k]
         ENDDO
      END DO

!     INDEX FOR u = -u (need for lasym integration in wrout)
      lk = 0
      IF (.NOT.ALLOCATED(uminus)) ALLOCATE (uminus(nznt))
      DO lt = 1, ntheta2
         k = ntheta1-lt+2
         IF (lt .eq. 1) k = 1             !u=-0 => u=0
         DO lz = 1, nzeta
            lk = lk + 1
            uminus(lk) = k                !(-u), for u = 0,pi
         END DO
      END DO

      IF (grank.LT.nranks .AND.
     &    IAND(ictrl_flag, output_flag).NE.0) THEN
         CALL Gather1XArray(vp)
         CALL Gather1XArray(iotas)
         CALL Gather1XArray(phips)
         CALL Gather1XArray(phipf)
         CALL Gather1XArray(chips)
         CALL Gather1XArray(mass)
         CALL Gather1XArray(icurv)
         CALL Gather1XArray(specw)
         CALL Gather1XArray(bdamp)
         CALL Gather1XArray(sm)
         CALL Gather1XArray(sp)

         CALL Gather2XArray(pphip)
         CALL Parallel2Serial2X(pphip, phip)
         CALL Gather2XArray(psqrts)
         CALL Parallel2Serial2X(psqrts, sqrts)
         CALL Gather2XArray(pshalf)
         CALL Parallel2Serial2X(pshalf, shalf)
         CALL Gather2XArray(pwint)
         CALL Parallel2Serial2X(pwint, wint)

         CALL Gather4XArray(pxc)
         CALL Parallel2Serial4X(pxc,xc)
         CALL Gather4XArray(pscalxc)
         CALL Parallel2Serial4X(pscalxc,scalxc)
         CALL second0(tfileoff)
      END IF
      fo_prepare_time = fo_prepare_time + (tfileoff-tfileon)

!      ORIGPARVMEC=PARVMEC
!      PARVMEC=.FALSE.
      IF (grank .EQ. 0) THEN
         CALL fileout(iseq, ictrl_flag, ier_flag, lscreen)
      ENDIF
      ! SAL 06/11/2020 Moved here because of shared memory
      IF (IAND(ictrl_flag, cleanup_flag) .eq. 0 .or.
     &    ier_flag                       .eq. more_iter_flag) THEN
      ELSE
          CALL free_persistent_mem
      END IF
      !CALL MPI_Barrier(NS_COMM, MPI_ERR) !SAL 070719
      CALL second0(tfileoff)
      fileout_time = fileout_time + (tfileoff-tfileon)
      fo_par_call_time = fileout_time

      END SUBROUTINE fileout_par

      SUBROUTINE fileout(iseq, ictrl_flag, ier_flag, lscreen)
      USE vmec_main
      USE vac_persistent
      USE realspace
      USE vmec_params, ONLY: mscale, nscale, signgs, uminus,
     &      norm_term_flag, more_iter_flag, output_flag,
     &      cleanup_flag, successful_term_flag
      USE vforces
      USE xstuff, ONLY: xc, gc, xsave, scalxc
      USE precon2d, ONLY: ictrl_prec2d
      USE timer_sub
#ifdef _HBANGLE
      USE angle_constraints, ONLY: free_multipliers, getrz
#endif
      USE parallel_include_module

      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: iseq, ictrl_flag
      INTEGER, INTENT(inout) :: ier_flag
      LOGICAL :: lscreen
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER :: istat, loc_ier_flag
      LOGICAL, PARAMETER :: lreset_xc = .false.
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: js, istat1=0, irst0, OFU
      REAL(dp), DIMENSION(:), POINTER :: lu, lv
      REAL(dp), ALLOCATABLE :: br_out(:), bz_out(:)
      CHARACTER(LEN=*), PARAMETER, DIMENSION(0:14) :: werror = (/
     &   'EXECUTION TERMINATED NORMALLY                            ', ! norm_term_flag
     &   'INITIAL JACOBIAN CHANGED SIGN (IMPROVE INITIAL GUESS)    ', ! bad_jacobian_flag
     &   'FORCE RESIDUALS EXCEED FTOL: MORE ITERATIONS REQUIRED    ', ! more_iter_flag
     &   'VMEC INDATA ERROR: NCURR.ne.1 but BLOAT.ne.1.            ', !
     &   'MORE THAN 75 JACOBIAN ITERATIONS (DECREASE DELT)         ', ! jac75_flag
     &   'ERROR READING INPUT FILE OR NAMELIST                     ', ! input_error_flag
     &   'NEW AXIS GUESS STILL FAILED TO GIVE GOOD JACOBIAN        ', !
     &   'PHIEDGE HAS WRONG SIGN IN VACUUM SUBROUTINE              ', ! phiedge_error_flag
     &   'NS ARRAY MUST NOT BE ALL ZEROES                          ', ! ns_error_flag
     &   'ERROR READING MGRID FILE                                 ', ! misc_error_flag
     &   'VAC-VMEC I_TOR MISMATCH : BOUNDARY MAY ENCLOSE EXT. COIL ', !
     &   'SUCCESSFUL VMEC CONVERGENCE                              ', ! successful_term_flag
     &   'BSUBU OR BSUBV JS=1 COMPONENT NON-ZERO                   ', ! bsub_bad_js1_flag
     &   'RMNC N=0, M=1 IS ZERO                                    ', ! r01_bad_value_flag
     &   'ARNORM OR AZNORM EQUAL ZERO IN BCOVAR                    '  ! arz_bad_value_flag
     &   /)
      CHARACTER(LEN=*), PARAMETER ::
     &    Warning = " Error deallocating global memory FILEOUT"
      LOGICAL :: lwrite, loutput, lterm
      REAL(dp) :: tmpxc, rmssum
C-----------------------------------------------

      INFILEOUT=.TRUE.

      lu => czmn;   lv => crmn

!
!     COMPUTE REMAINING COVARIANT COMPONENT OF B (BSUBS),
!     CYLINDRICAL COMPONENTS OF B (BR, BPHI, BZ), AND
!     AVERAGE EQUILIBRIUM PROPERTIES AT END OF RUN
!

      iequi = 1
      lterm = ier_flag .eq. norm_term_flag  .or.
     &        ier_flag .eq. successful_term_flag
      lwrite = lterm .or. ier_flag.eq.more_iter_flag
      loutput = (IAND(ictrl_flag, output_flag) .ne. 0)
      loc_ier_flag = ier_flag
      if (ier_flag .eq. successful_term_flag) THEN
          loc_ier_flag = norm_term_flag
      end if

      IF (lwrite .AND. loutput) THEN
!
!     The sign of the jacobian MUST multiply phi to get the physically
!     correct toroidal flux
!
         phi(1) = zero
         DO js = 2, ns
            phi(js) = phi(js-1) + phip(js)
         END DO
         phi = (signgs*twopi*hs)*phi

!        Must save irst value if in "restart" mode
         irst0 = irst
         CALL funct3d (lscreen, istat)
         fo_funct3d_time = timer(tfun)

!        Write out any special files here
!        CALL dump_special

         irst = irst0

         ALLOCATE(br_out(nrzt), bz_out(nrzt), stat=istat)
         gc = xc
#ifdef _HBANGLE
         CALL getrz(gc)
#endif
         CALL eqfor(br_out, bz_out, clmn, blmn, rcon(1,1),
     &              gc, ier_flag)
      END IF

!      CALL free_mem_precon
!
!     Call WROUT to write output or error message if lwrite = false
!

      IF (loutput .AND. ASSOCIATED(bzmn_o)) THEN
         CALL wrout(bzmn_o, azmn_o, clmn, blmn, crmn_o, czmn_e,
     &              crmn_e, xsave, gc, loc_ier_flag, lwrite
#ifdef _ANIMEC
     &              ,brmn_o, sigma_an, ppar, pperp, onembc, pp1, pp2,
     &              pp3
#endif
     &             )

         IF (ntor .EQ. 0) THEN
            CALL write_dcon (xc)
         END IF

         IF (lscreen .and. ier_flag.ne.more_iter_flag)
     &   PRINT 120, TRIM(werror(loc_ier_flag))
         IF (lscreen .and. lterm) THEN
            IF (grank.EQ.0) THEN
               PRINT 10, TRIM(input_extension), ijacob
            END IF
         END IF

         IF (nthreed .gt. 0) THEN
            WRITE (nthreed,120) TRIM(werror(loc_ier_flag))
            IF (.not. lterm) GOTO 1000
            WRITE (nthreed, 10) TRIM(input_extension), ijacob
            IF (rank.EQ.0) THEN
               CALL write_times(nthreed, lscreen, lfreeb, lrecon,
     &                          ictrl_prec2d .ne. 0)

            IF (grank.EQ.0) THEN
               WRITE(nthreed,*)
               WRITE(nthreed,'(1x,a,i4)') 'NO. OF PROCS:  ',gnranks
               WRITE(nthreed,101)         'PARVMEC     :  ',PARVMEC
               WRITE(nthreed,101)         'LPRECOND    :  ',LPRECOND
               WRITE(nthreed,101)         'LV3FITCALL  :  ',LV3FITCALL
            END IF
 101  FORMAT(1x,a,l4)
            END IF
         END IF
      END IF

   10 FORMAT(' FILE : ',a,/,' NUMBER OF JACOBIAN RESETS = ',i4,/)
  120 FORMAT(/1x,a,/)

!
!     TESTING READ_WOUT MODULE WRITING ROUTINES
!
      IF (ALLOCATED(br_out)) THEN
!        IF (lscreen) CALL TestWout(xc, br_out, bz_out, crmn_e, czmn_e)
         DEALLOCATE (br_out, bz_out)
      END IF

!     END TEST

 1000 CONTINUE

!
!     DEALLOCATE GLOBAL MEMORY AND CLOSE FILES
!
      IF (IAND(ictrl_flag, cleanup_flag) .eq. 0 .or.
     &    ier_flag                       .eq. more_iter_flag) THEN
         RETURN
      END IF

      IF (ALLOCATED(cosmu))
     &  DEALLOCATE(cosmu, sinmu, cosmum, sinmum, cosmui, cosmumi,
     &             sinmui, sinmumi, cosnv, sinnv, cosnvn, sinnvn,
     &             cosmui3, cosmumi3, cos01, sin01, stat=istat1)
      IF (istat1 .ne. 0) PRINT *, Warning // "#1"
#ifdef _HBANGLE
        CALL free_multipliers
#endif

      IF (ALLOCATED(xm)) DEALLOCATE (xm, xn, ixm, xm_nyq, xn_nyq,
     &   jmin3, mscale, nscale, uminus, stat=istat1)
      IF (istat1 .ne. 0) PRINT *, Warning // "#2"

      IF (ALLOCATED(tanu))
     &   DEALLOCATE(tanu, tanv, sinper, cosper, sinuv, cosuv, sinu,
     &              cosu, sinv, cosv, sinui, cosui, cmns, csign, sinu1,
     &              cosu1, sinv1, cosv1, imirr, xmpot, xnpot,
     &              stat=istat1)
      IF (istat1 .ne. 0) PRINT *, Warning // "#3"

      CALL free_mem_funct3d
      CALL free_mem_ns (lreset_xc)
      CALL free_mem_nunv
!      CALL free_persistent_mem

      CALL close_all_files

      END SUBROUTINE fileout
!------------------------------------------------

ext: f

max_stars_repo_name: joseluisvelasco/STELLOPT

max_issues_repo_name: joseluisvelasco/STELLOPT


text:
Aly Bonde (Alysoun Bonde) is a junior Political Science and History (major) History double major from http://en.wikipedia.org/wiki/Pleasant_Hill,_California Pleasant Hill, CA. She is the 0809 Campus Editor for The California Aggie and served as a City of Davis City Staff Writer in 0708. If you know where the spelling of her first name came from without looking it up, she will give you a piece of candy.

20080618 05:02:00 nbsp Welcome to the Wiki Howdy, Aly, and Welcome to the Wiki!   What kind of candy? Users/JabberWokky Evan JabberWokky Edwards

20080618 14:05:42 nbsp Welcome and have some links!  :D Users/RichLindvall

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


module ncdr_dims
    use kinds, only: i_long
    use ncdr_state, only: ncdr_files, current_ncdr_id
    use ncdr_climsg, only: ncdr_error
    use ncdr_check, only: ncdr_nc_check, ncdr_check_ncdr_id, &
        ncdr_check_current_ncdr_id
    use netcdf, only: nf90_inquire_dimension, NF90_MAX_NAME
    use netcdf_unlimdims, only: pf_nf90_inq_unlimdims

    implicit none

    interface nc_diag_read_lookup_dim
        module procedure nc_diag_read_id_lookup_dim, &
            nc_diag_read_noid_lookup_dim
    end interface nc_diag_read_lookup_dim

    interface nc_diag_read_assert_dim
        module procedure nc_diag_read_id_assert_dim, &
            nc_diag_read_noid_assert_dim
    end interface nc_diag_read_assert_dim

    interface nc_diag_read_check_dim
        module procedure nc_diag_read_id_check_dim, &
            nc_diag_read_noid_check_dim
    end interface nc_diag_read_check_dim

    interface nc_diag_read_get_dim
        module procedure nc_diag_read_id_get_dim, &
            nc_diag_read_noid_get_dim
    end interface nc_diag_read_get_dim

    interface nc_diag_read_check_dim_unlim
        module procedure nc_diag_read_id_check_dim_unlim, &
            nc_diag_read_noid_check_dim_unlim
    end interface nc_diag_read_check_dim_unlim

    interface nc_diag_read_get_dim_names
        module procedure nc_diag_read_id_get_dim_names, &
            nc_diag_read_noid_get_dim_names
    end interface nc_diag_read_get_dim_names

    contains
        subroutine nc_diag_read_parse_file_dims(file_ncid, file_index, num_dims)
            integer(i_long), intent(in)                :: file_ncid
            integer(i_long), intent(in)                :: file_index
            integer(i_long), intent(in)                :: num_dims

            integer(i_long), dimension(:), allocatable :: unlim_dims
            integer(i_long)                            :: num_unlims
            integer(i_long)                            :: i, j

            character(len=NF90_MAX_NAME)               :: dim_name

            ncdr_files(file_index)%ndims = num_dims
            allocate(ncdr_files(file_index)%dims(num_dims))

            ! Get unlimited dimension information
            call ncdr_nc_check(pf_nf90_inq_unlimdims(file_ncid, num_unlims))

            allocate(unlim_dims(num_unlims))

            call ncdr_nc_check(pf_nf90_inq_unlimdims(file_ncid, num_unlims, unlim_dims))

            do i = 1, num_dims
                ncdr_files(file_index)%dims(i)%dim_id = i

                call ncdr_nc_check(nf90_inquire_dimension(file_ncid, i, &
                        dim_name, &
                        ncdr_files(file_index)%dims(i)%dim_size))

                ncdr_files(file_index)%dims(i)%dim_name = trim(dim_name)
                ncdr_files(file_index)%dims(i)%dim_unlim = .FALSE.

                do j = 1, num_unlims
                    if (i == unlim_dims(j)) then
                        ncdr_files(file_index)%dims(i)%dim_unlim = .TRUE.
                        exit
                    end if
                end do
            end do
        end subroutine nc_diag_read_parse_file_dims

        function nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name) result(dim_index)
            integer(i_long), intent(in)    :: file_ncdr_id
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index

            call ncdr_check_ncdr_id(file_ncdr_id)

            do dim_index = 1, ncdr_files(file_ncdr_id)%ndims
                if (ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name == dim_name) &
                    return
            end do

            ! Otherwise, return -1!
            dim_index = -1
        end function nc_diag_read_id_lookup_dim

        function nc_diag_read_noid_lookup_dim(dim_name) result(dim_index)
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index

            call ncdr_check_current_ncdr_id

            dim_index = nc_diag_read_id_lookup_dim(current_ncdr_id, dim_name)
        end function nc_diag_read_noid_lookup_dim

        function nc_diag_read_id_assert_dim(file_ncdr_id, dim_name) result(dim_index)
            integer(i_long), intent(in)    :: file_ncdr_id
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index

            call ncdr_check_ncdr_id(file_ncdr_id)

            ! Otherwise, return -1!
            dim_index = nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name)

            ! ...except don't, since we're asserting!
            if (dim_index == -1) &
                call ncdr_error("The specified dimension '" // dim_name // "' does not exist!")
        end function nc_diag_read_id_assert_dim

        function nc_diag_read_noid_assert_dim(dim_name) result(dim_index)
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index

            call ncdr_check_current_ncdr_id

            dim_index = nc_diag_read_id_assert_dim(current_ncdr_id, dim_name)
        end function nc_diag_read_noid_assert_dim

        function nc_diag_read_id_check_dim(file_ncdr_id, dim_name) result(dim_exists)
            integer(i_long), intent(in)    :: file_ncdr_id
            character(len=*), intent(in)   :: dim_name

            logical                        :: dim_exists

            call ncdr_check_ncdr_id(file_ncdr_id)

            if (nc_diag_read_id_lookup_dim(file_ncdr_id, dim_name) == -1) then
                dim_exists = .FALSE.
                return
            end if

            dim_exists = .TRUE.
        end function nc_diag_read_id_check_dim

        function nc_diag_read_noid_check_dim(dim_name) result(dim_exists)
            character(len=*), intent(in)   :: dim_name

            logical                        :: dim_exists

            call ncdr_check_current_ncdr_id

            if (nc_diag_read_lookup_dim(dim_name) == -1) then
                dim_exists = .FALSE.
                return
            end if

            dim_exists = .TRUE.
        end function nc_diag_read_noid_check_dim

        function nc_diag_read_id_get_dim(file_ncdr_id, dim_name) result(dim_size)
            integer(i_long), intent(in)    :: file_ncdr_id
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index, dim_size

            call ncdr_check_ncdr_id(file_ncdr_id)

            dim_index = nc_diag_read_id_assert_dim(file_ncdr_id, dim_name)

            dim_size = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_size
        end function nc_diag_read_id_get_dim

        function nc_diag_read_noid_get_dim(dim_name) result(dim_size)
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_size

            call ncdr_check_current_ncdr_id

            dim_size = nc_diag_read_id_get_dim(current_ncdr_id, dim_name)
        end function nc_diag_read_noid_get_dim

        function nc_diag_read_id_check_dim_unlim(file_ncdr_id, dim_name) result(dim_isunlim)
            integer(i_long), intent(in)    :: file_ncdr_id
            character(len=*), intent(in)   :: dim_name

            integer(i_long)                :: dim_index
            logical                        :: dim_isunlim

            call ncdr_check_ncdr_id(file_ncdr_id)

            dim_index = nc_diag_read_id_assert_dim(file_ncdr_id, dim_name)

            dim_isunlim = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_unlim
        end function nc_diag_read_id_check_dim_unlim

        function nc_diag_read_noid_check_dim_unlim(dim_name) result(dim_isunlim)
            character(len=*), intent(in)   :: dim_name

            logical                        :: dim_isunlim

            call ncdr_check_current_ncdr_id

            dim_isunlim = nc_diag_read_id_check_dim_unlim(current_ncdr_id, dim_name)
        end function nc_diag_read_noid_check_dim_unlim

        subroutine nc_diag_read_id_get_dim_names(file_ncdr_id, num_dims, dim_name_mlen, dim_names)
            integer(i_long), intent(in)              :: file_ncdr_id
            integer(i_long), intent(out), optional   :: num_dims
            integer(i_long), intent(out), optional   :: dim_name_mlen
            character(len=:), intent(inout), dimension(:), allocatable, optional:: dim_names

            integer(i_long)                :: dim_index, ndims, max_dim_name_len

            max_dim_name_len = 0

            call ncdr_check_ncdr_id(file_ncdr_id)

            ndims = ncdr_files(file_ncdr_id)%ndims

            if (present(num_dims)) &
                num_dims = ndims

            ! Figure out character max length
            do dim_index = 1, ndims
                if (len(ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name) > max_dim_name_len) &
                    max_dim_name_len = len(ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name)
            end do

            if (present(dim_name_mlen)) &
                dim_name_mlen = max_dim_name_len

            if (present(dim_names)) then
                if (.NOT. allocated(dim_names)) then
                    allocate(character(max_dim_name_len) :: dim_names(ndims))
                else
                    if (size(dim_names) /= ndims) &
                        call ncdr_error("Invalid allocated array size for dimension names storage!")
                    if (len(dim_names) < max_dim_name_len) &
                        call ncdr_error("Invalid allocated array size for dimension names storage! (String length does not match!)")
                end if

                do dim_index = 1, ndims
                    dim_names(dim_index) = ncdr_files(file_ncdr_id)%dims(dim_index)%dim_name
                end do
            end if
        end subroutine nc_diag_read_id_get_dim_names

        subroutine nc_diag_read_noid_get_dim_names(dummy,num_dims, dim_name_mlen, dim_names)
            character(len=*),intent(in)              :: dummy ! MAT A dummy argument is needed so that Fortran
                                                              !     can distinguish between the _id_ and _noid_
                                                              !     versions of this code
            integer(i_long), intent(out), optional   :: num_dims
            integer(i_long), intent(out), optional   :: dim_name_mlen
            character(len=:), intent(inout), dimension(:), allocatable, optional:: dim_names

            call ncdr_check_current_ncdr_id

            if (present(num_dims)) then
                if (present(dim_name_mlen)) then
                    if (present(dim_names)) then
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_name_mlen, dim_names)
                    else
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_name_mlen)
                    end if
                else
                    if (present(dim_names)) then
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims, dim_names = dim_names)
                    else
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, num_dims)
                    end if
                end if
            else
                if (present(dim_name_mlen)) then
                    if (present(dim_names)) then
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_name_mlen = dim_name_mlen, &
                            dim_names = dim_names)
                    else
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_name_mlen = dim_name_mlen)
                    end if
                else
                    if (present(dim_names)) then
                        call nc_diag_read_id_get_dim_names(current_ncdr_id, dim_names = dim_names)
                    else
                        ! Why would you do this?
                        call nc_diag_read_id_get_dim_names(current_ncdr_id)
                    end if
                end if
            end if
        end subroutine nc_diag_read_noid_get_dim_names
end module ncdr_dims


text:
	SUBROUTINE GR_WTRM  ( lun, title, ignum, gdattm, level, ivcord,
     +			      parm, iret )
C************************************************************************
C* GR_WTRM								*
C*									*
C* This subroutine writes a grid identifier to the specified logical	*
C* unit using a standard format.  TITLE is set to indicate that the 	*
C* title line:								*
C*									*
C*    NUM    TIME1     TIME2     LEVEL1    LEVEL2   VCORD     PARM	*
C*									*
C* is to be written first.  If IGNUM is not positive, the grid 		*
C* number will not be written and will not be included in the title.	*
C*									*
C* GR_WTRM  ( LUN, TITLE, IGNUM, GDATTM, LEVEL, IVCORD, PARM, IRET )	*
C*									*
C* Input parameters:							*
C*	LUN		INTEGER		Logical unit for write		*
C*	TITLE		LOGICAL		Flag to write title		*
C*	IGNUM		INTEGER		Grid number			*
C*	GDATTM (2)	CHAR*20		GEMPAK time			*
C*	LEVEL  (2)	INTEGER		Vertical levels			*
C*	IVCORD		INTEGER		Vertical coordinate		*
C*	PARM		CHAR*12		Parameter name			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/87						*
C* M. desJardins/GSFC	 6/88	GEMPAK4					*
C* M. desJardins/GSFC	 4/89	Added call to LV_CCRD			*
C* K. Brill/NMC		01/92	Add different WRITE format for VAX	*
C* M. desJardins/NMC	 3/92	Make line 79 characters to stop wrap	*
C* M. Linda/GSC		 9/97	Corrected right border of prologue	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	CHARACTER*(*)	gdattm (*), parm
	INTEGER		level  (*)
	LOGICAL		title
C*
	CHARACTER	vcord*4, dt1*18, dt2*16, p*12, lev*5
C-----------------------------------------------------------------------
	iret = 0
C
C*	Translate vertical coordinate.
C
	CALL LV_CCRD  ( ivcord, vcord, ier )
C
C*	Move character strings into variables with correct length.
C
	dt1 = gdattm (1)
	dt2 = gdattm (2)
	p      = parm
C
C*	Make level 2 into a string.  Write nothing if level2 = -1.
C
	IF  ( level (2) .eq. -1 )  THEN
	    lev = ' '
	  ELSE
	    CALL ST_INCH ( level (2), lev, ier )
	END IF
C
C*	Write title if requested, checking whether grid number is to
C*	be written.
C
	IF  ( ( title ) .and. ( ignum .gt. 0 ) )  THEN
	  IF  ( MTMACH .eq. MTVAX )  THEN
	    WRITE  ( lun, 1000 )
1000	    FORMAT ( 1X, '  NUM', 7X, 'TIME1', 14X, 'TIME2', 11X,
     +                   'LEVL1 LEVL2', 2X, 'VCORD', 1X, 'PARM' )
	  ELSE
	    WRITE  ( lun, 1111 )
1111	    FORMAT ( '  NUM', 7X, 'TIME1', 14X, 'TIME2', 11X,
     +                   'LEVL1 LEVL2', 2X, 'VCORD', 1X, 'PARM' )
	  END IF
	ELSE IF  ( title )  THEN
	  IF  ( MTMACH .eq. MTVAX )  THEN
	    WRITE  ( lun, 1001 )
1001	    FORMAT ( 5X, 'TIME1', 13X, 'TIME2', 9X,
     +                   'LEVL1 LEVL2', 3X, 'VCORD', 1X, 'PARM'  )
	  ELSE
	    WRITE  ( lun, 1002 )
1002	    FORMAT ( 4X, 'TIME1', 13X, 'TIME2', 9X,
     +                   'LEVL1 LEVL2', 3X, 'VCORD', 1X, 'PARM'  )
	  END IF
	END IF
C
C*	Write the grid identifier.
C
	IF  ( ignum .gt. 0 )  THEN
	  IF  ( MTMACH .eq. MTVAX )  THEN
	    WRITE  ( lun, 2000 ) ignum, dt1, dt2, level (1), lev,
     +				 vcord, parm
2000	    FORMAT ( 1X, I5, 5X, A, A, 2x, I6, 2X, A, 2X, A, 1X, A )
	   ELSE
	    WRITE  ( lun, 2111 ) ignum, dt1, dt2, level (1), lev,
     +				 vcord, parm
2111	    FORMAT ( I5, 5X, A, A, 2x, I6, 2X, A, 2X, A, 1X, A )
	  END IF
	 ELSE
	  IF  ( MTMACH .eq. MTVAX )  THEN
	    WRITE  ( lun, 2001 ) dt1, dt2, level (1), lev, vcord,
     +				 parm
2001	    FORMAT ( 1X, A, 1X, A, I6, 2X, A, 3X, A, 1X, A )
	   ELSE
	    WRITE  ( lun, 2002 ) dt1, dt2, level (1), lev, vcord,
     +				 parm
2002	    FORMAT ( A, 1X, A, I6, 2X, A, 3X, A, 1X, A )
	  END IF
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
subroutine driver(km,jm,im,              &
     beta, sigma, g, dt, Cpd, tau_inf, alpha,         &
     T, q, p, ps, solin, Ts,             &
     Tinc, Tdot, SrfRadFlx, swhr, swflx_out, lwhr, lwflx_out, up_out, down_out, tau_out)
!-----------------------------!
!  CliMT driver for grey gas  !
!  radiation scheme           !
!  J.L. Mitchell 10Mar05      !
!_____________________________!

!! Note: tau_inf here is the BROADBAND optical depth

! In
integer im,jm,km
!f2py intent(in,hide) im,jm,km
real(8),                     intent(in) :: sigma, g, dt, Cpd, tau_inf, alpha, beta
real(8),dimension(km,jm,im), intent(in) :: T, q, p
real(8),dimension(jm,im),    intent(in) :: Ts, ps, solin

! Out
real(8),dimension(km,jm,im), intent(out) :: Tinc,Tdot, lwflx_out, lwhr, up_out, down_out, tau_out
real(8),dimension(km,jm,im), intent(out) :: swflx_out, swhr
real(8),dimension(jm,im)   , intent(out) :: SrfRadFlx

! Local
real(8),dimension(0:km,jm,im) :: plev, tau, lwflx, up, down

! Input pressures are at midlevel, need p on level surfaces
plev(1:km-1,:,:) = ( p(1:km-1,:,:) + p(2:km,:,:) )/2.
plev(0     ,:,:) = 0.
plev(km    ,:,:) = ps

! Set profile of optical depth
do k=0,km
   tau(k,:,:) = tau_inf/beta*(1.- ( plev(k,:,:)/ps )**alpha )
enddo

! Loop over lat and lon
do i=1,im
   do j=1,jm
      call grey_gas(km,beta,sigma,T(:,j,i), tau(:,j,i), Ts(j,i),  &
                    lwflx(:,j,i), up(:,j,i), down(:,j,i))
   enddo
enddo

Tdot = g/Cpd*(lwflx(1:km,:,:)-lwflx(0:km-1,:,:))/        &
              (plev(1:km,:,:)-plev(0:km-1,:,:))/100.
lwflx_out = -lwflx(0:km-1,:,:)
up_out    = -up(0:km-1,:,:)
down_out  = down(0:km-1,:,:)
tau_out   = tau(0:km-1,:,:) * beta
! Surface radiative flux
SrfRadFlx = -lwflx(km,:,:) + solin

Tinc = Tdot*2.*dt
Tdot = Tdot*86400.
lwhr = Tdot

do k=1,km
swflx_out(k,:,:) = solin
enddo
swhr = 0.

end subroutine driver

! - - - > midlevel
! ----- > surfaces

!- - - - - - - - - - - - kappa(0),T(0)                  TOP OF ATMOSPHERE
!----------------------- press(0),tau(0),up/down(0)
!- - - - - - - - - - - - kappa(1),T(1)
!----------------------- press(1)
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - - kappa(nlev)
!----------------------- press(nlev)
!- - - - - - - - - - - - kappa(nlev+1)                  SURFACE

max_stars_repo_name: CliMT/climt-legacy

max_issues_repo_name: CliMT/climt-legacy

max_forks_repo_name: CliMT/climt-legacy


text:
! Program to test the MERGE intrinsic
program intrinsic_merge
   integer, dimension(3) :: a, b
   integer i

   a = (/-1, 2, 3/)

   i = 5
   if (merge (-1, 1, i .gt. 3) .ne. -1) call abort
   i = 1
   if (merge (-1, 1, i .ge. 3) .ne. 1) call abort

   b = merge(a, 0, a .ge. 0)
   if (any (b .ne. (/0, 2, 3/))) call abort
end program

max_issues_repo_name: vidkidz/crossbridge

max_forks_repo_name: vidkidz/crossbridge


text:
      subroutine rdvars
************************************************************************
*
*   RDVARS -- Read the variables from the input file.
*
************************************************************************
      include "parameters.h"

      integer nepn
      parameter(nepn=npde+2)

      double precision wpde,eltvsc,tensn,press,rad0,fdinc,dxymin
      common /mfe020/ wpde(npde)
      common /mfe021/ eltvsc(npde),tensn(npde),press(npde),rad0
      common /mfe022/ fdinc,dxymin

      double precision tout
      integer nout,ofreq,mstep,imsg
      common /mfe050/ tout(50),nout,ofreq,mstep,imsg

      double precision ptol,rtol
      common /mfe060/ ptol(nepn),rtol

      integer mtry,mitr,mvec
      double precision h,hlb,ntol,margin,vtol
      common /mfe062/ h,hlb,ntol,margin,vtol,mtry,mitr,mvec

      double precision usera
      common /mfe100/ usera(25)

      integer j,k
      character*8 label

      read(5,'(a)',end=910,err=910) label
      if(label .ne. '$') go to 910
*     ==================================================================
*      Read the input parameters.
*     ==================================================================
      read(5,*,end=920,err=930) label, (wpde(k), k=1,npde)
      read(5,*,end=920,err=930) label, (eltvsc(k), k=1,npde)
      read(5,*,end=920,err=930) label, (tensn(k), k=1,npde)
      read(5,*,end=920,err=930) label, (press(k), k=1,npde)
      read(5,*,end=920,err=930) label, rad0
      read(5,*,end=920,err=930) label, fdinc
      read(5,*,end=920,err=930) label, dxymin

      read(5,*,end=920,err=930) label, imsg
      read(5,*,end=920,err=930) label, ofreq
      read(5,*,end=920,err=930) label, mstep
      read(5,*,end=920,err=930) label, nout
      read(5,*,end=920,err=930) label, (tout(j), j=1,nout)

      read(5,*,end=920,err=930) label, rtol
      read(5,*,end=920,err=930) label, (ptol(k), k=1,nepn)

      read(5,*,end=920,err=930) label, h
      read(5,*,end=920,err=930) label, hlb
      read(5,*,end=920,err=930) label, margin
      read(5,*,end=920,err=930) label, ntol
      read(5,*,end=920,err=930) label, mitr
      read(5,*,end=920,err=930) label, vtol
      read(5,*,end=920,err=930) label, mvec
*     ==================================================================
*      Echo the input parameters.
*     ==================================================================
  100 format(//a/)
  110 format(t3,a,t42,'=',i6)
  120 format(t3,a,t42,'=',g11.4)
  130 format(t3,a,t42,'=',(t43,g11.4,2g12.4))
  140 format(t3,'(',a8,') =',g11.4)
  150 format()

      write(8,100) 'M F E   P A R A M E T E R S'
      write(8,130) 'Equation weights (WPDE)', (wpde(k), k=1,npde)
      write(8,130) 'Element viscosities (ELTVSC)', (eltvsc(k), k=1,npde)
      write(8,130) 'Element tensions (TENSN)', (tensn(k), k=1,npde)
      write(8,130) 'Element pressures (PRESS)', (press(k), k=1,npde)
      write(8,120) 'Element pressure radius (RAD0)', rad0
      write(8,120) 'Jacobian increment (FDINC)', fdinc
      write(8,120) 'Minimum element area (DXYMIN)', dxymin
      write(8,150)
      write(8,110) 'BDF2 message flag (IMSG)', imsg
      write(8,110) 'Output frequency (OFREQ)', ofreq
      write(8,110) 'Maximum number of steps (MSTEP)', mstep
      write(8,130) 'Solution output times (TOUT)', (tout(j), j=1,nout)
      write(8,150)
      write(8,120) 'Relative tolerance on areas (RTOL)', rtol
      write(8,130) 'Predictor error tolerance (PTOL)',(ptol(k),k=1,nepn)
      write(8,150)
      write(8,120) 'Initial time step (H)', h
      write(8,120) 'Time step lower bound (HLB)', hlb
      write(8,120) 'Jacobian time step margin (MARGIN)', margin
      write(8,120) 'Newton iteration tolerance (NTOL)', ntol
      write(8,110) 'Maximum number of iterations (MITR)', mitr
      write(8,120) 'Vector tolerance in GMRES (VTOL)', vtol
      write(8,110) 'Max no of vectors in GMRES (MVEC)', mvec

      read(5,'(a)',end=910,err=910) label
      if(label .ne. '$') go to 910
*     ==================================================================
*      Read and echo the user parameters.
*     ==================================================================
      do 30 j=1,25
       read(5,*,end=31,err=930) label, usera(j)
       if(j .eq. 1) then
        write(8,100) 'U S E R   D E F I N E D   V A R I A B L E S'
        endif
       write(8,140) label, usera(j)
   30 continue
   31 continue

      close(5)

      return
*     ==================================================================
*      Input errors.
*     ==================================================================
  910 write(8,911)
  911 format(/'** RDVARS: Bad file format -- expecting a ''$''.',
     +       /'** Aborting execution.')
      stop

  920 write(8,921)
  921 format(/'** RDVARS: Bad file format -- at EOF.',
     +       /'** Aborting execution.')
      stop

  930 write(8,931) label
  931 format(/'** RDVARS: Bad file format -- part of line:',a,
     +       /'** Aborting execution.')
      stop
      end

max_stars_repo_name: mfeproject/legacy-gwmfe

max_issues_repo_name: mfeproject/legacy-gwmfe

max_forks_repo_name: mfeproject/legacy-gwmfe