text:
subroutine abcoefs

!      coefficients for the Adams-Bashforth scheme

use grid

implicit none

real alpha, beta

if(nstep.ge.3.and.nadams.eq.3.or.nrestart.eq.2) then
  alpha = dt3(nb) / dt3(na)
  beta = dt3(nc) / dt3(na)
  ct = (2.+3.* alpha) / (6.* (alpha + beta) * beta)
  bt = -(1.+2.*(alpha + beta) * ct)/(2. * alpha)
  at = 1. - bt - ct
else if(nstep.ge.2) then
  at = 3./2.
  bt = -1./2.
  ct = 0.
else
  at = 1.
  bt = 0.
  ct = 0.
end if

end subroutine abcoefs

max_stars_repo_name: kbren/uwnet

max_issues_repo_name: kbren/uwnet

max_forks_repo_name: kbren/uwnet


text:
      double complex function A41HAQggmppp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A41phiAQggmppp,A41phiAQggmpmm
      integer j1,j2,j3,j4

      A41HAQggmppp=
     .   A41phiAQggmppp(j1,j2,j3,j4,za,zb)
     .  -A41phiAQggmpmm(j2,j1,j4,j3,zb,za)

      return
      end

      double complex function A41HAQggmpmm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A41phiAQggmpmm,A41phiAQggmppp
      integer j1,j2,j3,j4

      A41HAQggmpmm=
     .    A41phiAQggmpmm(j1,j2,j3,j4,za,zb)
     .   -A41phiAQggmppp(j2,j1,j4,j3,zb,za)

      return
      end

      double complex function A41HAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A41phiAQggmpmp
      integer j1,j2,j3,j4

      A41HAQggmpmp=
     .    A41phiAQggmpmp(j1,j2,j3,j4,za,zb)
     .   -A41phiAQggmpmp(j2,j1,j4,j3,zb,za)

      return
      end

      double complex function A41HAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      double complex A41phiAQggmppm
      integer j1,j2,j3,j4

      A41HAQggmppm=
     .    A41phiAQggmppm(j1,j2,j3,j4,za,zb)
     .   -A41phiAQggmppm(j2,j1,j4,j3,zb,za)

      return
      end

ext: f

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
      SUBROUTINE OUTSEM (I)
C     PRINT A SINGLE SEMANTIC ACTION FOR A PRODUCTION
C     GF 11.07.1980
C
      INCLUDE 'PARS.f'
      INCLUDE 'SEMS.f'
      INTEGER*2 I
     = ,CODE
     = ,SEMNO(40) ! MNEMONICS FOR THE SEMANTIC ACTIONS
      DATA SEMNO
     = /'AC','CO',  'AC','IN',  'AC','MA',  'AC','TA'
     = ,'AT','CO',  'AT','IN',  'AT','MA',  'SY','AT'
     = ,'SO','CO',  'RE','IN',  'UN','CH',  'SO','TA'
     = ,'SY','CO',  'SY','IN',  'SY','MA',  'SE','PR'
     = ,'AC','CU',  'AT','TR',  'EO','SY',  'EO','S '
     = /
      CODE = SEM(I)
      CALL ZZWC (SEMNO,CODE*4-3,CODE*4,0)
      CALL ZZWC('(',1,1,0)
      CALL PUTSYM (SEMSYM(I))
      CALL ZZWC (')',1,1,3)
      IF (CODE .EQ. EOS) I = - 1 ! RETURN 'I=0'
      I = I + 1
      RETURN ! OUTSEM
      END

max_stars_repo_name: gfis/jextra

max_issues_repo_name: gfis/jextra

max_forks_repo_name: gfis/jextra


! Test that NULLIFY works

Module share
  Real, Pointer :: rp
  Procedure(Real), Pointer :: mprp
End Module share

Program nullifytest
Use share

INTEGER, PARAMETER :: maxvalue=1024

Type dt
  Integer :: l = 3
End Type
Type t
  Type(dt),Pointer :: p
End Type

Type(t),Allocatable :: x(:)
Type(t),Pointer :: y(:)
Type(t),Pointer :: z

Integer, Pointer :: pi
Procedure(Real), Pointer :: prp

Allocate(rp)
Nullify(rp)

Allocate(x(3))
Nullify(x(2)%p)

Nullify(y(2)%p)

Nullify(pi)
Nullify(prp)
Nullify(mprp)

Nullify(z%p)

End Program


text:
Cartridge World Davis is a locally owned and owner operated store that specializes in ink cartridges refilled ink cartridge refilling and toner cartridge remanufacturing for printers, fax machines and small copiers. At Cartridge World Davis, they help save consumers money while making the environmentally superior choice.

Their old location was at 516 2nd Street, next door to the old Mishkas.  As of Summer 2011, it looks like a new fish grill is opening in that location.

>ReusingEven Better Than Recycling<
>Buying Locally Supports a Strong Local Economy<
>Save Money and Save the World...One Cartridge at a Time!<

20081104 14:19:46 nbsp The people who work at this store are assholes and will tow your car illegally with no warning. Never park in the parking lot behind their store or you will go through hell, although I was not charged for the towing as the company that towed me realizes the girls there are nuts. Users/AllanRae

   I always thought that this particular parking lot was not a public spot. Users/SunjeetBaadkar

20081207 15:14:33 nbsp there are signs before you enter telling you it is for employees only Users/EricaMacGregor

20081210 10:53:37 nbsp Though we are a little wacky at CW Davis, Im not sure we qualify as NUTS. As everyone knows, parking in Davis is a huge problem. Parking in employee/staff parking keeps the businesses that pay for those spots from opening, closing and functioning smoothly throughout the day. And for a business that makes deliveries...forget about it. So, if anyone is wondering, all the spaces in this building are now occupied and all the tenants can and will tow, LEGALLY. For the gentleman complaining about being towed, there is a sign at the entrance that says the parking is for employees only. This would see to be warning enough, but weve taken further precautions. Cartridge World spaces are marked clearly with blue and yellow paint. AND, on the night in question we put an orange construction cone with a sign indicating not to park in the exact space you were towed from. What more can business owners be expected to do? Users/VictoriaRohl

20090814 09:56:53 nbsp The staff is very friendly and even stayed open a bit later so I could refill 2 cartridges.  Great Service! I would definitly recommend them to anyone. Users/KatherineL

20100422 13:18:01 nbsp Seems like they have closed. Store is locked, no answering machine.  Users/BryanPon

20100427 14:44:17 nbsp This place is Great, I like the people who work here, and they provide Ink @ a downtown location, making it much easier to gather supplies (paper also) for someone like myself who walks / rides bike. Users/ReViewer

20100520 11:16:13 nbsp Ive been passing by hereandthere for the last 2 months and it seems like the store shut down? Always dark with blinds closed and door locked...  Users/ThUn

  Yes, whats the deal? Is it closed, or what? Users/NaBarry
   http://www.cartridgeworld.com/StoreFinder.aspx?zip95616 Store finder for zip code 95616... The Davis location doesnt show up, so thats probably a no. How unfortunate, I never had a chance to patronize their business. I still have their business card taped to the side of my desk. Users/EBT

20100621 18:00:55 nbsp They are supposedly coming back...not sure when... Users/SunjeetBaadkar

20100709 11:07:52 nbsp Cartridge World is reopening at 130 G Street next to Volleys under new ownership!  They should be open by Monday July 19th in their new location.  The phone number is the same 5302977200. Users/vincentc

20101115 15:32:14 nbsp I love this place! Used to buy cartridges new, but decided to try refilling so I get to recycle them AND its cheaper. Cartridge World is in this tiny little storefront next to Volleys. I called about refilling two cartridges and the girl who answered was so nice and helpful. I just picked up one and the second should be ready tomorrow. Will definitely be going back on the regular. Users/SarahdeCrescenzo

20120302 13:17:47 nbsp Great place; smaller than the original store so they have less stock, but Im still able to get quick service on almost everything I need. They almost always have the lowest cost, and have a very helpful staff and a timesaving delivery option. Although its only a few minutes bike ride for me to pick up ink and toner if I need to. Ive never had any problems using any of their recycled products. Users/sedberg

20120723 09:00:35 nbsp Cartridge World has saved me both money and time.  It is great to be able to walk in and have someone there who will help you find the right cartridge every time.   Users/JeremyTurner

20140418 16:33:37 nbsp Closed last month.  Users/MyRealName

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
ELEMENTAL FUNCTION func_hypergeometric(a, b, c, z) RESULT(ans)
    ! NOTE: See https://en.wikipedia.org/wiki/Hypergeometric_function
    ! NOTE: See https://docs.scipy.org/doc/scipy/reference/generated/scipy.special.hyp2f1.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), INTENT(in)                                             :: a
    REAL(kind = REAL64), INTENT(in)                                             :: b
    REAL(kind = REAL64), INTENT(in)                                             :: c
    REAL(kind = REAL64), INTENT(in)                                             :: z

    ! Declare internal parameters ...
    INTEGER(kind = INT64), PARAMETER                                            :: imax = 1024_INT64
    REAL(kind = REAL64), PARAMETER                                              :: epsmin = 1.0e-10_REAL64

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: i
    REAL(kind = REAL64)                                                         :: eps
    REAL(kind = REAL64)                                                         :: n

    ! Check that this value of z means that the answer is obtainable via the
    ! power series ...
    IF(ABS(z) < 1.0e0_REAL64)THEN
        ! Initialize answer ...
        ans = 1.0e0_REAL64

        ! Loop over iterations ...
        DO i = 1_INT64, imax
            ! Create short-hand ...
            n = REAL(i, kind = REAL64)

            ! Calculate increment ...
            eps = (func_rising_factorial(a, n) * func_rising_factorial(b, n) * (z ** i)) / (func_rising_factorial(c, n) * func_factorial(n))

            ! Increment answer ...
            ans = ans + eps

            ! Stop looping if the answer has converged ...
            IF(ABS(eps / ans) <= epsmin)THEN
                EXIT
            END IF
        END DO
    ELSE
        ! Set value ...
        ans = 0.0e0_REAL64
    END IF
END FUNCTION func_hypergeometric

max_stars_repo_name: Guymer/fortranlib

max_issues_repo_name: Guymer/fortranlib

max_forks_repo_name: Guymer/fortranlib


text:
c
c------------------------------------------------------------
c
       subroutine reg_slopes(q,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,lstgrd,
     &                   lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)

       use amr_module
       implicit double precision(a-h,o-z)

       dimension q(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &           qy(nvar,mitot,mjtot),irr(mitot,mjtot)
       dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
       dimension qxy(nvar,mitot,mjtot)
       logical  quad, nolimiter
       include "cuserdt.i"
       common /order2/ ssw, quad, nolimiter

c
c  Set all slopes, even for irregular or solid.
c  Will be fixed in slope routines for irregular/solid cells called afterwards

c      # ssw = slope switch (1. for slopes, 0 for donor cell 0 slopes)
c      # now set in amrcart
c
c   ssw = 0 for ctu (no slopes), 1 for muscl (second order).
c   compute slopes using muscl limiter
c   q contains either conserved or primitive variables
c
c  now set for quadratic reconstruction. Limiting done elsewhere
c  initialized in method (in case no slopes at all)

       hx2 = 2.d0*hx
       hy2 = 2.d0*hy
       hxsq = hx*hx
       hysq = hy*hy
c
       if (ssw .eq. 0.d0) go to 99
c
       do 12 j = 1, mjtot
       do 10 i = 2, mitot-1
       !!  for now do for all if (irr(i,j) .ne. lstgrd) go to 10
       do 11 m = 1, nvar
          qx(m,i,j)  = (q(m,i+1,j) - q(m,i-1,j))/hx2
          qxx(m,i,j) = (q(m,i+1,j)-2.d0*q(m,i,j)+q(m,i-1,j))/hxsq
 11    continue
 10    continue
 12    continue
c
       do 22 j = 2, mjtot-1
       do 21 i = 1, mitot
       !! for now do for all if (irr(i,j) .ne. lstgrd) go to 21
       do 20 m = 1, nvar
          qy(m,i,j) = (q(m,i,j+1) - q(m,i,j-1))/hy2
          qyy(m,i,j) = (q(m,i,j+1)-2.d0*q(m,i,j)+q(m,i,j-1))/hysq
          ! next line relies on qxy=0 at first and last rows/cols, so
          ! qxy only exists in interior
          if (i .gt. 1 .and. i .lt. mitot) then
             qxy(m,i,j) = (qx(m,i,j+1) - qx(m,i,j-1))/hy2
          endif
 20    continue
 21    continue
 22    continue
c
 99    continue
       return
       end


text:
      subroutine read_dwq(file_dwq, mmax  , nmax, ipnt )

      ! function : read a dwq file and check dimensions

      ! global declarations

      use filmod                   ! module contains everything for the files
      implicit none

      ! declaration of the arguments

      type(t_dlwqfile)                       :: file_dwq               ! aggregation-file
      integer                                :: mmax                   ! grid cells m direction
      integer                                :: nmax                   ! grid cells n direction
      integer                                :: ipnt(nmax,mmax)        ! aggregation pointer

      ! local declarations

      integer                                :: mmaxd                  ! grid cells m direction from dwq file
      integer                                :: nmaxd                  ! grid cells n direction from dwq file
      integer                                :: nmd                    ! total number of grid cells from dwq file
      integer                                :: ioptdd                 ! dido option ?
      integer                                :: idum                   ! dummy
      integer                                :: n,m                    ! loop counters
      integer                                :: ioerr                  ! error on file

      call dlwqfile_open(file_dwq)
      read(file_dwq%unit_nr,*,iostat=ioerr) nmaxd, mmaxd, nmd, ioptdd, idum
      if ( ioerr .ne. 0 ) then
         write(*,*) ' error reading dwq file'
         call srstop(1)
      endif

      if (nmaxd.ne.nmax.or.mmaxd.ne.mmax.or.nmd.ne.nmax*mmax) then
         write(*,*) ' dimensions grid on dido file differ from input hydrodynamics'
         call srstop(1)
      endif

      read(file_dwq%unit_nr,*,iostat=ioerr) ((ipnt(n,m),n=1,nmax),m=1,mmax)
      if ( ioerr .ne. 0 ) then
         write(*,*) ' error reading dwq file'
         call srstop(1)
      endif

      return
      end

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


! { dg-do compile }
!
! PR 54435: [4.7/4.8 Regression] ICE with SELECT TYPE on a non-CLASS object
!
! Contributed by xarthisius

subroutine foo(x)
  integer :: x
  select type (x)   ! { dg-error "Selector shall be polymorphic" }
  end select
end

! PR 54443: [4.7/4.8 Regression] Segmentation Fault when Compiling for code using Fortran Polymorphic Entities
!
! Contributed by Mark Beyer <mbeyer@cirrusaircraft.com>

program class_test
  type hashnode
    character(4) :: htype
  end type
  class(hashnode), pointer :: hp

  select type(hp%htype)   ! { dg-error "is not a named variable" }

end program


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief free the memory of all global main arrays (with dynamic size)
!>    @param[in] ismpl local sample index
      SUBROUTINE dealloc_arrays(ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_data
        use mod_time
        use mod_conc
        use mod_linfos
        use mod_OMP_TOOLS
        use mod_blocking_size
        IMPLICIT NONE
        integer :: ismpl
        INCLUDE 'OMP_TOOLS.inc'
        INTEGER mfactor
        INTRINSIC max

!
        IF (linfos(1)>=2) WRITE(*,*) ' [I] : ... dealloc_arrays'
!
!       single system size (factor == 1)
        mfactor = 1

        DEALLOCATE(project_sfx)

        DEALLOCATE(propunit)
        memory = memory - nunits*nprop*nsmpl

!       temporary convergence list
        DEALLOCATE(conc_conv)
        memory = memory - ntrac*nsmpl

!       inversion
        DEALLOCATE(opti_props)
        memory = memory - nunits*nprop
        DEALLOCATE(opti_bc)
        memory = memory - nunits*nbc
        DEALLOCATE(a_propunit)
        DEALLOCATE(d_propunit)
        DEALLOCATE(e_propunit)
        memory = memory - 3*nunits*nprop

        DEALLOCATE(node_info)
        memory = memory - i0*j0*k0
!     additional global & private vectors for linear system solver
!       global buffer for boundary exchange (+ismpl)
        DEALLOCATE(lss_bound_block)
        memory = memory - (block_i*block_j+block_i*block_k+block_j*block_k)*bdim_i*bdim_j*bdim_k*2*nsmpl
        DEALLOCATE(lss_dnrm)
        memory = memory - i0*j0*k0*nsmpl
        DEALLOCATE(lss_tmp)
        memory = memory - i0*j0*k0*nsmpl
!       private copy for preconditioning (+Tlevel_1 +ismpl)
        DEALLOCATE(lss_lma)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lmb)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lmc)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lmd)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lme)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lmf)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lmg)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lud)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lx)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_lb)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
!
        DEALLOCATE(lss_lloctmp)
        memory = memory - max_blocks*block_i*block_j*block_k*mfactor*max_loctmp*tlevel_1*nsmpl
!
        DEALLOCATE(lss_ldnrm)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
        DEALLOCATE(lss_ud_block)
        memory = memory - (block_i*block_j+block_i*block_k+block_j*block_k)*max_blocks*tlevel_1*nsmpl
        DEALLOCATE(lss_lr0_hat)
        memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl

!       variables for variable time stepping
        deallocate(flag_delt)
        memory = memory - nsmpl
        deallocate(delt_count)
        memory = memory - nsmpl
        deallocate(flag_1st_timestep)
        memory = memory - nsmpl
        deallocate(delt_old)
        memory = memory - nsmpl
!
!
!       coefficients for linear equations
        DEALLOCATE(a)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(b)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(c)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(d)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(e)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(f)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(g)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(x)
        memory = memory - i0*j0*k0*mfactor*nsmpl
!
        DEALLOCATE(w)
        memory = memory - i0*j0*k0*mfactor*nsmpl
        DEALLOCATE(r)
        memory = memory - i0*j0*k0*mfactor
        DEALLOCATE(bc_mask)
        memory = memory - i0*j0*k0*mfactor*nsmpl
!       only for ilu-precond. (shadow vectors)
        DEALLOCATE(ud)
        memory = memory - i0*j0*k0*mfactor*nsmpl
!
!
        DEALLOCATE(head)
        memory = memory - i0*j0*k0*nsmpl
        DEALLOCATE(temp)
        memory = memory - i0*j0*k0*nsmpl
        DEALLOCATE(conc)
        memory = memory - i0*j0*k0*max(ntrans,1)*nsmpl
        DEALLOCATE(pres)
        memory = memory - i0*j0*k0*nsmpl
        DEALLOCATE(tsal)
        memory = memory - i0*j0*k0*nsmpl
        DEALLOCATE(uindex)
        memory = memory - i0*j0*k0

        DEALLOCATE(headold)
        memory = memory - i0*j0*k0*ncgen*nsmpl
        DEALLOCATE(tempold)
        memory = memory - i0*j0*k0*ncgen*nsmpl
        DEALLOCATE(concold)
        memory = memory - i0*j0*k0*ncgen*nsmpl*max(ntrans,1)
        DEALLOCATE(presold)
        memory = memory - i0*j0*k0*ncgen*nsmpl

        DEALLOCATE(delx)
        memory = memory - i0
        DEALLOCATE(dely)
        memory = memory - j0
        DEALLOCATE(delz)
        memory = memory - k0
        DEALLOCATE(delxa)
        memory = memory - i0
        DEALLOCATE(delya)
        memory = memory - j0
        DEALLOCATE(delza)
        memory = memory - k0

        if (vdefaultswitch) then
           DEALLOCATE(vdefault)
        end if

!      dealloc. proz. grid array, see more in 'solve/omp_preconditioniers.f'
        CALL par_end2()

!     time periods
        DEALLOCATE(bcperiod)
        memory = memory - ngsmax*3*max(nbctp,1)*nsmpl
        DEALLOCATE(ibcperiod)
        memory = memory - max(nbctp,1)
        DEALLOCATE(lbcperiod)
        memory = memory - ngsmax*max(nbctp,1)
        DEALLOCATE(outt)
        memory = memory - max(noutt+1,1)
        DEALLOCATE(smon_idx)
        memory = memory - nsmpl
        deallocate(delta_time)
        memory = memory - max(ntimestep,1)
        DEALLOCATE(opti_tp)
        memory = memory - 3*ngsmax*mopti_tp*max(nbctp,1)

        DEALLOCATE(a_bcperiod)
        DEALLOCATE(d_bcperiod)
        DEALLOCATE(e_bcperiod)
        DEALLOCATE(tpwgt)
        memory = memory - 4*ngsmax*2*max(nbctp,1)
        DEALLOCATE(simtime)
        memory = memory - nsmpl

        DEALLOCATE(tr_switch)
        memory = memory - nsmpl

        DEALLOCATE(fh_table)
        memory = memory - c_fhandler*tlevel_0

        DEALLOCATE(diff_c)
        memory = memory - max(ntrans,1)
        DEALLOCATE(mmas_c)
        memory = memory - max(ntrans,1)
        DEALLOCATE(beta_c)
        memory = memory - max(ntrans,1)

!     boundary structures
        DEALLOCATE(ibc_data)
        memory = memory - max(nbc_data,1)*nibc
        DEALLOCATE(dbc_data)
        memory = memory - max(nbc_data,1)*ndbc*nsmpl
        DEALLOCATE(dbc_dataold)
        memory = memory - max(nbc_data,1)

!       borehole logs
        DEALLOCATE(ibh_pos)
        memory = memory - 2*nbh_logs
        DEALLOCATE(cbh_name)
        memory = memory - nbh_logs*64

!     - convergency history buffer -
        DEALLOCATE(conv_history)
        memory = memory - conv_hlen*conv_hmax*nsmpl
        DEALLOCATE(conv_chlen)
        DEALLOCATE(conv_ipos)
        DEALLOCATE(lcon)
        memory = memory - 3*conv_hmax*nsmpl

#ifdef DEBUG
        DEALLOCATE(debugout)
        n_debugout = 0
#endif

!     OpenMP specific REDUCTION staff
        DEALLOCATE(omp_dglobal)
        DEALLOCATE(omp_iglobal)
        memory = memory - 12*tlevel_1*nsmpl

!       allocated in "forward_init"
        DEALLOCATE(main_input)
        memory = memory - max(mpara,1)*nsmpl
        DEALLOCATE(main_output)
        memory = memory - max(ndata,1)*nsmpl

        write(*,*) "Deallocated Memory, remaining ",memory*8/1024/1024, " MB"
        RETURN
      END SUBROUTINE dealloc_arrays


text:
      SUBROUTINE ZROTG(CA,CB,C,S)
*     .. Scalar Arguments ..
      DOUBLE COMPLEX CA,CB,S
      DOUBLE PRECISION C
*     ..
*
*  Purpose
*  =======
*
*     determines a double complex Givens rotation.
*
*     .. Local Scalars ..
      DOUBLE COMPLEX ALPHA
      DOUBLE PRECISION NORM,SCALE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC CDABS,DCMPLX,DCONJG,DSQRT
*     ..
      IF (CDABS(CA).NE.0.0d0) GO TO 10
      C = 0.0d0
      S = (1.0d0,0.0d0)
      CA = CB
      GO TO 20
   10 CONTINUE
      SCALE = CDABS(CA) + CDABS(CB)
      NORM = SCALE*DSQRT((CDABS(CA/DCMPLX(SCALE,0.0d0)))**2+
     +       (CDABS(CB/DCMPLX(SCALE,0.0d0)))**2)
      ALPHA = CA/CDABS(CA)
      C = CDABS(CA)/NORM
      S = ALPHA*DCONJG(CB)/NORM
      CA = ALPHA*NORM
   20 CONTINUE
      RETURN
      END

max_stars_repo_name: nashmit/lapack-release

max_issues_repo_name: nashmit/lapack-release

max_forks_repo_name: nashmit/lapack-release


text:
My best contributions to the wiki were on University Construction. My worst contributions were to MU Games Area. My greatest sins were not updating either of them.

The lack of uptake to wiki:sf SFWiki makes me make this a face like this :(

20060710 21:11:40 nbsp Re: Wiki Update notice on front page:  Doh  I was waiting until the 17th so the notice was up two months.  But yeah, its been bugging me as well. Users/JabberWokky

20060807 19:20:36 nbsp Thanks  and now I know how to chop down those Aggie URLs.  I tried removing the GET vars, but it didnt work. Users/JabberWokky

20060819 19:31:30 nbsp I was merely giving structure to the pageand make it less onesidedwhen I added the Get over yourself.  JoshFernandez wrote his pro opinion and I merely transcribed it to the proturtle section that I appropriately created.  Yes, I chose one of many pro comments, but its not my duty to transcribe every single proturtle entry.  Instead of reverting to the version that existed prior to my edits, you could have easily transcribed the pro comments for the community yourself. Users/RishiTrivedi

20060819 22:33:55 nbsp thanks for helping to make the discussion civil. im tired. Users/MorganFlores

20060921 13:50:11 nbsp I wish my greatest sins were as slight as not updating a wiki page (and adorably misplaced facial hair). Why do you look so sad in the second picture?  Users/KaiTing
  Whatever, KaiTing.  You got served. Users/RishiTrivedi

Sorry, I created the Gulag page as it was a funny mention on a few pages, but honestly it is a dead thing and people should stop reviving a joke which has expired. ~Users/DavePoole


text:
      SUBROUTINE GX (ZZ,RH,XK,GZ,GZP)
C     SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX.
      COMPLEX GZ,GZP
      R2=ZZ*ZZ+RH*RH
      R=SQRT(R2)
      RK=XK*R
      GZ=CMPLX(COS(RK),-SIN(RK))/R
      GZP=-CMPLX(1.,RK)*GZ/R2
      RETURN
      END

max_stars_repo_name: ViperScience/ViperNEC

max_issues_repo_name: ViperScience/ViperNEC

max_forks_repo_name: ViperScience/ViperNEC


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine calwav ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Wave characteristics

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        CALCULATE WAVE CHARACTERISTICS FROM EMIPRICAL FORMULAES
!        MODEL IS VERTICALLY AVERAGED.
!
!        AVERAGED MODELS
!
! Name    T   L I/O  Description                              Units
! ----    --- -  -   -------------------                      ----
! DEPTH   R   1  I   Water depth                                       [m]
! DS      R   1  L   Standaard deptch                                  [-]
! FETCH   R   1  I   Fetch                                             [m]
! FS      R   1  L   Standaard fetch                                   [-]
! G       R   1  I   Acceleration of gravity                        [m/s2]
! RHOW    R   1  I   Density of water                              [kg/m3]
! VWIND   R   1  I   Wind velocity at 10 m                           [m/s]

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4
!
!     Local declarations, constants in source
!
      PARAMETER ( G      =     9.8    ,
     +            RHOW   =  1000.0    ,
     +            PI     = 3.14159265 )
      REAL        INIDEP
!
      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
!
      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG
!!    CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
!!    IF (IKMRK1.EQ.1) THEN
      IF (BTEST(IKNMRK(ISEG),0)) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
!     IF (IKMRK2.EQ.0) THEN
      IF (IKMRK2.EQ.0 .OR. IKMRK2.EQ.3) THEN
!
      VWIND   = PMSA(IP1 )
      FETCH   = PMSA(IP2 )
      DEPTH   = PMSA(IP3 )
      INIDEP  = PMSA(IP4 )

      IF (FETCH .LT. 1E-20 )  CALL ERRSYS ('FETCH in CALWAVE zero', 1)
!     IF (VWIND .LT. 1E-20 )  CALL ERRSYS ('VWIND in CALTAU zero', 1 )

!     Initialisation
      H       = 0.0
      RL      = 0.0
      T       = 0.0

!     Check if user wants to use value of inidepth (pos values only)
      IF (INIDEP .LT. 0.0) INIDEP = DEPTH

!     Shear stress by wind
      IF (VWIND .LT. 0.0001) GOTO 150

!     dimensieloze strijklengte
      FS   = G * FETCH / VWIND**2
!     write(*,*) 'FS:', FS

!     dimensieloze diepte
      DS   = G * INIDEP / VWIND**2
!     write(*,*) 'DS:', DS

!     bepaal golfhoogte H
      A1   = 0.710 *( DS**0.763 )
      A2   = 0.855 *( DS**0.365 )
      A3   = 0.0150*( FS**0.450 ) / TANH(A1)
      A4   = 0.0345*( FS**0.370 ) / TANH(A2)
      HS   = 0.240 * TANH( A1) * TANH( A3)
!     write(*,*) 'HS:', HS
      TS   = 2.0*PI* TANH( A2) * TANH( A4)
!     write(*,*) 'TS:', TS
      H    = HS * ( VWIND * VWIND) / G
!     write(*,*) 'H:', H

!     bepaal golfperiode T
      T    = TS * VWIND /G
!     write(*,*) 'T:', T

!     bepaling golflengte (iteratief hier niet opgenomen)
      RL0  = G * T * T / ( 2.0 * PI)
!     write(*,*) 'L0:', RL0
      A5   = 2.0 * PI * INIDEP / RL0

!     afscherming voor te groot argument functie tanh
!     voor diepe systemen tov golflengte
!     A5 groot, tanh=1, rl=rl0, a5=a6,sinh(>9)->0,ubg->fwg->0
      if (A5 .gt. 9.) then
         RL  = RL0
      else
!     let op sommige documentatie stelt: RL = RL0*SQRT (TANH (A5))
         RL  = RL0 * TANH(A5)
      endif
!     write(*,*) 'L:', RL

  150 CONTINUE
!
      PMSA (IP5) = H
      PMSA (IP6) = RL
      PMSA (IP7) = T
!
      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + INCREM (  1 )
      IP2   = IP2   + INCREM (  2 )
      IP3   = IP3   + INCREM (  3 )
      IP4   = IP4   + INCREM (  4 )
      IP5   = IP5   + INCREM (  5 )
      IP6   = IP6   + INCREM (  6 )
      IP7   = IP7   + INCREM (  7 )
!
 9000 CONTINUE
!

      RETURN
      END


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!!  Interface to access Delwaq from MT3D

   module MT3D
      logical :: MT3D_debug = .false.
   end module

   logical function MT3D_set_debug_status (set_MT3D_debug)
      !DEC$ ATTRIBUTES DLLEXPORT::MT3D_set_debug_status
      !DEC$ ATTRIBUTES DECORATE, ALIAS : 'MT3D_SET_DEBUG_STATUS' :: MT3D_set_debug_status

      use MT3D

      implicit none

      logical :: set_MT3D_debug

      MT3D_debug = set_MT3D_debug

      MT3D_set_debug_status = .true.
   end function

   logical function MT3D_processes_init (number_segments, number_substances, substances, &
                                         number_parameters, process_parameters, process_parameter_values, &
                                         number_processes, processes, deltt_in)
      !DEC$ ATTRIBUTES DLLEXPORT::MT3D_processes_init
      !DEC$ ATTRIBUTES DECORATE, ALIAS : 'MT3D_PROCESSES_INIT' :: MT3D_processes_init

      use waq_omi_priv
      use MT3D

      implicit none

      integer, intent(in)                                        :: number_segments
      integer, intent(in)                                        :: number_substances
      character(len=*), dimension(number_substances), intent(in) :: substances
      integer, intent(in)                                        :: number_parameters
      character(len=*), dimension(number_parameters), intent(in) :: process_parameters
      real, dimension(number_segments, number_parameters), intent(in) :: process_parameter_values
      integer, intent(in)                                        :: number_processes
      character(len=*), dimension(number_processes), intent(in)  :: processes
      real, intent(in)                                           :: deltt_in               ! In days, real

      logical, external       :: SetReferenceDate
      logical, external       :: SetIntegrationOptions
      logical, external       :: SetSimulationTimes
      logical, external       :: DefineWQSchematisation
      logical, external       :: DefineMonitoringLocations
      logical, external       :: DefineWQDispersion
      logical, external       :: DefineWQProcessesX
      logical, external       :: DefineWQExtraOutputParameters
      logical, external       :: SetCurrentValueScalarInit
      logical, external       :: SetCurrentValueFieldInit
      logical, external       :: SetOutputTimers
      logical, external       :: SetInitialVolume
      integer, external       :: ModelInitialize
      logical, external       :: SetFlowData
      logical, external       :: SetBoundaryConditions

      integer, parameter      :: integration_method = 0

      integer, dimension(1,4) :: pointers = reshape((/ 0, 0, 0, 0  /), (/ 1,4 /))
      integer, dimension(4)   :: number_exchanges = (/ 0, 0, 0, 0 /)
      real, dimension(3)      :: dispersion = (/ 0.0, 0.0, 0.0 /)
      real, dimension(2)      :: dispersion_length = (/ 1.0, 1.0 /)
      real, dimension(1)      :: flow = (/ 0.0 /)
      real, dimension(1)      :: area = (/ 1.0 /)

      real, allocatable       :: substance_concentrations(:,:)
      real, allocatable       :: substance_boundary_concentrations(:)
      real, allocatable       :: volume(:)
      integer, allocatable    :: substance_mult(:)
      real                    :: dvol_dt

      integer                 :: startTime = 0     !< Start time in seconds since the reference date/time
      integer                 :: endTime = huge(0) !< Stop time in seconds since the reference date/time
      integer                 :: deltt             !< Time step in seconds

      character(len=8)        :: cseg
      integer, dimension(number_segments) :: imon
      character(len=8), dimension(number_segments) :: cmon

      logical :: success, debug
      integer :: success_int, iseg, isub, ipar, i

      MT3D_processes_init = .false.

      deltt = int(deltt_in * 86400.0e0)     ! From days (real) to seconds integer

      allocate (substance_boundary_concentrations(number_substances))
      allocate (volume(number_segments))
      allocate (substance_mult(number_substances))
      substance_mult = 1

      success = SetReferenceDate( 2014, 1, 1, 0, 0, 0 )
      if(.not.success) return
      success = SetIntegrationOptions(integration_method, .true., .true., .true., .false., .false.)
      if(.not.success) return
      success = SetSimulationTimes( startTime, endTime, deltt )
      if(.not.success) return
      success = DefineWQSchematisation( number_segments, pointers, number_exchanges )
      if(.not.success) return

      if (mt3d_debug) then
         cseg = "s0000000"
         do iseg = 1, min(100,number_segments)
            imon(iseg) = iseg
            write(cseg(2:8), '(I7.7)') iseg
            cmon(iseg) = cseg
         end do
         success = DefineMonitoringLocations(imon, cmon, min(100,number_segments))
         if(.not.success) return
      else
         success = DefineMonitoringLocations( (/0/), (/ ' ' /), 0 )
         if(.not.success) return
      endif

      success = DefineWQDispersion(dispersion, dispersion_length ) ! dummy values
      if(.not.success) return

      success = DefineWQProcessesX( substances, substance_mult, number_substances, number_substances, &
                                    (/ 'DELT'/), 1 , &
                                   process_parameters, number_parameters,   &
                                   processes, number_processes)
      if(.not.success) return
      success = DefineWQExtraOutputParameters( (/ 'DELT' /), 1 )
      if(.not.success) return
      do isub = 1, number_substances
         success = SetCurrentValueScalarInit( substances(isub), 0.0 )
         if(.not.success) return
      end do
      do ipar = 1, number_parameters
         success = SetCurrentValueFieldInit( process_parameters (ipar), process_parameter_values(1:number_segments,ipar))
         if(.not.success) return
      end do

      if (mt3d_debug) then
         success = SetOutputTimers( 1, 0, endTime, deltt )
         if(.not.success) return
         success = SetOutputTimers( 2, 0, endTime, deltt )
         if(.not.success) return
         success = SetOutputTimers( 3, 0, endTime, deltt )
         if(.not.success) return
      else
         success = SetOutputTimers( 1, endTime, endTime, endTime )
         if(.not.success) return
         success = SetOutputTimers( 2, endTime, endTime, endTime )
         if(.not.success) return
         success = SetOutputTimers( 3, endTime, endTime, endTime )
         if(.not.success) return
      end if

      volume  = 1.0e0
      success = SetInitialVolume( volume )
      if(.not.success) return
      success_int = ModelInitialize()
      if(.not.success_int.eq.0) return
      success = SetFlowData( volume, area, flow )
      if(.not.success) return
      substance_boundary_concentrations = 0.0
      success = SetBoundaryConditions( 1, substance_boundary_concentrations )
      if(.not.success) return

      MT3D_processes_init = .true.
   end function MT3D_processes_init

   logical function MT3D_processes_setpar (number_parameters, number_segments, process_parameters, process_parameter_values)
      !DEC$ ATTRIBUTES DLLEXPORT::MT3D_processes_setpar
      !DEC$ ATTRIBUTES DECORATE, ALIAS : 'MT3D_PROCESSES_SETPAR' :: MT3D_processes_setpar

!      use MT3D_PL

      implicit none

      integer, intent(in)                                        :: number_parameters
      integer, intent(in)                                        :: number_segments
      character(len=*), dimension(number_parameters), intent(in) :: process_parameters
      real, dimension(number_segments, number_parameters), intent(in) :: process_parameter_values

      logical, external       :: SetCurrentValueFieldInit

      logical :: success
      integer :: ipar, i

      MT3D_processes_setpar = .false.

      do ipar = 1, number_parameters
         success = SetCurrentValueFieldInit( process_parameters (ipar), process_parameter_values(1:number_segments,ipar))
         if(.not.success) return
      end do

      MT3D_processes_setpar = .true.
   end function MT3D_processes_setpar

   logical function MT3D_processes_step (number_segments, number_substances, substance_concentrations, deltt_in )
      !DEC$ ATTRIBUTES DLLEXPORT::MT3D_processes_step
      !DEC$ ATTRIBUTES DECORATE, ALIAS : 'MT3D_PROCESSES_STEP' :: MT3D_processes_step

!      use MT3D_PL
      use waq_omi_priv

      implicit none

      logical, external          :: SetSimulationTimes
      integer, external          :: ModelPerformTimeStep

      integer, intent(in)                                                 :: number_segments
      integer, intent(in)                                                 :: number_substances
      real, dimension(number_segments, number_substances), intent (inout) :: substance_concentrations
      real, intent(in)                                                    :: deltt_in               ! In days

      integer                 :: startTime = 0   !< Start time in seconds since the reference date/time
      integer                 :: endTime         !< Stop time in seconds since the reference date/time
      integer                 :: deltt           !< Time step in seconds

!      double precision, dimension(number_segments, number_substances) :: substance_concentrations_dbl

      logical :: success
      integer :: isub, i, success_int

      deltt = int(deltt_in * 86400.0e0)     ! In seconds
      startTime = 0
      endTime = huge(0)                     ! no end time until finalization
      success = SetSimulationTimes( startTime, endTime, deltt )
      if(.not.success) return

      MT3D_processes_step = .false.

      do isub = 1, number_substances
         success = SetValuePriv( DLWQ_CONCENTRATION, isub, ODA_ALL_SEGMENTS, substance_concentrations(1:number_segments, isub), dlwq_set )
      end do
      if(.not.success) return
      success_int = ModelPerformTimeStep()
      if(.not.success_int.eq.0) return
      do isub = 1, number_substances
         success = GetValuePriv( DLWQ_CONCENTRATION, isub, ODA_ALL_SEGMENTS, substance_concentrations(1:number_segments, isub) )
         if(.not.success) return
      end do

      MT3D_processes_step = .true.
   end function MT3D_processes_step

   logical function MT3D_processes_fin ()
      !DEC$ ATTRIBUTES DLLEXPORT::MT3D_processes_fin
      !DEC$ ATTRIBUTES DECORATE, ALIAS : 'MT3D_PROCESSES_FIN' :: MT3D_processes_fin

      implicit none

      integer, external       :: ModelFinalize
      integer                 :: success_int

      success_int = ModelFinalize()

      MT3D_processes_fin = success_int.eq.0
   end function MT3D_processes_fin


text:
module modis29

	use CKD_common

	implicit none
	private

	integer, parameter :: ni = 5
	integer, parameter :: no3 = 1
	integer, parameter :: nch4 = 1
	integer, parameter :: nn2o = 2

	public :: ch29, init_ch29

contains

	subroutine init_ch29(modis_channel)

		type(ckd_type), intent(inout) :: modis_channel
		integer :: all_weights

		all_weights = ni*nch4*no3*nn2o

		modis_channel%num_weights = all_weights
		allocate(modis_channel%weights(all_weights))
		allocate(modis_channel%taus(all_weights, max_layers))

	end subroutine init_ch29

      subroutine ch29(u0, p0, t0, ux, fac,modis_channel)
!
!      This routine was developed for MODIS Channel 29: 1140-1200 cm^{-1}
!
!-----------------------------------------------------------------
!     Channel 29   8.33 - 8.77 microns
!-----------------------------------------------------------------
!  INPUTS:
!     u0 --> water vapor amount [g/cm2/km]
!     p0 --> pressure in atmospheres
!     t0 --> temp in K
!	  ux --> ozone (g/cm^2/km)
!     fac --> layer thickness in km
!-----------------------------------------------------------------
		real, dimension(:), intent(in) :: u0, p0, t0, ux, fac
		type(ckd_type), intent(inout) :: modis_channel

		integer, parameter :: nlev = max_levels
		integer, parameter :: nlay = max_layers
		integer, parameter :: mlv = nlay

		real :: p(nlay), t(nlay),u(nlay), uo3(nlay), un2o(nlay), xlog, &
				  uch4(nlay)

		real :: tau(ni,nlay),tauch4(nch4, nlay), tauo3(no3, nlay), taun2o(nn2o, nlay), &
				 f(ni), fo3(no3), fn2o(nn2o), fch4(nch4), twin

		integer :: i,m, ic, id, index

      do m=1,nlay
        t(m)=(t0(m)+t0(m+1))/2.0
        xlog=(log10(p0(m))+log10(p0(m+1)))/2.0
        p(m)=10.0**xlog
        xlog=(log10(u0(m))+log10(u0(m+1)))/2.0
        u(m)=fac(m)*10.0**xlog
        xlog=(log10(ux(m))+log10(ux(m+1)))/2.0
        uo3(m)=fac(m)*10.0**xlog
        uch4(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*1.75e-06*fac(m)* &
     &          1.0e+05/6.023e+23*16.04303
        un2o(m)=p(m)*1.01325e+06/(1.3805e-16*t(m))*3.10e-07*fac(m)* &
     &          1.0e+05/6.023e+23*44.0128
	  enddo

      call ck_29(u,f,p,t,tau)
      call cko3_29(uo3,fo3,p,t,tauo3)
      call ckch4_29(uch4,fch4,p,t,tauch4)
      call ckn2o_29(un2o,fn2o,p,t,taun2o)

      do m=1,nlay
        call window_29(u(m),twin,p(m),t(m),fac(m))
           do id=1,nn2o   ! two k's for n2o
        do i=1,ni         ! five k's for water vapor
		   index = (id-1)*ni + i
			modis_channel%taus(index,m)=tau(i,m)+twin+tauo3(1,m) &
     &          +tauch4(1,m)+taun2o(id,m)
			if (m == 1) modis_channel%weights(index) = f(i)*fo3(1)*fch4(1)*fn2o(id)
           end do
        end do
      enddo

	end subroutine ch29

! *********************************************************************
!     h2o 1140-1200 cm^{-1}
      subroutine ck_29(u,f,p,t,tau)
		real, dimension(:), intent(in) :: p, t, u

		real, dimension(:), intent(inout) :: f
		real, dimension(:,:), intent(inout) :: tau

		integer, parameter :: mlv = max_layers
		integer :: m

		real :: k(ni)
		real :: coefk(ni,3,num_pressures)
		integer :: i, jp, jt
      f(1)=0.624325
      f(2)=0.253393
      f(3)=0.089834
      f(4)=0.026964
      f(5)=0.005484
      k(1)=0.0072755
      do i=2,ni
        k(i)=8.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 0.00000,0.00000,0.00000,0.00000,0.00000,0.00000, &
     & 0.00000,0.00006,0.00065,0.00265,0.00730,0.01769, &
     & 0.04487,0.11014,0.24011,0.44539,0.77830,1.26324, &
     & 1.93516, &
     & 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, &
     & 0.000e+00,1.275e-06,1.470e-05,5.463e-05,1.524e-04,3.462e-04, &
     & 8.261e-04,1.945e-03,4.299e-03,7.952e-03,1.399e-02,2.282e-02, &
     & 3.441e-02, &
     & 0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00,0.000e+00, &
     & 0.000e+00,5.625e-09,1.125e-07,3.906e-07,1.178e-06,2.606e-06, &
     & 5.284e-06,1.178e-05,2.511e-05,4.654e-05,7.976e-05,1.279e-04, &
     & 1.867e-04/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 0.00000,0.00000,0.00000,0.00000,0.00001,0.00021, &
     & 0.00100,0.00301,0.00822,0.02028,0.04442,0.09274, &
     & 0.16324,0.26366,0.39942,0.58242,0.84505,1.18790, &
     & 1.68415, &
     & 0.000e+00,0.000e+00,0.000e+00,0.000e+00,2.125e-07,4.725e-06, &
     & 2.071e-05,6.063e-05,1.574e-04,3.879e-04,8.413e-04,1.719e-03, &
     & 2.968e-03,4.783e-03,7.230e-03,1.045e-02,1.519e-02,2.140e-02, &
     & 2.962e-02, &
     & 0.000e+00,0.000e+00,0.000e+00,0.000e+00,3.125e-10,3.563e-08, &
     & 1.459e-07,4.406e-07,1.066e-06,2.516e-06,5.706e-06,1.075e-05, &
     & 1.748e-05,2.754e-05,4.141e-05,5.808e-05,8.307e-05,1.204e-04, &
     & 1.526e-04/
      data ( (coefk(3,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 0.00010,0.00012,0.00032,0.00085,0.00193,0.00458, &
     & 0.01031,0.02119,0.04015,0.06639,0.10163,0.14948, &
     & 0.21695,0.30768,0.42844,0.59514,0.84740,1.17004, &
     & 1.48726, &
     & 6.413e-06,7.337e-06,1.126e-05,2.530e-05,5.484e-05,1.101e-04, &
     & 2.316e-04,4.420e-04,7.960e-04,1.290e-03,1.956e-03,2.831e-03, &
     & 4.046e-03,5.697e-03,7.895e-03,1.074e-02,1.516e-02,2.099e-02, &
     & 2.736e-02, &
     & 1.053e-07,1.197e-07,1.322e-07,2.650e-07,5.916e-07,1.016e-06, &
     & 1.897e-06,3.206e-06,5.294e-06,8.391e-06,1.266e-05,1.748e-05, &
     & 2.388e-05,3.295e-05,4.598e-05,5.965e-05,7.798e-05,1.001e-04, &
     & 1.449e-04/
      data ( (coefk(4,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 0.02081,0.02124,0.02440,0.03128,0.03987,0.05173, &
     & 0.06697,0.08747,0.11456,0.15100,0.20218,0.27745, &
     & 0.38290,0.51788,0.65919,0.78981,0.93236,1.06208, &
     & 1.13645, &
     & 6.691e-04,6.936e-04,7.050e-04,8.089e-04,9.665e-04,1.168e-03, &
     & 1.433e-03,1.786e-03,2.247e-03,2.882e-03,3.805e-03,5.040e-03, &
     & 6.803e-03,9.243e-03,1.208e-02,1.451e-02,1.720e-02,1.948e-02, &
     & 2.062e-02, &
     & 7.641e-06,8.097e-06,7.569e-06,7.547e-06,8.419e-06,9.331e-06, &
     & 1.065e-05,1.229e-05,1.459e-05,1.789e-05,2.317e-05,2.783e-05, &
     & 3.367e-05,4.389e-05,6.509e-05,7.864e-05,9.405e-05,1.047e-04, &
     & 9.958e-05/
      data ( (coefk(5,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 1.76643,1.76732,1.77176,1.77534,1.78324,1.79220, &
     & 1.80674,1.82530,1.84127,1.84779,1.83103,1.77690, &
     & 1.69182,1.57332,1.43992,1.27381,1.10369,0.89454, &
     & 0.69900, &
     & 3.494e-02,3.492e-02,3.490e-02,3.487e-02,3.489e-02,3.491e-02, &
     & 3.488e-02,3.491e-02,3.484e-02,3.469e-02,3.423e-02,3.325e-02, &
     & 3.176e-02,2.964e-02,2.708e-02,2.392e-02,2.113e-02,1.741e-02, &
     & 1.365e-02, &
     & 1.993e-04,1.990e-04,1.970e-04,1.965e-04,1.955e-04,1.953e-04, &
     & 1.920e-04,1.894e-04,1.848e-04,1.809e-04,1.761e-04,1.714e-04, &
     & 1.643e-04,1.556e-04,1.381e-04,1.207e-04,1.094e-04,9.372e-05, &
     & 7.355e-05/

		call apply_ckd(ni, k, u, f, p, t, tau, coefk, .false.)

      end subroutine ck_29
!  *********************************************************************
      subroutine window_29 (amnt,twin,patm,temp,fac)
!      Parameterization of CKD_2.4 continuum over 1140 to 1200 cm-1 band
!      Fit inaccurate for amnt < 0.01 g/cm*2;
!           however optical depths < 0.001.
!      INPUT:
!      amnt = h2O layer amount (g/cm**2)
!      patm= pressure (atm)
!      temp = temperature (k)
!      OUTPUT:
!      twin = parameterized CKD_2.4 optical depth over band
!
	  real, intent(in) :: amnt, patm, temp, fac
	  real, intent(inout) :: twin

      integer, parameter :: ncoef=7

      real ::  aa(ncoef), ph2o, tau_log
!
      data aa/7.487,1.001,-0.02105,0.02266,-0.4916,-4.798e-04,0.9770/
!
      ph2o = amnt*(8.314e+07*temp)/(fac*1.0e+05*18.01534*1.01325e+06)
!
          tau_log   = aa(1)              + &
     &                 aa(2) * log(amnt)  + &
     &                 aa(3) * temp       + &
     &                 aa(4) * patm       + &
     &                 aa(5) * ph2o       + &
     &                 aa(6) * amnt       + &
     &                 aa(7) * log(ph2o)

        twin = exp ( tau_log )
!

        end subroutine window_29
!  *********************************************************************
!      o3 1140--1200 cm^{-1}
      subroutine cko3_29(u,f,p,t,tau)
		real, dimension(:), intent(in) :: p, t, u

		real, dimension(:), intent(inout) :: f
		real, dimension(:,:), intent(inout) :: tau

		integer, parameter :: mlv = max_layers
		integer :: m

		real :: k(no3)

      f(1)=1.00000
      do m=1,mlv
          k(1)=15.60821*(1.0000+4.6204e-03*(t(m)-250.0)+ &
     &          8.7844e-06*(t(m)-250.0)**2)
          tau(1,m)=k(1)*u(m)
      end do
	 end subroutine cko3_29
!  *********************************************************************
!      ch4 1140--1200 cm^{-1}
      subroutine ckch4_29(u,f,p,t,tau)
		real, dimension(:), intent(in) :: p, t, u

		real, dimension(:), intent(inout) :: f
		real, dimension(:,:), intent(inout) :: tau

		integer, parameter :: mlv = max_layers
		integer :: m

		real :: k(nch4)
      f(1)=1.00000
      do m=1,mlv
          k(1)=3.44205*(1.0000+1.8357e-02*(t(m)-250.0)+ &
     &          1.4238e-04*(t(m)-250.0)**2)
          tau(1,m)=k(1)*u(m)
      end do
	end subroutine ckch4_29
!  *********************************************************************
!      n2o 1140--1200 cm^{-1}
      subroutine ckn2o_29(u,f,p,t,tau)
		real, dimension(:), intent(in) :: p, t, u

		real, dimension(:), intent(inout) :: f
		real, dimension(:,:), intent(inout) :: tau

		integer, parameter :: mlv = max_layers
		integer :: m

		real :: k(nn2o)
		real :: coefk(nn2o,3,num_pressures)
		integer :: i, jp, jt
      f(1)=0.819050
      f(2)=0.180950
      k(1)=24.4321126
      do i=2,nn2o
        k(i)=11.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 0.00000,0.00000,0.00010,0.00049,0.00167,0.00505, &
     & 0.01137,0.02124,0.03650,0.05920,0.09294,0.14144, &
     & 0.20923,0.30905,0.45202,0.63756,0.86176,1.17401, &
     & 1.53221, &
     & 0.000e+00,0.000e+00,4.625e-07,2.713e-06,1.113e-05,2.500e-05, &
     & 4.000e-05,6.125e-05,9.650e-05,1.523e-04,2.298e-04,3.539e-04, &
     & 4.795e-04,6.371e-04,9.179e-04,1.314e-03,1.267e-03,1.004e-03, &
     & 1.089e-03, &
     & 0.000e+00,0.000e+00,-3.125e-10,-7.812e-09,-3.125e-09,-1.250e-08, &
     & -2.910e-13,4.375e-08,6.250e-08,1.250e-07,1.812e-07,4.344e-07, &
     & 1.725e-06,1.959e-06,9.281e-07,2.384e-06,1.004e-05,8.034e-06, &
     & 6.109e-06/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     & 1.52647,1.52490,1.52238,1.51850,1.51379,1.50365, &
     & 1.48864,1.46990,1.44604,1.41986,1.39347,1.36856, &
     & 1.33966,1.29786,1.23922,1.16373,1.06093,0.94282, &
     & 0.79944, &
     & 6.396e-04,6.494e-04,6.670e-04,6.926e-04,7.307e-04,7.821e-04, &
     & 8.535e-04,9.373e-04,1.033e-03,1.082e-03,1.056e-03,9.970e-04, &
     & 9.186e-04,8.666e-04,7.456e-04,5.936e-04,5.576e-04,7.041e-04, &
     & 7.050e-04, &
     & 5.103e-06,4.909e-06,4.875e-06,4.672e-06,4.537e-06,4.316e-06, &
     & 4.006e-06,3.675e-06,3.947e-06,3.956e-06,4.153e-06,3.431e-06, &
     & 3.003e-06,3.334e-06,3.466e-06,2.672e-06,-4.719e-07,-2.406e-07, &
     & 9.312e-07/
		call apply_ckd(nn2o, k, u, f, p, t, tau, coefk, .false.)

      end subroutine ckn2o_29

end module modis29

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
C
C
*+ do_age_B_const

       subroutine do_age_B_const(map_array,status)
C      -------------------------------------------
C
C Calculate a map of synchrotron age assuming a constant B field
C
C Given:
C   map data
      real*4      map_array(*)
C Returned:
C   status
      integer     status
C
C A map of spectral-age is calculated from a map of break frequency
C assuming a constrant magnetic field in space and time within the
C emitting region.
C-

C Assumed B-field
       real*4     B_field
C input map and pointer
       integer    imap, ip_map
C output map and pointer
       integer    iwork, ip_work
C blank value on input map
       real*4     blank
C map range
       integer    minirt(10)
C pointers and counters
       integer    i
C local function
       real*4     synch_age

C check status on entry
       if (status.ne.0) return

C read input map and data
       call map_getmap('Break-frequency-map : ','Default-Map','READ',
     *                 imap,status)
       call ennull(blank,status)
       call io_getr('B-field (nT) : ','1.0',B_field,status)

C find output map
       call map_alloc_out(0,0,'DIRECT',iwork,ip_work,status)

C read pointer to input map
       call map_alloc_in(imap,'DIRECT',map_array,ip_map,status)

C read the UV range on which to work
       call enminirt(minirt,status)

C check status at this stage
       if (status.ne.0) goto 999

C do the calculation
       do i = 1,minirt(5)*minirt(6)
         if (map_array(ip_map+i-1).ne.blank) then
           map_array(ip_work+i-1) =
     *              synch_age(map_array(ip_map+i-1),B_field)
         else
           map_array(ip_work+i-1) = blank
         end if
       end do

C update the text of the redtape
       call adredt('created','AGE-MAP',status)
       call stnull(blank,status)

C tidy up, make output map new current map etc.
999    call map_end_alloc(imap,map_array,status)
       call map_end_alloc(iwork,map_array,status)

C check status value
       call iocmd_err(status,'AGE-MAP',' ')

       end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
      SUBROUTINE CONVOL(ITYPE,BUFIN,NSAMPS,FILTER,NFPTS,OBUF,NOUT)
!     CONVOL PERFORMS TIME DOMAIN CONVOLUTION AND CORRELATION BETWEEN ARRAYS
! BUFIN AND FILTER.  THE OUTPUT IS RETURNED IN OBUF AND IS  VARIABLE IN LENGTH
! DEPENDING ON THE TYPE OF OPERATION REQUESTED.
!
! ARGUMENTS:
!        ITYPE  - TYPE OF CONVOLUTION OR CORRRELATION DESIGNATOR.
!               =-2,  PARTIAL CONVOLUTION.  THIS TYPE IS DESIGNED FOR ZERO PHASE
!                     FILTERING WHERE NEGATIVE TIME AFTER FILTERING IS NOT WANTED
!                     THIS ASSUMES THAT THE FIRST TIME OF THE DATA IS 0 AND THE
!                     FILTER IS SYMMETRICAL.
!               =-1,  FULL CONVOLUTION.  THE TIME REFERENCE OF THE FIRST OUTPUT
!                     POINT IS T1+T2, WHERE T1 IS THE TIME OF THE FIRST SAMPLE
!                     IN BUFIN AND T2 IS THE TIME OF THE FIRST SAMPLE IN ARRAY
!                     FILTER.  E.G.  IF A ZERO PHASE FILTER HAS TIME POINTS -19
!                     TO +19 AND THE FIRST SAMPLE IN BUFIN IS AT TIME 0, THEN
!                     THE TIME OF THE FIRST OUTPUT SAMPLE IS -19.
!               =+1,  FULL CORRELATION.  BOTH POSITIVE AND NEGATIVE LAGS ARE
!                     COMPUTED.  CORRELATIONS ARE EVEN FUNCTIONS, THEREFORE HALF
!                     CORRELATIONS GIVE THE SAME INFORMATION AND SHOULD BE USED
!                     MOST OF THE TIME.
!               =+2,  HALF CORRELATION.  ONLY THE RIGHT HALF OF THE CORRELATION
!                     IS PERFORMED.  THIS TYPE IS DESIGNED FOR VIBROSEIS
!                     DESWEEPING WHERE A FULL CORRELATION WOULD BE A TOTAL
!                     WASTE OF TIME!!!
!        BUFIN  - INPUT ARRAY TO BE FILTERED (CONVOLVED) OR CORRELATED.
!        NSAMPS - THE NUMBER OF SAMPLES IN BUFIN TO FILTER.
!        FILTER - AN ARRAY OF REAL FILTER WEIGHTS.  AN ARRAY OF VALUES TO BE
!                 CORRELATED.
!        NFPTS  - THE NUMBER OF FILTER POINTS IN THE FILTER ARRAY.
!        OBUF   - THE OUTPUT ARRAY.
!        NOUT   - THE NUMBER OF OUTPUT SAMPLES TO GENERATE.  FOR CONVOLUTION
!                 THIS SHOULD NORMALLY BE MSAMPS+MPTS.  FOR CORRELATION THIS IS
!                 THE NUMBER OF LAGS TO OUTPUT, IT MIGHT BE  MIN0(MSAMPS,MPTS).
!
!   NOTE:  LEADING AND TRAILING ZEROES DO NOT HAVE TO BE GIVEN.
!
!   COPYRIGHTED BY:
!       PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, FEBRUARY 1979
!       REWRITTEN IN NOVEMBER 1979 FOR THE FPS AP.
!
      DIMENSION BUFIN(1),FILTER(1),OBUF(1)
      COMMON /SIOAP/ IASGND,IRELSE,IN,IOUT,NEXTAD,LAPSIZ,IFREE
!           IASGND - AP ASSIGNMENT SWITCH
!                  =0,  AP IS NOT ASSIGNED - CALL APINIT
!                  =1,  AP IS ASSIGNED - DO NOT CALL APINIT
!          IRELSE - AP RELEASE SWITCH
!                 =0,  AP SHOULD BE RELEASED BEFORE RETURNING
!                 =1,  AP SHOULD BE LEFT ASSIGNED
!          IN     - A SWITCH INDICATING WHETHER THE DATA IS ALREDY IN THE AP
!                 =0,  THE DATA IS NOT IN THE AP.
!                 =1,  THE DATA IS IN THE AP AT ADDRESS IN
!          IOUT   - A SWITCH INDICATING WHETHER THE DATA SHOULD BE LEFT IN THE AP
!                 =0,  THE DATA SHOULD BE MOVED BACK TO THE HOST
!                 =1,  THE DATA CAN BE LEFT IN THE AP WITHOUT AN APGET
!****
!****
!****
      IPAD1=IN                                                         ! SET UP THE ADDRESS OF THE INPUT DATA IN THE AP
      IF(IN.EQ.0) IPAD1=1
      ITEMP=ITYPE+3
      GO TO (110,120,120,120,130), ITEMP
  110 NZEROS=NFPTS/2                                                   !  PARTIAL CONVOLUTION
  111 IDATA=NZEROS+IPAD1                                               !  THE ADDRESS OF THE DATA IN THE AP
      IPAD2=IDATA+NSAMPS                                               !  THE ADDRESS OF THE BACK END PAD
      IAPFLT=IPAD2+NZEROS                                              !  THE ADDRESS OF THE FILTER IN THE AP
      CALL VMOV(IN+NSAMPS-1,-1,IDATA+NSAMPS-1,-1,nsamps)               ! MOVE THE DATA FOR  PAD
      CALL VCLR(IPAD1,1,NZEROS)                                        ! CREATE THE PAD
      GO TO 180
  120 NZEROS=NFPTS-1                                                   !  FULL CONVOLUTION AND CORRELATION
      GO TO 111
  130 NZEROS=NFPTS-1                                                   !  HALF CORRELATION
      IDATA=IPAD1                                                      !  DON'T NEED A FRONT END PAD
      IPAD2=IDATA+NSAMPS                                               !  ADDRESS OF THE BACKEND PAD
      IAPFLT=IPAD2+NZEROS                                              !  ADDRESS OF THE FILTER IN THE AP
  180 CALL VCLR(IPAD2,1,NZEROS)                                        ! START THE BACK END PAD
      CALL APPUT(FILTER,IAPFLT,NFPTS,2)                                !  START THE FILTER INTO THE AP
      INC=1                                                            ! THE DATA INCREMENT FOR CORRELATION
      IADDR=IAPFLT                                                     ! THE DATA ADRESS FOR CORRELATION
      IF(ITYPE.GE.0) GO TO 200
      INC=-1                                                           ! THE INC FOR CONVOLUTION
      IADDR=IAPFLT+NFPTS-1
  200 CONTINUE
      CALL APWAIT                                                      ! WAIT FOR THE DATA TRANSFERS AND CLEARING TO FINISH
      CALL CONV(IPAD1,1,IADDR,INC,IPAD1,1,NOUT,NFPTS)
      IN=IPAD1
      RETURN
      END


text:
!==============================================================================!
  subroutine Control_Mod_Starting_Time_Step_For_Statistics(val, verbose)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  integer           :: val
  logical, optional :: verbose
!==============================================================================!

  call Control_Mod_Read_Int_Item('STARTING_TIME_STEP_FOR_STATISTICS',  &
                                 HUGE_INT, val, verbose)

  end subroutine

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:22 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE TSTEPO_FLUX_T__genmod
          INTERFACE
            SUBROUTINE TSTEPO_FLUX_T(TS_,TS1_,RHO_)
              REAL(KIND=8) :: TS_(14,0:37,0:37,0:33)
              REAL(KIND=8) :: TS1_(14,0:37,0:37,0:33)
              REAL(KIND=8) :: RHO_(0:37,0:37,0:32)
            END SUBROUTINE TSTEPO_FLUX_T
          END INTERFACE
        END MODULE TSTEPO_FLUX_T__genmod


! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

  type dt
    integer :: x = 0
  end type
  type (dt) :: t
  integer :: i, j, k, l, r, s, a(30)
  integer, target :: q(30)
  integer, pointer :: p(:)
  !$omp declare reduction (foo : integer : &
  !$omp & omp_out = omp_out + omp_in) initializer (omp_priv = 0)
  !$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
  !$omp & + omp_in%x)
  a(:) = 1
  q(:) = 1
  p => q
  r = 0
  j = 10
  k = 20
  s = 0
  !$omp simd safelen (8) reduction(+:r, t) linear(j, k : 2) &
  !$omp& private (l) aligned(p : 4) reduction(foo:s)
  do i = 1, 30
    l = j + k + a(i) + p(i)
    r = r + l
    j = j + 2
    k = k + 2
    s = s + l
    t%x = t%x + l
  end do
  if (r.ne.2700.or.j.ne.70.or.k.ne.80.or.s.ne.2700) call abort
  if (t%x.ne.2700) call abort
end


text:
	SUBROUTINE GPTOPT ( device, txtfil, txtloc, panel, column,
     +			    clear, iret )
C************************************************************************
C* GPTOPT								*
C*									*
C* This subroutine displays a summary of the users options.		*
C*									*
C* GPTOPT ( DEVICE, TXTFIL, TXTLOC, PANEL, COLUMN, CLEAR, IRET )	*
C*									*
C* Input Parameters:							*
C*	DEVICE		CHAR*		Device				*
C*	TXTFIL		CHAR*		Text file			*
C*	TXTLOC		CHAR*		Text location in Normal coords	*
C*	PANEL		CHAR*		Panel input			*
C*	COLUMN		CHAR*		Number of columns		*
C*	CLEAR		LOGICAL		Clear option flag		*
C*									*
C* Output Parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = exit			*
C**									*
C* Log:									*
C* T. Lee/GSC		10/97						*
C* S. Jacobs/NCEP	10/97	Removed TITLE; Added TXTLOC		*
C* I. Durham/GSC	01/98	Added COLUMN				*
C************************************************************************
	CHARACTER*(*)	device, txtfil, txtloc, panel, column
	LOGICAL		clear
C*
	LOGICAL		respnd
	CHARACTER	clr*3
C*
C------------------------------------------------------------------------
C*
	iret = 0
	IF  ( clear )  THEN
	    clr = 'YES'
	ELSE
	    clr = 'NO'
        END IF
	WRITE ( 6, 5000) device, txtfil, txtloc, panel, column, clr
C*
	CALL IP_RESP ( respnd, ier )
	IF  ( respnd ) THEN
	    CALL TM_ACCP ( ier )
	    IF ( ier .eq. 2 ) iret = -1
	END IF
C*
5000	FORMAT ( ' GPTEXT PARAMETERS:',//
     +           ' Device:        ', A,/
     +           ' Text file:     ', A,/
     +           ' Text location: ', A,/
     +           ' Panel:         ', A,/
     +           ' Num Columns    ', A,/
     +           ' Clear:         ', A )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
********************************************************************
      SUBROUTINE initw(w,ndim,nf)
      implicit none
*     IMPORT/EXPORT
      integer  ndim,nf
      real     w(ndim,nf)
*     LOCAL
      integer  i,l
*     FUNCTIONS
      real    g05caf
      real    rand
*
      DO i=1,ndim
       DO l=1,nf
!        w(i,l) = g05caf()
 !        w(i,l) = rand()
       ENDDO
      ENDDO
*
      END
*****************************************************************************
      real FUNCTION l2nrm(f,ndim)
      implicit none
      integer i,ndim
      real    f(ndim),nrm
*
      nrm = 0.0
      DO i=1,ndim
       nrm = f(i)*f(i) + nrm
      ENDDO
      l2nrm = sqrt(nrm)
*
      END
*****************************************************************************
      real FUNCTION linrm(f,ndim)
      implicit none
      integer i,ndim
      real    f(ndim),nrm
*
      nrm = 0.0
      DO i=1,ndim
       IF ( abs(f(i)).GT.nrm ) nrm = abs(f(i))
      ENDDO
      linrm = nrm
*
      END
****************************************
      subroutine findex(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer row, i, j, k, XX
      IF (prec.eq.1) THEN
         call findex_interleaved_ordering(row,i,j,k,XX)
      ELSE
         call findex_block_ordering(row,i,j,k,XX)
      END IF
      end subroutine findex

****************************************
      subroutine findex_block_ordering(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer t, r, XX, row, i, j, k, nn
      nn = n*m*(l+la)
      if (row.LE.2*nn) then
         XX = 2 - mod(row,2) ! UU or VV
         r = (row + 2 - XX)/2
      elseif (row.LE.3*nn) then
         XX = WW
         r = mod(row-1,nn)+1
      elseif (row.LE.4*nn) then
         XX = PP
         r = mod(row-1,nn)+1
      elseif (row.LE.6*nn) then
         XX = 6 - mod(row,2) ! TT or SS
         r = (mod(row-1,2*nn)+1 +6 - XX)/2
      else
         STOP "error in findex (matetc.f): row > ndim "
      end if
      k = int((r-1)/(n*m))+1
      r = mod(r-1,n*m)+1
      j = int((r-1)/n)+1
      i = mod(r-1,n)+1
      end subroutine findex_block_ordering

****************************************
      subroutine findex_interleaved_ordering(row,i,j,k,XX)
      ! find variable XX and grid point (i,j,k) that
      ! correspond to row 'row' in matrix A
      implicit none
      include 'usr.com'
      integer t, r, XX, row, i, j, k

      XX = mod(row - 1, nun) + 1
      r = (row - XX)/nun
      t = mod(r, n*m)
      k = (r - t)/(n*m) + 1
      i = mod(t, n) + 1
      j = (t - i + 1)/n + 1
      end subroutine findex_interleaved_ordering

****************************************
      integer function find_row(i,j,k)
      implicit none
      include 'par.com'
      integer i,j,k
      find_row = nun*((k-1)*n*m+ n*(j-1) + i-1)
      WRITE(99,*) "use of find_row is prohibited, use find_row2 instead"
      STOP
      end function find_row

****************************************
      integer function find_row2(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
!      include 'par.com'
      include 'usr.com'
      integer i,j,k,XX
!     functions
      integer find_row_interleaved_ordering, find_row_block_ordering
      IF (prec.eq.1) THEN
         find_row2 = find_row_interleaved_ordering(i,j,k,XX)
      ELSE
         find_row2 = find_row_block_ordering(i,j,k,XX)
      END IF
      end function find_row2

****************************************
      integer function find_row_block_ordering(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
      include 'usr.com'
      integer i,j,k,XX
      select case (XX)
      case (UU:VV)
         find_row_block_ordering = 2*((k-1)*n*m + (j-1)*n + i-1) + XX
      case (WW)
         find_row_block_ordering = (k-1)*n*m + (j-1)*n + i + (WW-1)*n*m*(l+la)
      case (PP)
         find_row_block_ordering = (k-1)*n*m + (j-1)*n + i + (PP-1)*n*m*(l+la)
      case (TT:SS)
         find_row_block_ordering = 2*((k-1)*n*m + (j-1)*n + i-1) +(TT-1)*n*m*(l+la)+(XX-4)
      case default
         find_row_block_ordering = -1
      end select
      ! check dimensions
      if ((i>n).or.(i<1).or.(j>m).or.(j<1).or.(k>l+la).or.(k<1)) then
         find_row_block_ordering = -1
      end if
      end function find_row_block_ordering

****************************************
      integer function find_row_interleaved_ordering(i,j,k,XX)
      ! find row in matrix A of variable XX at grid point (i,j,k)
      implicit none
      include 'usr.com'
      integer i,j,k,XX
      find_row_interleaved_ordering = nun*((k-1)*n*m+ n*(j-1) + i-1)+XX
      ! check dimensions
      if ((i>n).or.(i<1).or.(j>m).or.(j<1).or.(k>l+la).or.(k<1)) then
         find_row_interleaved_ordering = -1
      end if
      end function find_row_interleaved_ordering

*******************************************************************************
      SUBROUTINE matAvec(v1,v2)
*     This multiplies sparse matrix A and vector v1 to vector v2
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
      real     v1(ndim),v2(ndim)
*     LOCAL
      integer  i,v
*
      v2 = 0.0
      DO i = 1,ndim
       DO v = begA(i),begA(i+1)-1
         v2(i) = coA(v)*v1(jcoA(v)) + v2(i)
       ENDDO
      ENDDO
*
      END
*******************************************************************************
      SUBROUTINE matBvec(v1,v2)
*     This multiplies sparse matrix B and vector v1 to vector v2
*     B is a diagonal matrix
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
      real     v1(ndim),v2(ndim)
*     LOCAL
      integer  i
*
      DO i = 1,ndim
       v2(i) = coB(i)*v1(i)
      ENDDO
*
      END
************************************************************************
      SUBROUTINE writematrhs(rl)
*     write the matrix A + rhs to a file
      USE m_mat
      implicit none
      include 'par.com'
!      include 'mat.com'
*     INPUT/OUTPUT
      real     rl(ndim)
*     LOCAL
      integer i
*
      open( 9,file='B.co')
      open(10,file='A.info')
      open(11,file='A.beg')
      open(12,file='A.jco')
      open(13,file='A.co')
      open(14,file='A.rl')
      write(10,*) ndim,begA(ndim+1)-1
      DO i=1,ndim+1
        write(11,*) begA(i)
      ENDDO
      DO i=1,begA(ndim+1)-1
        write(12,*) jcoA(i)
      ENDDO
      DO i=1,begA(ndim+1)-1
        write(13,*) coA(i)
      ENDDO
      DO i=1,ndim
        write( 9,*) coB(i)
        write(14,*) rl(i)
      ENDDO
      close( 9)
      close(10)
      close(11)
      close(12)
      close(13)
      close(14)
*     STOP
*
      END
*******************************************************
      subroutine writevector(ndim,x)
      implicit none
      integer ndim, i
      real x(1)
      open(10,file='A.sol', status='UNKNOWN')
*      print*, 'Vector'
      do i = 1, ndim
         write(10,*) x(i)
*         print '(A,I4,A,G10.10)', '[', i, '] = ', x(i)
      enddo
      close(10)
*      stop
      end
********************************************************
      subroutine writevectori(ndim,x)
      implicit none
      integer ndim, i
      integer x(1)
*      open(10,file='A.sol', status='UNKNOWN')
      print*, 'Vector'
      do i = 1, ndim
*         write(10,*) x(i)
         print '(A,I4,A,I8)', '[', i, '] = ', x(i)
      enddo
      close(10)
      end
********************************************************
      subroutine printmat( a, n)
      integer n, i, j
      real a(n,n)
      write(*,*) ' '
      do i = 1, n
         write(*,'(10(f10.4,x))') (a(i,j), j = 1, n)
      enddo
      write(*,*) ' '
      end

max_stars_repo_name: Sbte/i-emic

max_issues_repo_name: Sbte/i-emic

max_forks_repo_name: nlesc-smcm/i-emic


text:
!-- gdCommon.f90
!-- 4 Mar 92, Richard Maine: Version 1.0.

module gd_common

  !-- Utility module for use in gd_read.
  !-- Provides functionality common to several gd_read submodules.
  !-- Routines, data, and types to manage the list of signals
  !-- and data sources.
  !-- 19 Oct 91, Richard Maine.

  use precision
  use sysdep_io
  use string
  use gd_tree

  implicit none
  private

  integer, public, parameter :: signal_name_len = 16

  integer, public, parameter :: no_source_code = 0
  integer, public, parameter :: file_source_code = 1
  integer, public, parameter :: filter_source_code = 2
  integer, public, parameter :: calc_source_code = 3

  !-- gd_source_type has generic information about a data source.
  !-- This is accessible outside of gd_read.
  type, public :: gd_source_type
    integer :: source_code
         !-- An integer code for the source type.
    integer :: source_number
         !-- The source number.  A single numbering sequence is
         !-- currently shared by all source codes.
    character*(file_name_len) :: source_name
         !-- Source name.  Often a file name.
    character*80 :: source_description
         !-- One-line description of the source.
    real(r_kind) :: source_dt
         !-- Nominal source sample interval.  0 if unknown or undefined.
         !-- Value for files reflects any file thinning.
    integer :: n_source_signals
         !-- Number of signals available from this source.
         !-- Note there may be more signals defined than are available.
         !-- This total includes only the available signals.
    integer :: source_signal_offset
         !-- Offset in the gd signal list of the signals from this source.
  end type

  !-- gd_signal_type has information about a get_data signal.
  type, public :: gd_signal_type
    integer :: signal_number  !-- Signal number in the get_data list.
    character*(signal_name_len) :: signal_name
         !-- Unique signal name.
    integer :: source_number
         !-- The source number for this signal.
         !-- For filter signals, this is the number of the associated file,
         !-- because that's what we always seem to need.
         !-- If we ever need the filter source number as distinct from
         !-- the file source number, we'll need a change.
    integer :: source_code
         !-- An integer code for the source type.
    integer :: source_signal_number
         !-- Index in the list of signals from this source.
         !-- For filter signals, refers to the associated file signal list,
         !-- rather than the filter signal list.
    real(r_kind) :: skew, adjusted_skew
         !-- Time skew for this signal.  Irrelevant for calc signals.
         !-- For hold-last-value signals, the adjusted skew includes
         !-- both the given skew plus an allowance for the time tolerance;
         !-- for other signals it is the same as the skew.
    logical :: interpolate
         !-- False means hold last value.  Irrelevant for calc signals.
    logical :: used
         !-- Is this signal used?
    logical :: synced
         !-- Does this signal need to be synced?
         !-- A filter input may be used without needing to be synced.
    real(r_kind) :: data
         !-- Signal data value.
  end type

  type signal_ptr_type
    type(gd_signal_type), pointer :: gd_signal
  end type

  type signal_list_node_type
    type(gd_signal_type) :: signal
    type(signal_list_node_type), pointer :: prev_node
  end type

  type, public :: gd_signal_list_type
    private
    integer :: n_signals
    type(tree_type) :: tree
    type(signal_list_node_type), pointer :: last_node
  end type

  type gd_source_list_node_type
    type(gd_source_type) :: source
    type(gd_source_list_node_type), pointer :: prev_node
  end type

  type, public :: gd_source_list_type
    private
    integer :: n_sources
    type(gd_source_list_node_type), pointer :: last_node
  end type

  !-- This dummy entry is returned when searches fail.
  type(gd_signal_type), target, save :: no_signal

  !-- Public procedures.
  public init_signal_list, release_signal_list, add_gd_signal
  public find_gd_signal, get_signal_array, get_signal_names, signal_list_size
  public init_source_list, release_source_list
  public add_gd_source, get_source_array, source_list_size

contains

  subroutine init_signal_list (signal_list)

    !-- Initialize an empty signal list.
    !-- 19 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(out) :: signal_list

    !-------------------- executable code.

    no_signal%signal_number = 0
    no_signal%signal_name = ''
    no_signal%source_number = 0
    no_signal%source_code = no_source_code
    no_signal%source_signal_number = 0
    no_signal%skew = 0.
    no_signal%adjusted_skew = 0.
    no_signal%interpolate = .false.
    no_signal%used = .false.
    no_signal%synced = .false.
    no_signal%data = 0.

    signal_list%n_signals = 0
    call initialize_tree(signal_list%tree)
    nullify(signal_list%last_node)
    return
  end subroutine init_signal_list

  subroutine release_signal_list (signal_list)

    !-- Release space in the signal list.
    !-- 19 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(inout) :: signal_list

    !-------------------- local.
    type(signal_list_node_type), pointer :: node

    !-------------------- executable code.

    do while(associated(signal_list%last_node))
      node => signal_list%last_node
      signal_list%last_node => node%prev_node
      deallocate(node)
    end do
    call deallocate_tree(signal_list%tree)
    return
  end subroutine release_signal_list

  function signal_list_size (signal_list)

    !-- Return the number of signals in a list.
    !-- 1 Sep 92, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(in) :: signal_list
         !-- The list of get_data signal records.
    integer :: signal_list_size  !-- Number of signals in the list.

    !-------------------- executable code.

    signal_list_size = signal_list%n_signals
    return
  end function signal_list_size

  subroutine add_gd_signal (signal_list, signal_name, source, gd_signal, &
    source_name, error)

    !-- Add a new name to the get_data signal list.
    !-- Modify the name to be unique if needed.
    !-- If this routine fails (presumably by running out of memory)
    !-- then the signal list will likely be left with spurious
    !-- nodes for the preceding signals of the same source.
    !-- We probably ought to either figure out how to delete the
    !-- spurious nodes or declare the gd_read connection unuseable.
    !-- However, odds are that things will bomb later in any case
    !-- if we are that short on memory.
    !-- 19 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(inout) :: signal_list
         !-- The list of get_data signal records.
    character*(*), intent(in) :: signal_name
         !-- Name of the new signal to be added.
    type(gd_source_type), intent(inout) :: source
         !-- Source record for the source of this signal.
    type(gd_signal_type), pointer :: gd_signal
         !-- Record of information about the signal.  Intent(out)
         !-- Default values will be filled in on exit.
    character*(*), intent(in) :: source_name
         !-- Name of the source.  Used in messages.
    logical, intent(out) :: error

    !-------------------- local.
    logical :: dup
    integer :: number, iostat
    character, parameter :: sharp = '#'
    character :: new_name*(signal_name_len)
    integer, pointer :: int_array(:)
    type(signal_ptr_type) :: signal_ptr
    type(signal_list_node_type), pointer :: signal_list_node

    !-------------------- executable code.

    nullify(signal_list_node)
    allocate(signal_list_node, stat=iostat)
    if (iostat /= 0) goto 8000

    gd_signal => signal_list_node%signal
    signal_ptr%gd_signal => gd_signal

    !-- Try to add the name as is (unless it is blank).
    dup = signal_name == ''
    if (.not. dup) then
      call add_tree_data(signal_name, transfer(signal_ptr,int_array), &
           signal_list%tree, dup, error)
      if (error) goto 8000
    end if

    !-- Generate a new name to avoid duplication.
    new_name = signal_name
    number = 1
    loop: do while(dup)
      number = number + 1
      new_name = sharp // trim(adjustl(int_string(number))) // sharp // &
           signal_name
      call add_tree_data(new_name, transfer(signal_ptr,int_array), &
           signal_list%tree, dup, error)
      if (error) goto 8000
      if (.not. dup) call write_error_msg('Duplicate name ' // signal_name // &
         ' from ' // source_name // ' changed to ' // new_name)
    end do loop

    !-- Add to linked list of signals and to source signal count.
    if (source%n_source_signals == 0) &
         source%source_signal_offset = signal_list%n_signals
    source%n_source_signals = source%n_source_signals + 1
    signal_list%n_signals = signal_list%n_signals + 1
    signal_list_node%prev_node => signal_list%last_node
    signal_list%last_node => signal_list_node

    gd_signal%signal_name = new_name
    gd_signal%signal_number = signal_list%n_signals
    gd_signal%source_number = source%source_number
    gd_signal%source_code = source%source_code
    gd_signal%source_signal_number = source%n_source_signals
    gd_signal%skew = 0.
    gd_signal%adjusted_skew = 0.
    gd_signal%interpolate = .false.
    gd_signal%used = .false.
    gd_signal%synced = .false.
    gd_signal%data = 0.
    error = .false.
    return

    !-- Error exit.
    8000 continue
    if (associated(signal_list_node)) deallocate(signal_list_node)
    error = .true.
    return
  end subroutine add_gd_signal

  subroutine find_gd_signal (signal_name, signal_list, gd_signal)

    !-- Find a get_data signal record by name.
    !-- 22 Oct 91, Richard Maine.

    !-------------------- interface.
    character*(*), intent(in) :: signal_name  !-- name of the signal sought.
    type(gd_signal_list_type), intent(in) :: signal_list
         !-- List of signal records to search.
    type(gd_signal_type), pointer :: gd_signal
         !-- Record of data about the specified signal.
         !-- If not found, returns pointer to dummy no_signal record.

    !-------------------- local.
    integer, pointer :: int_array(:)
    type(signal_ptr_type) :: signal_ptr

    !-------------------- executable code.

    call get_tree_data(signal_name, signal_list%tree, int_array)
    if (associated(int_array)) then
      signal_ptr = transfer(int_array, signal_ptr)
      gd_signal => signal_ptr%gd_signal
    else
      gd_signal => no_signal
    end if
    return
  end subroutine find_gd_signal

  subroutine get_signal_array (signal_list, signal)

    !-- Get the get_data signal records in an array.
    !-- 22 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(in) :: signal_list
         !-- List of get_data signal records.
    type(gd_signal_type), intent(out) :: signal(0:)

    !-------------------- local.
    type(signal_list_node_type), pointer :: node

    !-------------------- executable code.

    node => signal_list%last_node
    do while (associated(node))
      signal(node%signal%signal_number) = node%signal
      node => node%prev_node
    end do
    signal(0) = no_signal
    return
  end subroutine get_signal_array

  subroutine get_signal_names (signal_list, signal_names)

    !-- Get the get_data signal names in a vector.
    !-- 22 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_signal_list_type), intent(in) :: signal_list
         !-- List of get_data signal records.
    character*(*), intent(out) :: signal_names(:)

    !-------------------- local.
    type(signal_list_node_type), pointer :: node

    !-------------------- executable code.

    node => signal_list%last_node
    do while (associated(node))
      signal_names(node%signal%signal_number) = node%signal%signal_name
      node => node%prev_node
    end do
    return
  end subroutine get_signal_names

  subroutine init_source_list (source_list)

    !-- Initialize an empty source list.
    !-- 17 Sept 92, Richard Maine.

    !-------------------- interface.
    type(gd_source_list_type), intent(out) :: source_list

    !-------------------- executable code.

    source_list%n_sources = 0
    nullify(source_list%last_node)
    return
  end subroutine init_source_list

  subroutine release_source_list (source_list)

    !-- Release space in the source list.
    !-- 17 Sept 92, Richard Maine.

    !-------------------- interface.
    type(gd_source_list_type), intent(inout) :: source_list

    !-------------------- local.
    type(gd_source_list_node_type), pointer :: node

    !-------------------- executable code.

    do while(associated(source_list%last_node))
      node => source_list%last_node
      source_list%last_node => node%prev_node
      deallocate(node)
    end do
    return
  end subroutine release_source_list

  function source_list_size (source_list)

    !-- Return the number of sources in a list.
    !-- 1 Sep 92, Richard Maine.

    !-------------------- interface.
    type(gd_source_list_type), intent(in) :: source_list
         !-- The list of get_data source records.
    integer :: source_list_size  !-- Number of sources in the list.

    !-------------------- executable code.

    source_list_size = source_list%n_sources
    return
  end function source_list_size

  subroutine add_gd_source (source_list, source_code, source_name, &
       source_description, source_dt, source, error)

    !-- Add a new entry to the get_data source list.
    !-- 17 Sept 92, Richard Maine.

    !-------------------- interface.
    type(gd_source_list_type), intent(inout) :: source_list
         !-- The list of get_data sources.
    integer, intent(in) :: source_code
         !-- Source code value for this source.
    character*(*), intent(in) :: source_name
         !-- Name of the source.
    character*(*), intent(in) :: source_description
         !-- One-line description of the source.
    real(r_kind), intent(in) :: source_dt
         !-- Nominal sample interval of the source.  (0 if not applicable).
    type(gd_source_type), pointer :: source
         !-- Record of information about the source.  Intent(out)
         !-- Default values will be filled in on exit.
    logical, intent(out) :: error

    !-------------------- local.
    integer :: iostat
    type(gd_source_list_node_type), pointer :: source_list_node

    !-------------------- executable code.

    nullify(source_list_node)
    allocate(source_list_node, stat=iostat)
    if (iostat /= 0) goto 8000

    source => source_list_node%source

    !-- Add to linked list.
    source_list_node%prev_node => source_list%last_node
    source_list%last_node => source_list_node

    source_list%n_sources = source_list%n_sources + 1

    source%source_code = source_code
    source%source_number = source_list%n_sources
    source%source_name = source_name
    source%source_description = source_description
    source%source_dt = source_dt
    source%n_source_signals = 0
    source%source_signal_offset = 0

    error = .false.
    return

    !-- Error exit.
    8000 continue
    if (associated(source_list_node)) deallocate(source_list_node)
    error = .true.
    return
  end subroutine add_gd_source

  subroutine get_source_array (source_list, source)

    !-- Get the get_data source records in an array.
    !-- 22 Oct 91, Richard Maine.

    !-------------------- interface.
    type(gd_source_list_type), intent(in) :: source_list
         !-- List of get_data source records.
    type(gd_source_type), intent(out) :: source(:)

    !-------------------- local.
    type(gd_source_list_node_type), pointer :: node

    !-------------------- executable code.

    node => source_list%last_node
    do while (associated(node))
      source(node%source%source_number) = node%source
      node => node%prev_node
    end do
    return
  end subroutine get_source_array

end module gd_common

max_stars_repo_name: brucegua/moocos

max_issues_repo_name: brucegua/moocos

max_forks_repo_name: brucegua/moocos


! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

! Check for semantic errors in ALLOCATE statements

subroutine C945_a(srca, srcb, srcc, src_complex, src_logical, &
  srca2, srcb2, srcc2, src_complex2, srcx, srcx2)
! If type-spec appears, it shall specify a type with which each
! allocate-object is type compatible.

!second part C945, specific to SOURCE, is not checked here.

  type A
    integer i
  end type

  type, extends(A) :: B
    real, allocatable :: x(:)
  end type

  type, extends(B) :: C
    character(5) s
  end type

  type Unrelated
    class(A), allocatable :: polymorph
    type(A), allocatable :: notpolymorph
  end type

  real srcx, srcx2(6)
  class(A) srca, srca2(5)
  type(B) srcb, srcb2(6)
  class(C) srcc, srcc2(7)
  complex src_complex, src_complex2(8)
  complex src_logical(5)
  real, allocatable :: x1, x2(:)
  class(A), allocatable :: aa1, aa2(:)
  class(B), pointer :: bp1, bp2(:)
  class(C), allocatable :: ca1, ca2(:)
  class(*), pointer :: up1, up2(:)
  type(A), allocatable :: npaa1, npaa2(:)
  type(B), pointer :: npbp1, npbp2(:)
  type(C), allocatable :: npca1, npca2(:)
  class(Unrelated), allocatable :: unrelat

  allocate(x1, source=srcx)
  allocate(x2, mold=srcx2)
  allocate(bp2(3)%x, source=srcx2)
  !OK, type-compatible with A
  allocate(aa1, up1, unrelat%polymorph, unrelat%notpolymorph, &
    npaa1, source=srca)
  allocate(aa2, up2, npaa2, source=srca2)
  !OK, type compatible with B
  allocate(aa1, up1, unrelat%polymorph, bp1, npbp1, mold=srcb)
  allocate(aa2, up2, bp2, npbp2, mold=srcb2)
  !OK, type compatible with C
  allocate(aa1, up1, unrelat%polymorph, bp1, ca1, npca1, mold=srcc)
  allocate(aa2, up2, bp2, ca2, npca2, source=srcc2)

  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(x1, mold=src_complex)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(x2(2), source=src_complex2)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(bp2(3)%x, mold=src_logical)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(unrelat, mold=srca)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(unrelat%notpolymorph, source=srcb)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(npaa1, mold=srcb)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(npaa2, source=srcb2)
  !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
  allocate(npca1, bp1, npbp1, mold=srcc)
end subroutine

module m
  type :: t
    real x(100)
   contains
    procedure :: f
  end type
 contains
  function f(this) result (x)
    class(t) :: this
    class(t), allocatable :: x
  end function
  subroutine bar
    type(t) :: o
    type(t), allocatable :: p
    real, allocatable :: rp
    allocate(p, source=o%f())
    !ERROR: Allocatable object in ALLOCATE must be type compatible with source expression from MOLD or SOURCE
    allocate(rp, source=o%f())
  end subroutine
end module

! Related to C945, check typeless expression are caught

subroutine sub
end subroutine

function func() result(x)
  real :: x
end function

program test_typeless
  class(*), allocatable :: x
  interface
    subroutine sub
    end subroutine
    real function func()
    end function
  end interface
  procedure (sub), pointer :: subp => sub
  procedure (func), pointer :: funcp => func

  ! OK
  allocate(x, mold=func())
  allocate(x, source=funcp())

  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
  allocate(x, mold=x'1')
  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
  allocate(x, mold=sub)
  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
  allocate(x, source=subp)
  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
  allocate(x, mold=func)
  !ERROR: Typeless item not allowed as SOURCE or MOLD in ALLOCATE
  allocate(x, source=funcp)
end program