text:
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!

module centered_real_linear_systems_solver

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip ! Integer precision

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use type_CenteredCyclicReductionUtility, only: &
        CenteredCyclicReductionUtility

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: genbun

contains

    ! SUBROUTINE genbun(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
    !
    !
    ! DIMENSION OF           a(m), b(m), c(m), y(idimy, n)
    ! ARGUMENTS
    !
    ! PURPOSE                The name of this package is a mnemonic for the
    !                        generalized buneman algorithm.
    !
    !                        It solves the real linear system of equations
    !
    !                        a(i)*x(i-1, j) + b(i)*x(i, j) + c(i)*x(i+1, j)
    !                        + x(i, j-1) - 2.0*x(i, j) + x(i, j+1) = y(i, j)
    !
    !                        for i = 1, 2, ..., m  and  j = 1, 2, ..., n.
    !
    !                        indices i+1 and i-1 are evaluated modulo m,
    !                        i.e., x(0, j) = x(m, j) and x(m+1, j) = x(1, j),
    !                        and x(i, 0) may equal 0, x(i, 2), or x(i, n),
    !                        and x(i, n+1) may equal 0, x(i, n-1), or x(i, 1)
    !                        depending on an input parameter.
    !
    ! USAGE                  call genbun(nperod, n, mperod, m, a, b, c, idimy, y, ierror)
    !
    ! ARGUMENTS
    !
    ! ON INPUT               nperod
    !
    !                          Indicates the values that x(i, 0) and
    !                          x(i, n+1) are assumed to have.
    !
    !                          = 0  if x(i, 0) = x(i, n) and x(i, n+1) =
    !                               x(i, 1).
    !                          = 1  if x(i, 0) = x(i, n+1) = 0  .
    !                          = 2  if x(i, 0) = 0 and x(i, n+1) = x(i, n-1).
    !                          = 3  if x(i, 0) = x(i, 2) and x(i, n+1) =
    !                               x(i, n-1).
    !                          = 4  if x(i, 0) = x(i, 2) and x(i, n+1) = 0.
    !
    !                        n
    !                          The number of unknowns in the j-direction.
    !                          n must be greater than 2.
    !
    !                        mperod
    !                          = 0 if a(1) and c(m) are not zero
    !                          = 1 if a(1) = c(m) = 0
    !
    !                        m
    !                          The number of unknowns in the i-direction.
    !                          n must be greater than 2.
    !
    !                        a, b, c
    !                          One-dimensional arrays of length m that
    !                          specify the coefficients in the linear
    !                          equations given above.  if mperod = 0
    !                          the array elements must not depend upon
    !                          the index i, but must be constant.
    !                          specifically, the subroutine checks the
    !                          following condition .
    !
    !                            a(i) = c(1)
    !                            c(i) = c(1)
    !                            b(i) = b(1)
    !
    !                          for i=1, 2, ..., m.
    !
    !                        idimy
    !                          The row (or first) dimension of the
    !                          two-dimensional array y as it appears
    !                          in the program calling genbun.
    !                          this parameter is used to specify the
    !                          variable dimension of y.
    !                          idimy must be at least m.
    !
    !                        y
    !                          A two-dimensional complex array that
    !                          specifies the values of the right side
    !                          of the linear system of equations given
    !                          above.
    !                          y must be dimensioned at least m*n.
    !
    !
    !  ON OUTPUT             y
    !
    !                          Contains the solution x.
    !
    !                        ierror
    !                          An error flag which indicates invalid
    !                          input parameters  except for number
    !                          zero, a solution is not attempted.
    !
    !                          = 0  no error
    !                          = 1  m <= 2
    !                          = 2  n <= 2
    !                          = 3  idimy <= m
    !                          = 4  nperod <= 0 or nperod > 4
    !                          = 5  mperod < 0 or mperod > 1
    !                          = 6  a(i) /= c(1) or c(i) /= c(1) or
    !                               b(i) /= b(1) for
    !                               some i=1, 2, ..., m.
    !                          = 7  a(1) /= 0 or c(m) /= 0 and
    !                                 mperod = 1
    !                          = 20 If the dynamic allocation of real and
    !                               complex workspace required for solution
    !                               fails (for example if n, m are too large
    !                               for your computer)
    !
    ! HISTORY                Written in 1979 by Roland Sweet of NCAR'S
    !                        scientific computing division. made available
    !                        on NCAR'S public libraries in January, 1980.
    !
    !                        Revised in June 2004 by John Adams using
    !                        Fortran 90 dynamically allocated workspace.
    !
    ! ALGORITHM              The linear system is solved by a cyclic
    !                        reduction algorithm described in the
    !                        reference.
    !
    ! REFERENCES             Sweet, R., "A cyclic reduction algorithm for
    !                        solving block tridiagonal systems of arbitrary
    !                        dimensions, " SIAM J. On Numer. Anal., 14 (1977)
    !                        PP. 706-720.
    !
    ! ACCURACY               This test was performed on a platform with
    !                        64 bit floating point arithmetic.
    !                        a uniform random number generator was used
    !                        to create a solution array x for the system
    !                        given in the 'purpose' description above
    !                        with
    !                          a(i) = c(i) = -HALF *b(i) = 1, i=1, 2, ..., m
    !
    !                        and, when mperod = 1
    !
    !                          a(1) = c(m) = 0
    !                          a(m) = c(1) = 2.
    !
    !                        The solution x was substituted into the
    !                        given system  and, using double precision
    !                        a right side y was computed.
    !                        using this array y, subroutine genbun
    !                        was called to produce approximate
    !                        solution z.  then relative error
    !                          e = max(abs(z(i, j)-x(i, j)))/
    !                              max(abs(x(i, j)))
    !                        was computed, where the two maxima are taken
    !                        over i=1, 2, ..., m and j=1, ..., n.
    !
    !                        The value of e is given in the table
    !                        below for some typical values of m and n.
    !
    !                   m (=n)    mperod    nperod        e
    !                   ------    ------    ------      ------
    !
    !                     31        0         0         6.e-14
    !                     31        1         1         4.e-13
    !                     31        1         3         3.e-13
    !                     32        0         0         9.e-14
    !                     32        1         1         3.e-13
    !                     32        1         3         1.e-13
    !                     33        0         0         9.e-14
    !                     33        1         1         4.e-13
    !                     33        1         3         1.e-13
    !                     63        0         0         1.e-13
    !                     63        1         1         1.e-12
    !                     63        1         3         2.e-13
    !                     64        0         0         1.e-13
    !                     64        1         1         1.e-12
    !                     64        1         3         6.e-13
    !                     65        0         0         2.e-13
    !                     65        1         1         1.e-12
    !                     65        1         3         4.e-13
    !
    subroutine genbun(nperod, n, mperod, m, a, b, c, idimy, y, ierror)

        ! Dummy arguments
        integer(ip), intent(in)    :: nperod
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: mperod
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: idimy
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: a(:)
        real(wp),    intent(in)    :: b(:)
        real(wp),    intent(in)    :: c(:)
        real(wp),    intent(inout) :: y(idimy,n)

        ! Local variables
        type(FishpackWorkspace)              :: workspace
        type(CenteredCyclicReductionUtility) :: util

        ! Allocate memory
        workspace = genbun_get_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call util%genbun_lower_routine(nperod, n, mperod, m, a, b, c, idimy, y, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine genbun

    function genbun_get_workspace(n, m) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)  :: n, m
        type(FishpackWorkspace)  :: return_value

        ! Local variables
        integer(ip)  :: irwk, icwk

        ! Get workspace dimensions for genbun
        call return_value%compute_genbun_workspace_lengths(n, m, irwk)

        ! No need to allocate complex arrays
        icwk = 0

        ! Allocate memory
        call return_value%create(irwk, icwk)

    end function genbun_get_workspace

end module centered_real_linear_systems_solver

max_stars_repo_name: jlokimlin/fishpack

max_issues_repo_name: jlokimlin/fishpack

max_forks_repo_name: jlokimlin/fishpack


text:
! Testing generic-spec, R1207
INTERFACE binky
END INTERFACE binky
!TODO-F08? INTERFACE OPERATOR(.abstract.)
!TODO-F08? END INTERFACE OPERATOR(.abstract.)
INTERFACE OPERATOR ( .le. )
END INTERFACE OPERATOR(.le.)
INTERFACE OPERATOR(-)
END INTERFACE OPERATOR(-)
INTERFACE ASSIGNMENT(=)
END INTERFACE ASSIGNMENT(=)
!TODO-F08? INTERFACE WRITE(UNFORMATTED)
!TODO-F08? END INTERFACE WRITE(UNFORMATTED)
END

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


text:
Pick up the latest copy of the California Aggie and find your favorite Communist/leftist columnist. Gather all your friends in a circle and have one person read the column out loud. Each time a liberal buzzword comes up in the article, raise your glasses and shout hooray! Liberal buzzwords include WASP (White AngloSaxon Protestant), colonization, American imperialism, diversity, racist, oil war, recount, no justice no peace ect. The buzz words vary from each year depending on the political environment.

Unfortunately in recent years, the Aggie columnists have not been as fun as they used to be.  For example it has been hypothesized that John Green actually made a list of buzzwords first and THEN tried to connect them, thus creating his articles.

PassiveAgressive Dissent Regarding This Page:
Pick up the latest copy of the California Aggie and find your favorite Communist/leftist columnist. Gather all your friends in a circle and have one person read the column out loud. Each time a liberal buzzword comes up in the article, raise your glasses and shout hooray! Liberal buzzwords include reality (White AngloSaxon Protestant), colonization, lower taxes, less spending, equality, Bush increased taxes and increased spending, Diebold, Strom Thurman and civil rights ect. The buzz words vary from each year depending on the political environment.  Users/JamesSchwab

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine velocity_correction
!***********************************************************************
! Copyright 2006 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
!     PSEUDOCODE
!
!     FOR each cell
!        If the velocity correction is not 1
!           Set flag to denote corrections needed
!           Exit loop over each cell
!        ENDIF the  factor is not 1
!     ENDFOR each cell
!
!     IF corrections are needed
!        FOR each particle
!           FOR each segment of its travel path
!              Compute new exit time from this cell
!           ENDFOR each segment of its travel path
!        ENDFOR each particle
!     ENDIF corrections are needed
!
!***********************************************************************
! Based on sorbed_times subroutine

      use comparttr, only : npart, n_cells, time_packed, cell_packed
      use comgrid, only : n_grid_points
      use comrock, only : vcf
      implicit none

      logical corrections
      integer i
      integer j
      integer istart
      integer iend
      real*8 time_current
      real*8 time_original_previous
      real*8 delta_time

c***************** Begin executable statements here**********

      corrections = .false.

!     FOR each cell
      check_loop: do i = 1, n_grid_points
!        If the velocity correction factor is not 1
         if(vcf(i).ne.1.) then
!           Set flag to denote corrections needed
            corrections = .true.
!           Exit loop over each cell
            exit check_loop
         end if
!        ENDIF the velocity correction factor is not 1
      end do check_loop
!     ENDFOR each cell

!     IF corrections are needed
      if(corrections) then

         istart = 1
!        FOR each particle
         do i = 1, npart
            iend = istart + n_cells(i)-1
            time_current = 0.
            time_original_previous = 0.
!           FOR each segment of its travel path
            do j = istart, iend
!              Compute new exit time from this cell
               delta_time = time_packed(j)-time_original_previous
               time_current = time_current +
     2              vcf(cell_packed(j))*delta_time
               time_original_previous = time_packed(j)
               time_packed(j) = time_current
            end do
!           ENDFOR each segment of its travel path
            istart = iend + 1
         end do
!        ENDFOR each particle
      end if
!     ENDIF corrections are needed

      return
      end subroutine velocity_correction

max_stars_repo_name: lanl/PLUMECALC

max_issues_repo_name: lanl/PLUMECALC

max_forks_repo_name: lanl/PLUMECALC


text:
      subroutine initil
c     implicit double precision (a-h,o-z)                                    dp
c
      use mod_parameters
      real*8 hed
      common/bk00/
     1k01,k02,k03,k04,k05,k06,k07,k08,k09,k10,k11,k12,
     2k13,k14,k15,k16,k17,k18,k19,k20,k21,k22,k23,k24,
     3k25,k26,k27,k28,k29,k30,k31,k32,k33,k34,k35,k36,
     4k37,k38,k39,k40,k41,k42,k43,k44,k45,k46,k47,k48,
     5k49,k50,k51,k52,k53,k54,k55,k56,k57,k58,k59,k60,
     6k61,k62,k63,k64,k65,k66,k67,k68,k69,k70,k71,k72,
     7k73,k74,k75,k76,k77,k78,k79,k80,k81,k82,k83,k84,
     8k85,k86,k87,k88,k89,k90,k91,k92,k93,k94,k95,k96
      common/bk01/h4(4,5),p14(4,5),p24(4,5)
      common/bk02/ioofc,iphase,imass,lpar(9)
      common/bk04/nprm(8)
      common/bk06/nprnt,mprint,itmpop,numelt,jprint,idump,locstr
      common/bk07/mbfc,nelpg,hed(12)
      common/bk08/kprint,nstep,ite,ilimit,newstf
      common/bk11/cnwmk(2),iequit,iprint,isref
      common/bk14/lfna(15),lfnt(6)
      common/bk15/cpuio(36),cpuip(36)
      common/bk16/maxint
      common/bk17/dn1,dn2,nwebuf,ntime,numnp,neq,ibar,mthsol
      common/bk18/nummat,ityp2d,ako(31)
      common/bk23/itemp,itherm,irtin
      common/bk26/dt,a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
      common/bk27/nlcur,nptst,nthpy,nthpz,nthps,xmy,xmz,xms,nload,nptm
      common/bk29/numfrq,clengt
      common/bk30/numlp,numpc,h22(2,2),pl2(2,2),h33(3,2),pl3(3,2)
      common/bk32/nsref,nequit,time,timep,lprint,nprint
      common/bk34/bb(1)
      common/bk44/hh(8),pp(2,8),xjj(4)
      common/bk45/gps(5),gpt(5)
      common/slar3/nsl,nsntl,nmntl,nslnmx,sltol,slhrd
      common/fissn0/maxneq,mwspac,ntpe0,ntpe1,nfissl(3)
      common/fissn1/melemt,nnns,ntpe2,n2g,llls
      common/fissn2/nwpblk,numblk,mwsusd,mxnepb,maxch,matpr,mench,ifa(2)
      common/cn3/ibbari,intgi,nmbfi,ithopi,ithcri,ithini,iengri,
     1           ijinti
      common/main_block/ a(1)
	  common/mbsize/numelt2, numnp2, neq2
c
      dimension gpst(10)
      equivalence (gpst,gps)
c
      data gpst/.5773502691896,-.5773502691896,-.5773502691896,
     1   .5773502691896, .0000000000000, .5773502691896, .5773502691896,
     2  -.5773502691896,-.5773502691896, .0000000000000/
c
cw      call timin (cpuio,cpuip,1,3)
cw      call timin (cpuio,cpuip,3,2)
      if (itemp.eq.0) go to 10
      numnp1=numnp+1
   10 lpar(5)=ityp2d
      loc=1
      lpar(3)=nelpg
      lpar(4)=numelt
      ndm=8
c
      nprm(1)=ndm
      nprm(2)=(ndm*(ndm+1))/2
      nprm(3)=nprm(2)+ndm
      nprm(4)=0
      nprm(5)=4*lpar(9)
      nprm(6)=48
      nprm(7)=8
      nprm(8)=1
c
c     compute and store basis functions for 4 node elements
c
      do 30 lst=1,5
      e1=gps(lst)
      e2=gpt(lst)
      call basis1 (e1,e2,hh,pp)
      do 20 i=1,4
      h4(i,lst)=hh(i)
      p14(i,lst)=pp(1,i)
   20 p24(i,lst)=pp(2,i)
   30 continue
c
c----------------------------------------------------------------
c----------------------------------------------------------------
ck      write(25,12) maxint
ck   12 format(////5x,'Gaussian integeration points =',i2)
ck      write(25,35)
ck   35 format(////5x,'Shape function for 4 integration points :'//)
ck      do 37 j=1,4
ck      write(25,36) j,(h4(i,j),i=1,4)
ck   36 format(5x,i1,' point : ',4(f8.3)/)
ck   37 continue
c
ck      write(25,38)
ck   38 format(///5x,'Derivative of shape function respect to local'
ck     .       ,' coordinates :'//)
ck      do 42 j=1,4
ck      write(25,41) j,(p14(i,j),i=1,4),j,(p24(i,j),i=1,4)
ck   41 format(5x,i1,' point respect to yy : ',4(f8.3)/5x,
ck     .          i1,' point respect to zz : ',4(f8.3)//)
ck   42 continue
c----------------------------------------------------------------
c----------------------------------------------------------------
c.... set load curves at time zero
      call ldcset (a(k57+2*numnp2),a(k63),a(k64),0.0)
c
c.... set initialization step for reference temperatures
      if(imass.eq.2.and.ithopi.ne.0)then
        write(lfnt(2),199)
        call bye(2)
      endif
      if(ithini.ne.0.and.ithopi.ne.-3)then
      time  =-dt
      nstep =-2
      elseif(imass.eq.2)then
      time=-dt
      nstep=-2
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&
c     else
c.... set initialization step if any nonzero loads at t=0
c     if(mthsol.lt.6) then
c     do 50 i=1,nlcur
c     if (ithcri.eq.i) go to 50
c     if (a(k57+2*numnp-1+i).eq.0.0) go to 50
c     time  =-dt
c     nstep =-2
c     go to 60
c  50 continue
c     endif
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      endif
c
c.... initialize temperatures
   60 continue
      call intmp(a(k81),a(k81+1),a(k82),a(k82+1))
      lpar(2)=numelt
c
      call intelt
c
c     set variables in block solver's common blocks
c
      maxneq=neq
      nnns=ndm
      llls=nnns+nnns*(nnns+1)/2
      n2g=128
c
c     initialize a array
c
      call blkcpy (a(k13),a(k16),nwebuf)
      call azero (a(k20),k21-k20)
c
cw      call timin (cpuio,cpuip,3,3)
cw      call timin (cpuio,cpuip,5,2)
c
c      if (nsl.ne.0) call intsld
c
c.... j-integral initialization
c     if(ijinti.ne.0)call jconsr
c
      return
  199 format(' **Error** cannot use static initialization option'/
     1 ' with thermal option')
      end

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


module mo_filter_functions

  use mo_kind, only: int8=>i1, int16=>i2, int32=>i4, int64=>i8, real32=>sp, real64=>dp
#if defined (__pgiFortran__) || defined (__NAGf90Fortran__) || defined (__NAG__)
  use mo_kind, only: real128=>dp
#else
  use mo_kind, only: real128=>qp
#endif

  implicit none

  public

contains

  pure logical function gt3lt5_i1(x) result(res)
    use mo_kind, only: int8=>i1
    integer(kind=int8),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_i1

  pure logical function gt3lt5_i2(x) result(res)
    use mo_kind, only: int16=>i2
    integer(kind=int16),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_i2

  pure logical function gt3lt5_i4(x) result(res)
    use mo_kind, only: int32=>i4
    integer(kind=int32),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_i4

  pure logical function gt3lt5_i8(x) result(res)
    use mo_kind, only: int64=>i8
    integer(kind=int64),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_i8

  pure logical function gt3lt5_r4(x) result(res)
    use mo_kind, only: real32=>sp
    real(kind=real32),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_r4

  pure logical function gt3lt5_r8(x) result(res)
    use mo_kind, only: real64=>dp
    real(kind=real64),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_r8

  pure logical function gt3lt5_r16(x) result(res)
#if defined (__pgiFortran__) || defined (__NAGf90Fortran__) || defined (__NAG__)
    use mo_kind, only: real128=>dp
#else
    use mo_kind, only: real128=>qp
#endif
    real(kind=real128),intent(in) :: x
    res = x > 3 .and. x < 5
  end function gt3lt5_r16

  pure logical function gt3lt5_c4(x) result(res)
    use mo_kind, only: real32=>sp
    complex(kind=real32),intent(in) :: x
    res = real(x) > 3 .and. real(x) < 5
  end function gt3lt5_c4

  pure logical function gt3lt5_c8(x) result(res)
    use mo_kind, only: real64=>dp
    complex(kind=real64),intent(in) :: x
    res = real(x) > 3 .and. real(x) < 5
  end function gt3lt5_c8

  pure logical function gt3lt5_c16(x) result(res)
#if defined (__pgiFortran__) || defined (__NAGf90Fortran__) || defined (__NAG__)
    use mo_kind, only: real128=>dp
#else
    use mo_kind, only: real128=>qp
#endif
    complex(kind=real128),intent(in) :: x
    res = real(x) > 3 .and. real(x) < 5
  end function gt3lt5_c16

end module mo_filter_functions


text:
program concurrency
  implicit none
  character(len=*), parameter :: str1 = 'Enjoy'
  character(len=*), parameter :: str2 = 'Rosetta'
  character(len=*), parameter :: str3 = 'Code'
  integer                     :: i
  real                        :: h
  real, parameter             :: one_third = 1.0e0/3
  real, parameter             :: two_thirds = 2.0e0/3

  interface
     integer function omp_get_thread_num
     end function omp_get_thread_num
  end interface
  interface
     integer function omp_get_num_threads
     end function omp_get_num_threads
  end interface

  ! Use OpenMP to create a team of threads
  !$omp parallel do private(i,h)
  do i=1,20
     ! First time through the master thread output the number of threads
     ! in the team
     if (omp_get_thread_num() == 0 .and. i == 1) then
        write(*,'(a,i0,a)') 'Using ',omp_get_num_threads(),' threads'
     end if

     ! Randomize the order
     call random_number(h)

     !$omp critical
     if (h < one_third) then
        write(*,'(a)') str1
     else if (h < two_thirds) then
        write(*,'(a)') str2
     else
        write(*,'(a)') str3
     end if
     !$omp end critical
  end do
  !$omp end parallel do

end program concurrency

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
program t
  implicit none
  integer::i
  i=f(-1)
  print '(i0)',i
contains
  integer function f(i)
    integer::i
    print '(i0)',i
    if (i.lt.0) then
      f=i
      return
    endif
    f=i+1
  end function f
end program t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text: Ace Jack Unsuited was a comic strip written by Hoang Tran that ran in the California Aggie from 20052006.  It featured a child genius college student and his roommate.


text: #redirect Southeast Asians Furthering Education


text:
      SUBROUTINE PSLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, A, DESCA,
     $                    ILOZ, IHIZ, Z, DESCZ, NS, ND, SR, SI, T, LDT,
     $                    V, LDV, WR, WI, WORK, LWORK )
*
*     Contribution from the Department of Computing Science and HPC2N,
*     Umea University, Sweden
*
*  -- ScaLAPACK routine (version 2.0.2) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     May 1 2012
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            IHIZ, ILOZ, KBOT, KTOP, LDT, LDV, LWORK, N, ND,
     $                   NS, NW
      LOGICAL            WANTT, WANTZ
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), DESCZ( * )
      REAL               A( * ), SI( KBOT ), SR( KBOT ), T( LDT, * ),
     $                   V( LDV, * ), WORK( * ), WI( * ), WR( * ),
     $                   Z( * )
*     ..
*
*  Purpose
*  =======
*
*  Aggressive early deflation:
*
*  PSLAQR2 accepts as input an upper Hessenberg matrix A and performs an
*  orthogonal similarity transformation designed to detect and deflate
*  fully converged eigenvalues from a trailing principal submatrix.  On
*  output A has been overwritten by a new Hessenberg matrix that is a
*  perturbation of an orthogonal similarity transformation of A.  It is
*  to be hoped that the final version of H has many zero subdiagonal
*  entries.
*
*  This routine handles small deflation windows which is affordable by
*  one processor. Normally, it is called by PSLAQR1. All the inputs are
*  assumed to be valid without checking.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  WANTT   (global input) LOGICAL
*          If .TRUE., then the Hessenberg matrix H is fully updated
*          so that the quasi-triangular Schur factor may be
*          computed (in cooperation with the calling subroutine).
*          If .FALSE., then only enough of H is updated to preserve
*          the eigenvalues.
*
*  WANTZ   (global input) LOGICAL
*          If .TRUE., then the orthogonal matrix Z is updated so
*          so that the orthogonal Schur factor may be computed
*          (in cooperation with the calling subroutine).
*          If .FALSE., then Z is not referenced.
*
*  N       (global input) INTEGER
*          The order of the matrix H and (if WANTZ is .TRUE.) the
*          order of the orthogonal matrix Z.
*
*  KTOP    (global input) INTEGER
*  KBOT    (global input) INTEGER
*          It is assumed without a check that either
*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together
*          determine an isolated block along the diagonal of the
*          Hessenberg matrix. However, H(KTOP,KTOP-1)=0 is not
*          essentially necessary if WANTT is .TRUE. .
*
*  NW      (global input) INTEGER
*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).
*          Normally NW .GE. 3 if PSLAQR2 is called by PSLAQR1.
*
*  A       (local input/output) REAL             array, dimension
*          (DESCH(LLD_),*)
*          On input the initial N-by-N section of A stores the
*          Hessenberg matrix undergoing aggressive early deflation.
*          On output A has been transformed by an orthogonal
*          similarity transformation, perturbed, and the returned
*          to Hessenberg form that (it is to be hoped) has some
*          zero subdiagonal entries.
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  ILOZ    (global input) INTEGER
*  IHIZ    (global input) INTEGER
*          Specify the rows of Z to which transformations must be
*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
*
*  Z       (input/output) REAL             array, dimension
*          (DESCH(LLD_),*)
*          IF WANTZ is .TRUE., then on output, the orthogonal
*          similarity transformation mentioned above has been
*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
*          If WANTZ is .FALSE., then Z is unreferenced.
*
*  DESCZ   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix Z.
*
*  NS      (global output) INTEGER
*          The number of unconverged (ie approximate) eigenvalues
*          returned in SR and SI that may be used as shifts by the
*          calling subroutine.
*
*  ND      (global output) INTEGER
*          The number of converged eigenvalues uncovered by this
*          subroutine.
*
*  SR      (global output) REAL             array, dimension KBOT
*  SI      (global output) REAL             array, dimension KBOT
*          On output, the real and imaginary parts of approximate
*          eigenvalues that may be used for shifts are stored in
*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
*          On proc #0, the real and imaginary parts of converged
*          eigenvalues are stored in SR(KBOT-ND+1) through SR(KBOT) and
*          SI(KBOT-ND+1) through SI(KBOT), respectively. On other
*          processors, these entries are set to zero.
*
*  T       (local workspace) REAL             array, dimension LDT*NW.
*
*  LDT     (local input) INTEGER
*          The leading dimension of the array T.
*          LDT >= NW.
*
*  V       (local workspace) REAL             array, dimension LDV*NW.
*
*  LDV     (local input) INTEGER
*          The leading dimension of the array V.
*          LDV >= NW.
*
*  WR      (local workspace) REAL             array, dimension KBOT.
*  WI      (local workspace) REAL             array, dimension KBOT.
*
*  WORK    (local workspace) REAL             array, dimension LWORK.
*
*  LWORK   (local input) INTEGER
*          WORK(LWORK) is a local array and LWORK is assumed big enough
*          so that LWORK >= NW*NW.
*
*  ================================================================
*  Implemented by
*        Meiyue Shao, Department of Computing Science and HPC2N,
*        Umea University, Sweden
*
*  ================================================================
*  References:
*        B. Kagstrom, D. Kressner, and M. Shao,
*        On Aggressive Early Deflation in Parallel Variants of the QR
*        Algorithm.
*        Para 2010, to appear.
*
*  ================================================================
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CONTXT, HBL, I, I1, I2, IAFIRST, ICOL, ICOL1,
     $                   ICOL2, INFO, II, IROW, IROW1, IROW2, ITMP1,
     $                   ITMP2, J, JAFIRST, JJ, K, L, LDA, LDZ, LLDTMP,
     $                   MYCOL, MYROW, NODE, NPCOL, NPROW, DBLK,
     $                   HSTEP, VSTEP, KKROW, KKCOL, KLN, LTOP, LEFT,
     $                   RIGHT, UP, DOWN, D1, D2
*     ..
*     .. Local Arrays ..
      INTEGER            DESCT( 9 ), DESCV( 9 ), DESCWH( 9 ),
     $                   DESCWV( 9 )
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, INFOG2L, SLASET,
     $                   SLAQR3, DESCINIT, PSGEMM, PSGEMR2D, SGEMM,
     $                   SLAMOV, SGESD2D, SGERV2D, SGEBS2D, SGEBR2D,
     $                   IGEBS2D, IGEBR2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
      IF( N.EQ.0 )
     $   RETURN
*
*     NODE (IAFIRST,JAFIRST) OWNS A(1,1)
*
      HBL = DESCA( MB_ )
      CONTXT = DESCA( CTXT_ )
      LDA = DESCA( LLD_ )
      IAFIRST = DESCA( RSRC_ )
      JAFIRST = DESCA( CSRC_ )
      LDZ = DESCZ( LLD_ )
      CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL )
      NODE = MYROW*NPCOL + MYCOL
      LEFT = MOD( MYCOL+NPCOL-1, NPCOL )
      RIGHT = MOD( MYCOL+1, NPCOL )
      UP = MOD( MYROW+NPROW-1, NPROW )
      DOWN = MOD( MYROW+1, NPROW )
*
*     I1 and I2 are the indices of the first row and last column of A
*     to which transformations must be applied.
*
      I = KBOT
      L = KTOP
      IF( WANTT ) THEN
         I1 = 1
         I2 = N
         LTOP = 1
      ELSE
         I1 = L
         I2 = I
         LTOP = L
      END IF
*
*     Begin Aggressive Early Deflation.
*
      DBLK = NW
      CALL INFOG2L( I-DBLK+1, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
     $     MYCOL, IROW, ICOL, II, JJ )
      IF ( MYROW .EQ. II ) THEN
         CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
     $        LDT, INFO )
         CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
     $        LDV, INFO )
      ELSE
         CALL DESCINIT( DESCT, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
     $        1, INFO )
         CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, II, JJ, CONTXT,
     $        1, INFO )
      END IF
      CALL PSGEMR2D( DBLK, DBLK, A, I-DBLK+1, I-DBLK+1, DESCA, T, 1, 1,
     $     DESCT, CONTXT )
      IF ( MYROW .EQ. II .AND. MYCOL .EQ. JJ ) THEN
         CALL SLASET( 'All', DBLK, DBLK, ZERO, ONE, V, LDV )
         CALL SLAQR3( .TRUE., .TRUE., DBLK, 1, DBLK, DBLK-1, T, LDT, 1,
     $        DBLK, V, LDV, NS, ND, WR, WI, WORK, DBLK, DBLK,
     $        WORK( DBLK*DBLK+1 ), DBLK, DBLK, WORK( 2*DBLK*DBLK+1 ),
     $        DBLK, WORK( 3*DBLK*DBLK+1 ), LWORK-3*DBLK*DBLK )
         CALL SGEBS2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV )
         CALL IGEBS2D( CONTXT, 'All', ' ', 1, 1, ND, 1 )
      ELSE
         CALL SGEBR2D( CONTXT, 'All', ' ', DBLK, DBLK, V, LDV, II, JJ )
         CALL IGEBR2D( CONTXT, 'All', ' ', 1, 1, ND, 1, II, JJ )
      END IF
*
      IF( ND .GT. 0 ) THEN
*
*        Copy the local matrix back to the diagonal block.
*
         CALL PSGEMR2D( DBLK, DBLK, T, 1, 1, DESCT, A, I-DBLK+1,
     $        I-DBLK+1, DESCA, CONTXT )
*
*        Update T and Z.
*
         IF( MOD( I-DBLK, HBL )+DBLK .LE. HBL ) THEN
*
*           Simplest case: the deflation window is located on one
*           processor.
*           Call SGEMM directly to perform the update.
*
            HSTEP = LWORK / DBLK
            VSTEP = HSTEP
*
*           Update horizontal slab in A.
*
            IF( WANTT ) THEN
               CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
     $              MYCOL, IROW, ICOL, II, JJ )
               IF( MYROW .EQ. II ) THEN
                  ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
                  DO 10 KKCOL = ICOL, ICOL1, HSTEP
                     KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
                     CALL SGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
     $                    LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO, WORK,
     $                    DBLK )
                     CALL SLAMOV( 'A', DBLK, KLN, WORK, DBLK,
     $                    A( IROW+(KKCOL-1)*LDA ), LDA )
   10             CONTINUE
               END IF
            END IF
*
*           Update vertical slab in A.
*
            CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
     $           MYCOL, IROW, ICOL, II, JJ )
            IF( MYCOL .EQ. JJ ) THEN
               CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
     $              MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
               IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
               DO 20 KKROW = IROW, IROW1, VSTEP
                  KLN = MIN( VSTEP, IROW1-KKROW+1 )
                  CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
     $                 A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO, WORK,
     $                 KLN )
                  CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
     $                 A( KKROW+(ICOL-1)*LDA ), LDA )
   20          CONTINUE
            END IF
*
*           Update vertical slab in Z.
*
            IF( WANTZ ) THEN
               CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
     $              MYCOL, IROW, ICOL, II, JJ )
               IF( MYCOL .EQ. JJ ) THEN
                  CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
     $                 MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                  IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                  DO 30 KKROW = IROW, IROW1, VSTEP
                     KLN = MIN( VSTEP, IROW1-KKROW+1 )
                     CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
     $                    Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
     $                    WORK, KLN )
                     CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
     $                    Z( KKROW+(ICOL-1)*LDZ ), LDZ )
   30             CONTINUE
               END IF
            END IF
*
         ELSE IF( MOD( I-DBLK, HBL )+DBLK .LE. 2*HBL ) THEN
*
*           More complicated case: the deflation window lay on a 2x2
*           processor mesh.
*           Call SGEMM locally and communicate by pair.
*
            D1 = HBL - MOD( I-DBLK, HBL )
            D2 = DBLK - D1
            HSTEP = LWORK / DBLK
            VSTEP = HSTEP
*
*           Update horizontal slab in A.
*
            IF( WANTT ) THEN
               CALL INFOG2L( I-DBLK+1, I+1, DESCA, NPROW, NPCOL, MYROW,
     $              MYCOL, IROW, ICOL, II, JJ )
               IF( MYROW .EQ. UP ) THEN
                  IF( MYROW .EQ. II ) THEN
                     ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
                     DO 40 KKCOL = ICOL, ICOL1, HSTEP
                        KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
                        CALL SGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V,
     $                       DBLK, A( IROW+(KKCOL-1)*LDA ), LDA, ZERO,
     $                       WORK, DBLK )
                        CALL SLAMOV( 'A', DBLK, KLN, WORK, DBLK,
     $                       A( IROW+(KKCOL-1)*LDA ), LDA )
   40                CONTINUE
                  END IF
               ELSE
                  IF( MYROW .EQ. II ) THEN
                     ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
                     DO 50 KKCOL = ICOL, ICOL1, HSTEP
                        KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
                        CALL SGEMM( 'T', 'N', D2, KLN, D1, ONE,
     $                       V( 1, D1+1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
     $                       LDA, ZERO, WORK( D1+1 ), DBLK )
                        CALL SGESD2D( CONTXT, D2, KLN, WORK( D1+1 ),
     $                       DBLK, DOWN, MYCOL )
                        CALL SGERV2D( CONTXT, D1, KLN, WORK, DBLK, DOWN,
     $                       MYCOL )
                        CALL SGEMM( 'T', 'N', D1, KLN, D1, ONE,
     $                       V, LDV, A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
     $                       WORK, DBLK )
                        CALL SLAMOV( 'A', D1, KLN, WORK, DBLK,
     $                       A( IROW+(KKCOL-1)*LDA ), LDA )
   50                CONTINUE
                  ELSE IF( UP .EQ. II ) THEN
                     ICOL1 = NUMROC( N, HBL, MYCOL, JAFIRST, NPCOL )
                     DO 60 KKCOL = ICOL, ICOL1, HSTEP
                        KLN = MIN( HSTEP, ICOL1-KKCOL+1 )
                        CALL SGEMM( 'T', 'N', D1, KLN, D2, ONE,
     $                       V( D1+1, 1 ), LDV, A( IROW+(KKCOL-1)*LDA ),
     $                       LDA, ZERO, WORK, DBLK )
                        CALL SGESD2D( CONTXT, D1, KLN, WORK, DBLK, UP,
     $                       MYCOL )
                        CALL SGERV2D( CONTXT, D2, KLN, WORK( D1+1 ),
     $                       DBLK, UP, MYCOL )
                        CALL SGEMM( 'T', 'N', D2, KLN, D2, ONE,
     $                       V( D1+1, D1+1 ), LDV,
     $                       A( IROW+(KKCOL-1)*LDA ), LDA, ONE,
     $                       WORK( D1+1 ), DBLK )
                        CALL SLAMOV( 'A', D2, KLN, WORK( D1+1 ), DBLK,
     $                       A( IROW+(KKCOL-1)*LDA ), LDA )
   60                CONTINUE
                  END IF
               END IF
            END IF
*
*           Update vertical slab in A.
*
            CALL INFOG2L( LTOP, I-DBLK+1, DESCA, NPROW, NPCOL, MYROW,
     $           MYCOL, IROW, ICOL, II, JJ )
            IF( MYCOL .EQ. LEFT ) THEN
               IF( MYCOL .EQ. JJ ) THEN
                  CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
     $                 MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                  IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                  DO 70 KKROW = IROW, IROW1, VSTEP
                     KLN = MIN( VSTEP, IROW1-KKROW+1 )
                     CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ZERO,
     $                    WORK, KLN )
                     CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA )
   70             CONTINUE
               END IF
            ELSE
               IF( MYCOL .EQ. JJ ) THEN
                  CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
     $                 MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                  IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                  DO 80 KKROW = IROW, IROW1, VSTEP
                     KLN = MIN( VSTEP, IROW1-KKROW+1 )
                     CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA,
     $                    V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
     $                    KLN )
                     CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
     $                    KLN, MYROW, RIGHT )
                     CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
     $                    RIGHT )
                     CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA, V, LDV, ONE,
     $                    WORK, KLN )
                     CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA )
   80             CONTINUE
               ELSE IF ( LEFT .EQ. JJ ) THEN
                  CALL INFOG2L( I-DBLK, I-DBLK+1, DESCA, NPROW, NPCOL,
     $                 MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                  IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                  DO 90 KKROW = IROW, IROW1, VSTEP
                     KLN = MIN( VSTEP, IROW1-KKROW+1 )
                     CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, 1 ),
     $                    LDV, ZERO, WORK, KLN )
                     CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
     $                    LEFT )
                     CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
     $                    KLN, MYROW, LEFT )
                     CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA, V( D1+1, D1+1 ),
     $                    LDV, ONE, WORK( 1+D1*KLN ), KLN )
                     CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ), KLN,
     $                    A( KKROW+(ICOL-1)*LDA ), LDA )
   90             CONTINUE
               END IF
            END IF
*
*           Update vertical slab in Z.
*
            IF( WANTZ ) THEN
               CALL INFOG2L( ILOZ, I-DBLK+1, DESCZ, NPROW, NPCOL, MYROW,
     $              MYCOL, IROW, ICOL, II, JJ )
               IF( MYCOL .EQ. LEFT ) THEN
                  IF( MYCOL .EQ. JJ ) THEN
                     CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
     $                    MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                     IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                     DO 100 KKROW = IROW, IROW1, VSTEP
                        KLN = MIN( VSTEP, IROW1-KKROW+1 )
                        CALL SGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ZERO,
     $                       WORK, KLN )
                        CALL SLAMOV( 'A', KLN, DBLK, WORK, KLN,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ )
  100                CONTINUE
                  END IF
               ELSE
                  IF( MYCOL .EQ. JJ ) THEN
                     CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
     $                    MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                     IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                     DO 110 KKROW = IROW, IROW1, VSTEP
                        KLN = MIN( VSTEP, IROW1-KKROW+1 )
                        CALL SGEMM( 'N', 'N', KLN, D2, D1, ONE,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ,
     $                       V( 1, D1+1 ), LDV, ZERO, WORK( 1+D1*KLN ),
     $                       KLN )
                        CALL SGESD2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
     $                       KLN, MYROW, RIGHT )
                        CALL SGERV2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
     $                       RIGHT )
                        CALL SGEMM( 'N', 'N', KLN, D1, D1, ONE,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ, V, LDV, ONE,
     $                       WORK, KLN )
                        CALL SLAMOV( 'A', KLN, D1, WORK, KLN,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ )
  110                CONTINUE
                  ELSE IF( LEFT .EQ. JJ ) THEN
                     CALL INFOG2L( IHIZ, I-DBLK+1, DESCZ, NPROW, NPCOL,
     $                    MYROW, MYCOL, IROW1, ICOL1, ITMP1, ITMP2 )
                     IF( MYROW .NE. ITMP1 ) IROW1 = IROW1-1
                     DO 120 KKROW = IROW, IROW1, VSTEP
                        KLN = MIN( VSTEP, IROW1-KKROW+1 )
                        CALL SGEMM( 'N', 'N', KLN, D1, D2, ONE,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ,
     $                       V( D1+1, 1 ), LDV, ZERO, WORK, KLN )
                        CALL SGESD2D( CONTXT, KLN, D1, WORK, KLN, MYROW,
     $                       LEFT )
                        CALL SGERV2D( CONTXT, KLN, D2, WORK( 1+D1*KLN ),
     $                       KLN, MYROW, LEFT )
                        CALL SGEMM( 'N', 'N', KLN, D2, D2, ONE,
     $                       Z( KKROW+(ICOL-1)*LDZ ), LDZ,
     $                       V( D1+1, D1+1 ), LDV, ONE,
     $                       WORK( 1+D1*KLN ), KLN )
                        CALL SLAMOV( 'A', KLN, D2, WORK( 1+D1*KLN ),
     $                       KLN, Z( KKROW+(ICOL-1)*LDZ ), LDZ )
  120                CONTINUE
                  END IF
               END IF
            END IF
*
         ELSE
*
*           Most complicated case: the deflation window lay across the
*           border of the processor mesh.
*           Treat V as a distributed matrix and call PSGEMM.
*
            HSTEP = LWORK / DBLK * NPCOL
            VSTEP = LWORK / DBLK * NPROW
            LLDTMP = NUMROC( DBLK, DBLK, MYROW, 0, NPROW )
            LLDTMP = MAX( 1, LLDTMP )
            CALL DESCINIT( DESCV, DBLK, DBLK, DBLK, DBLK, 0, 0, CONTXT,
     $           LLDTMP, INFO )
            CALL DESCINIT( DESCWH, DBLK, HSTEP, DBLK, LWORK / DBLK, 0,
     $           0, CONTXT, LLDTMP, INFO )
*
*           Update horizontal slab in A.
*
            IF( WANTT ) THEN
               DO 130 KKCOL = I+1, N, HSTEP
                  KLN = MIN( HSTEP, N-KKCOL+1 )
                  CALL PSGEMM( 'T', 'N', DBLK, KLN, DBLK, ONE, V, 1, 1,
     $                 DESCV, A, I-DBLK+1, KKCOL, DESCA, ZERO, WORK, 1,
     $                 1, DESCWH )
                  CALL PSGEMR2D( DBLK, KLN, WORK, 1, 1, DESCWH, A,
     $                 I-DBLK+1, KKCOL, DESCA, CONTXT )
  130          CONTINUE
            END IF
*
*           Update vertical slab in A.
*
            DO 140 KKROW = LTOP, I-DBLK, VSTEP
               KLN = MIN( VSTEP, I-DBLK-KKROW+1 )
               LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
               LLDTMP = MAX( 1, LLDTMP )
               CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK, 0,
     $              0, CONTXT, LLDTMP, INFO )
               CALL PSGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, A, KKROW,
     $              I-DBLK+1, DESCA, V, 1, 1, DESCV, ZERO, WORK, 1, 1,
     $              DESCWV )
               CALL PSGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, A, KKROW,
     $              I-DBLK+1, DESCA, CONTXT )
  140       CONTINUE
*
*           Update vertical slab in Z.
*
            IF( WANTZ ) THEN
               DO 150 KKROW = ILOZ, IHIZ, VSTEP
                  KLN = MIN( VSTEP, IHIZ-KKROW+1 )
                  LLDTMP = NUMROC( KLN, LWORK / DBLK, MYROW, 0, NPROW )
                  LLDTMP = MAX( 1, LLDTMP )
                  CALL DESCINIT( DESCWV, KLN, DBLK, LWORK / DBLK, DBLK,
     $                 0, 0, CONTXT, LLDTMP, INFO )
                  CALL PSGEMM( 'N', 'N', KLN, DBLK, DBLK, ONE, Z, KKROW,
     $                 I-DBLK+1, DESCZ, V, 1, 1, DESCV, ZERO, WORK, 1,
     $                 1, DESCWV )
                  CALL PSGEMR2D( KLN, DBLK, WORK, 1, 1, DESCWV, Z,
     $                 KKROW, I-DBLK+1, DESCZ, CONTXT )
  150          CONTINUE
            END IF
         END IF
*
*        Extract converged eigenvalues.
*
         II = 0
  160    CONTINUE
            IF( II .EQ. ND-1 .OR. WI( DBLK-II ) .EQ. ZERO ) THEN
               IF( NODE .EQ. 0 ) THEN
                  SR( I-II ) = WR( DBLK-II )
               ELSE
                  SR( I-II ) = ZERO
               END IF
               SI( I-II ) = ZERO
               II = II + 1
            ELSE
               IF( NODE .EQ. 0 ) THEN
                  SR( I-II-1 ) = WR( DBLK-II-1 )
                  SR( I-II ) = WR( DBLK-II )
                  SI( I-II-1 ) = WI( DBLK-II-1 )
                  SI( I-II ) = WI( DBLK-II )
               ELSE
                  SR( I-II-1 ) = ZERO
                  SR( I-II ) = ZERO
                  SI( I-II-1 ) = ZERO
                  SI( I-II ) = ZERO
               END IF
               II = II + 2
            END IF
         IF( II .LT. ND ) GOTO 160
      END IF
*
*     END OF PSLAQR2
*
      END

max_stars_repo_name: jschueller/scalapack

max_issues_repo_name: jschueller/scalapack

max_forks_repo_name: jschueller/scalapack


text:
!
!  Copyright (c) 2019 National Technology & Engineering Solutions of
!  Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
!  NTESS, the U.S. Government retains certain rights in this software.
!
   SUBROUTINE Z21_Z25
     USE NWC_DATABASE
     USE NWC_2000
     IMPLICIT NONE

     !This subroutine contains elements 21-25 (scandium,titanium,vanadium,chromium,and
     !manganese) and their naturally occuring isotopes.
     !Created with the Current Nuclear Wallet Cards (2004)
     !on May 25, 2004 by Karen Kajder.
     !
     !Modified to latest NWC electronic version values and ENDF/B-VII cross
     !sections by K. Russell DePriest on December 12, 2011.
     !
     ! - ENDF/B-VII Release 1 cross sections (that is, .80c) made the default
     !   on 05/09/2014 by K. Russell DePriest.
     ! - Vanadium changed from elemental to isotopic
     !
     ! - ENDF/B-VIII.0 cross sections at 293.6 K (that is, .00c) made the default
     !   on 07/22/2020 by K. Russell DePriest.
     !
     ! - Nuclear Wallet Card values verified on 07/22/2020 using
     !   "Nuclear Wallet Cards database version of 7/10/2019" on nndc.bnl.gov website.

     !Local variables
     REAL::holder, mass_of_element
     INTEGER:: i

     !Number of Scandium Isotopes
     sc_size = 1

     scandium_array(1)%z = 21
     scandium_array(1)%a = 45
     scandium_array(1)%symbol ="Sc-45 "
     scandium_array(1)%mass_defect = -41.0718
     scandium_array(1)%atom_percent = 100.0
     scandium_array(1)%zaid = "21045.00c"

     !Calculate isotopic mass for Scandium
     DO i=1,sc_size
          holder = scandium_array(i)%a + (scandium_array(i)%mass_defect/MeV_amu)

          scandium_array(i)%isotopic_mass = holder
     END DO

     !Set mass and holder to zero.
     sc_mass = 0.0
     holder = 0.0

     !Calculate mass of Scandium
     DO i=1, sc_size
          sc_mass = holder + (scandium_array(i)%isotopic_mass*		&
          &	scandium_array(i)%atom_percent)/100

          holder = sc_mass
     END DO

     !Calculate weight percent of Scandium
     DO i=1, sc_size
          scandium_array(i)%weight_percent = (scandium_array(i)%isotopic_mass &
          &   * scandium_array(i)%atom_percent)/sc_mass
     END DO

     !Number of Titanium Isotopes
     ti_size = 5

     titanium_array(1)%z = 22
     titanium_array(1)%a = 46
     titanium_array(1)%symbol ="Ti-46 "
     titanium_array(1)%mass_defect = -44.1277
     titanium_array(1)%atom_percent = 8.25
     titanium_array(1)%zaid = "22046.00c"

     titanium_array(2)%z = 22
     titanium_array(2)%a = 47
     titanium_array(2)%symbol ="Ti-47 "
     titanium_array(2)%mass_defect = -44.9373
     titanium_array(2)%atom_percent = 7.44
     titanium_array(2)%zaid = "22047.00c"

     titanium_array(3)%z = 22
     titanium_array(3)%a = 48
     titanium_array(3)%symbol ="Ti-48 "
     titanium_array(3)%mass_defect = -48.4927
     titanium_array(3)%atom_percent = 73.72
     titanium_array(3)%zaid = "22048.00c"

     titanium_array(4)%z = 22
     titanium_array(4)%a = 49
     titanium_array(4)%symbol ="Ti-49 "
     titanium_array(4)%mass_defect = -48.5637
     titanium_array(4)%atom_percent = 5.41
     titanium_array(4)%zaid = "22049.00c"

     titanium_array(5)%z = 22
     titanium_array(5)%a = 50
     titanium_array(5)%symbol ="Ti-50 "
     titanium_array(5)%mass_defect = -51.4316
     titanium_array(5)%atom_percent = 5.18
     titanium_array(5)%zaid = "22050.00c"

     !Calculate isotopic mass for Titanium
     DO i=1,ti_size
          holder = titanium_array(i)%a + (titanium_array(i)%mass_defect/MeV_amu)

          titanium_array(i)%isotopic_mass = holder
     END DO

     !Set mass and holder to zero.
     ti_mass = 0.0
     holder = 0.0

     !Calculate mass of Titanium
     DO i=1, ti_size
          ti_mass = holder + (titanium_array(i)%isotopic_mass*          &
          &     titanium_array(i)%atom_percent)/100

          holder = ti_mass
     END DO

     !Calculate weight percent of Titanium
     DO i=1, ti_size
          titanium_array(i)%weight_percent = (titanium_array(i)%isotopic_mass &
          &   * titanium_array(i)%atom_percent)/ti_mass
     END DO

     !Number of Vanadium Isotopes
     v_size = 2

     vanadium_array(1)%z = 23
     vanadium_array(1)%a = 50
     vanadium_array(1)%symbol =" V-50 "
     vanadium_array(1)%mass_defect = -49.2240
     vanadium_array(1)%atom_percent = 0.250
     vanadium_array(1)%zaid = "23050.00c"

     vanadium_array(2)%z = 23
     vanadium_array(2)%a = 51
     vanadium_array(2)%symbol =" V-51 "
     vanadium_array(2)%mass_defect = -52.2038
     vanadium_array(2)%atom_percent = 99.750
     vanadium_array(2)%zaid = "23051.00c"

     !Calculate isotopic mass for Vanadium
     DO i=1,v_size
          holder = vanadium_array(i)%a + (vanadium_array(i)%mass_defect/MeV_amu)

          vanadium_array(i)%isotopic_mass = holder
     END DO

     !Set mass and holder to zero.
     v_mass = 0.0
     holder = 0.0

     !Calculate mass of Vanadium
     DO i=1, v_size
          v_mass = holder + (vanadium_array(i)%isotopic_mass*          &
          &     vanadium_array(i)%atom_percent)/100

          holder = v_mass
     END DO

     !Calculate weight percent of Vanadium
     DO i=1, v_size
          vanadium_array(i)%weight_percent = (vanadium_array(i)%isotopic_mass &
          &   * vanadium_array(i)%atom_percent)/v_mass
     END DO

     !Number of Chromium Isotopes
     cr_size = 4

     chromium_array(1)%z = 24
     chromium_array(1)%a = 50
     chromium_array(1)%symbol ="Cr-50 "
     chromium_array(1)%mass_defect = -50.2620
     chromium_array(1)%atom_percent = 4.345
     chromium_array(1)%zaid = "24050.00c"

     chromium_array(2)%z = 24
     chromium_array(2)%a = 52
     chromium_array(2)%symbol ="Cr-52 "
     chromium_array(2)%mass_defect = -55.4192
     chromium_array(2)%atom_percent = 83.789
     chromium_array(2)%zaid = "24052.00c"

     chromium_array(3)%z = 24
     chromium_array(3)%a = 53
     chromium_array(3)%symbol ="Cr-53 "
     chromium_array(3)%mass_defect = -55.2869
     chromium_array(3)%atom_percent = 9.501
     chromium_array(3)%zaid = "24053.00c"

     chromium_array(4)%z = 24
     chromium_array(4)%a = 54
     chromium_array(4)%symbol ="Cr-54 "
     chromium_array(4)%mass_defect = -56.9347
     chromium_array(4)%atom_percent = 2.365
     chromium_array(4)%zaid = "24054.00c"

     !Calculate isotopic mass for Chromium
     DO i=1,cr_size
          holder = chromium_array(i)%a + (chromium_array(i)%mass_defect/MeV_amu)

          chromium_array(i)%isotopic_mass = holder
     END DO

     !Set mass and holder to zero.
     cr_mass = 0.0
     holder = 0.0

     !Calculate mass of Chromium
     DO i=1, cr_size
          cr_mass = holder + (chromium_array(i)%isotopic_mass*          &
          &     chromium_array(i)%atom_percent)/100

          holder = cr_mass
     END DO

     !Calculate weight percent of Chromium
     DO i=1, cr_size
          chromium_array(i)%weight_percent = (chromium_array(i)%isotopic_mass &
          &   * chromium_array(i)%atom_percent)/cr_mass
     END DO

     !Number of Manganese Isotopes
     mn_size = 1

     manganese_array(1)%z = 25
     manganese_array(1)%a = 55
     manganese_array(1)%symbol ="Mn-55 "
     manganese_array(1)%mass_defect = -57.7124
     manganese_array(1)%atom_percent = 100.0
     manganese_array(1)%zaid = "25055.00c"

     !Calculate isotopic mass for Manganese
     DO i=1,mn_size
          holder = manganese_array(i)%a + (manganese_array(i)%mass_defect/MeV_amu)

          manganese_array(i)%isotopic_mass = holder
     END DO

     !Set mass and holder to zero.
     mn_mass = 0.0
     holder = 0.0

     !Calculate mass of Manganese
     DO i=1, mn_size
          mn_mass = holder + (manganese_array(i)%isotopic_mass*          &
          &     manganese_array(i)%atom_percent)/100

          holder = mn_mass
     END DO

     !Calculate weight percent of Manganese
     DO i=1, mn_size
          manganese_array(i)%weight_percent = (manganese_array(i)%isotopic_mass &
          &   * manganese_array(i)%atom_percent)/mn_mass
     END DO

   END SUBROUTINE Z21_Z25

max_stars_repo_name: krdepri/MatMCNP

max_issues_repo_name: sandialabs/MatMCNP

max_forks_repo_name: sandialabs/MatMCNP


text:
      SUBROUTINE G1CLS7(IFUNCO,LENGTH,IDATA,RDATA)
C
C          ------------------------------------------------
C          ROUTINE NO. (1018)   VERSION (A8.8)    14:JUL:97
C          ------------------------------------------------
C
C          THIS DECODES MAPPING AND PICTURE-TRANSFORMATION FUNCTIONS.
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          <IFUNCO> GIVES THE FUNCTION CODE:
C                   =  1, DEFINE LIN.-LIN. MAP       (X1,X2,Y1,Y2),
C                   =  2, DEFINE LIN.-LOG. MAP       (X1,X2,Y1,Y2),
C                   =  3, DEFINE LOG.-LIN. MAP       (X1,X2,Y1,Y2),
C                   =  4, DEFINE LOG.-LOG. MAP       (X1,X2,Y1,Y2),
C                   =  5, DEFINE VECTOR WINDOW       (X1,X2,Y1,Y2),
C                   =  6, DEFINE NEW MASK AREA       (X1,X2,Y1,Y2),
C                   =  7, SET MASK LEVEL             (N),
C                   =  8, SET PICTURE X-SCALE        (FACTOR),
C                   =  9, SET PICTURE Y-SCALE        (FACTOR),
C                   = 10, -NO LONGER USED-
C                   = 11, -NO LONGER USED-
C                   = 12, SET PICTURE ROTATE         (ANGLE),
C                   = 13, SET DEVICE REFERENCE POINT (X,Y),
C                   = 14, DO A TRANSFORM INDENT,
C                   = 15, DO A TRANSFORM UNDENT      (C1,....C7),
C                   = 16, SET CLIP TRANSFORM MODE    (N),
C                   = 17, SET TRANSFORM RANGE        (N).
C          <LENGTH> GIVES THE DATA LENGTH (IN BYTES),
C          [IDATA]  IS THE INTEGER DATA ARRAY, AND
C          [RDATA]  IS THE ALTERNATIVE REAL DATA ARRAY.
C
C
      REAL    RDATA(*)
      INTEGER IDATA(*)
      LOGICAL SHIFT1,CURTRA,ERRON
C
      COMMON /T1CFON/ KFONT1
      COMMON /T1CPOS/ XCHAR,YCHAR
      COMMON /T1MAPP/ X1MAP1,X2MAP1,Y1MAP1,Y2MAP1
      COMMON /T1MAPS/ ORIMX1,ORIMY1,SCAMX1,SCAMY1
      COMMON /T1MAPT/ MAPNO1
      COMMON /T1MASK/ X1MSK1(10),X2MSK1(10),Y1MSK1(10),Y2MSK1(10),MSKLV1
      COMMON /T1PPBT/ XPLOTB,YPLOTB
      COMMON /T1PPOS/ XPLOT1,YPLOT1
      COMMON /T1TCOB/ XCBX,XCBY,YCBX,YCBY,RPICXB,RPICYB,RDEVXB,RDEVYB
      COMMON /T1TCOC/ XCCX,XCCY,YCCX,YCCY,RPICXC,RPICYC,RDEVXC,RDEVYC,
     &                CURTRA
      COMMON /T1TCOR/ XRVX,XRVY,YRVX,YRVY,RPICXR,RPICYR,RDEVXR,RDEVYR
      COMMON /T1TRNC/ SCALXC,SCALYC,ROTATC
C     COMMON /T1TRNB/ SCALXB,SCALYB,ROTATB
      COMMON /T1TRNS/ SCALXS,SCALYS,ROTATS,RDEVXS,RDEVYS
      COMMON /T1TRST/ SHIFT1,MTRAN1,KLIPM1,INDLVL
      COMMON /T1WNDO/ X1WND1,X2WND1,Y1WND1,Y2WND1
      COMMON /T3ERRS/ ERRON,NUMERR
      COMMON /T3LIMS/ IMAXI,RMAXI,RMINI
C
C
      IF (IFUNCO.LT.1.OR.IFUNCO.GT.17)  RETURN
      IF (IFUNCO.EQ.10.OR.IFUNCO.EQ.11) RETURN
      IF (IFUNCO.GT.4) GO TO 4
C
C          THE FIRST 4 FUNCTIONS SET THE MAPPING.
C
      MAPNO1= IFUNCO
      X1MAP1= RDATA(1)
      X2MAP1= RDATA(2)
      Y1MAP1= RDATA(3)
      Y2MAP1= RDATA(4)
C
C          THE CURRENT POSITIONS ARE RESET FOR A NEW MAP.
C
      XPLOT1= X1MAP1
      YPLOT1= Y1MAP1
      CALL G1LINE(0.0,0.0,.FALSE.)
      XCHAR= XPLOTB
      YCHAR= YPLOTB
C
C          THE NEW X AND Y MAPPING FACTORS ARE CALCULATED.
C
      IF (MAPNO1.EQ.3.OR.MAPNO1.EQ.4) GO TO 1
C
      ORIMX1= X1MAP1
      SCAMX1= 0.0
      IF (ABS(X2MAP1-X1MAP1).LT.RMINI) GO TO 2
C
      SCAMX1= 1.0/(X2MAP1-X1MAP1)
      GO TO 2
C
    1 IF (ABS(SIGN(1.0,X2MAP1)-SIGN(1.0,X1MAP1)).GE.RMINI) GO TO 901
C
      AB1MAP= ABS(X1MAP1)
      AB2MAP= ABS(X2MAP1)
      IF (AB1MAP.LT.RMINI.OR.AB2MAP.LT.RMINI) GO TO 901
C
      ORIMX1= ALOG(AB1MAP)
      DEXP= ALOG(AB2MAP)-ORIMX1
      IF (ABS(DEXP).LT.RMINI) GO TO 901
C
      SCAMX1= 1.0/DEXP
    2 IF (MAPNO1.EQ.2.OR.MAPNO1.EQ.4) GO TO 3
C
      ORIMY1= Y1MAP1
      SCAMY1= 0.0
      IF (ABS(Y2MAP1-Y1MAP1).LT.RMINI) RETURN
C
      SCAMY1= 1.0/(Y2MAP1-Y1MAP1)
      RETURN
C
    3 IF (ABS(SIGN(1.0,Y2MAP1)-SIGN(1.0,Y1MAP1)).GE.RMINI) GO TO 901
C
      AB1MAP= ABS(Y1MAP1)
      AB2MAP= ABS(Y2MAP1)
      IF (AB1MAP.LT.RMINI.OR.AB2MAP.LT.RMINI) GO TO 901
C
      ORIMY1= ALOG(AB1MAP)
      DEXP= ALOG(AB2MAP)-ORIMY1
      IF (ABS(DEXP).LT.RMINI) GO TO 901
C
      SCAMY1= 1.0/DEXP
      RETURN
C
    4 IFUNC= IFUNCO-4
      GO TO (7,8,9,10,11,10,11,12,13,16,17,18,19), IFUNC
C
C          THIS PART SETS THE WINDOW AREA.
C
    7 CALL G1MAPP(RDATA(1),RDATA(3),XVAL1,YVAL1,0)
      CALL G1MAPP(RDATA(2),RDATA(4),XVAL2,YVAL2,0)
      X1WND1= AMIN1(XVAL1,XVAL2)-0.00001
      X2WND1= AMAX1(XVAL1,XVAL2)+0.00001
      Y1WND1= AMIN1(YVAL1,YVAL2)-0.00001
      Y2WND1= AMAX1(YVAL1,YVAL2)+0.00001
      RETURN
C
C          THIS PART SETS THE NEXT MASKING AREA,
C          PROVIDED THE LEVEL DOES NOT EXCEED 10.
C
    8 IF (MSKLV1.GE.10) RETURN
      MSKLV1= MSKLV1+1
      CALL G1MAPP(RDATA(1),RDATA(3),XVAL1,YVAL1,0)
      CALL G1MAPP(RDATA(2),RDATA(4),XVAL2,YVAL2,0)
      X1MSK1(MSKLV1)= AMIN1(XVAL1,XVAL2)
      X2MSK1(MSKLV1)= AMAX1(XVAL1,XVAL2)
      Y1MSK1(MSKLV1)= AMIN1(YVAL1,YVAL2)
      Y2MSK1(MSKLV1)= AMAX1(YVAL1,YVAL2)
      RETURN
C
C          THIS SECTION SETS A NEW MASKING LEVEL,
C          PROVIDED IT IS IN THE RANGE [0 TO 10].
C
    9 IF (IDATA(1).LT.0.OR.IDATA(1).GT.10) RETURN
C
      MSKLV1= IDATA(1)
      RETURN
C
C          THIS SETS X AND Y SCALING FACTORS.
C
   10 IF (ABS(RDATA(1)).GE.RMINI) SCALXC= RDATA(1)
      IF (KFONT1.GE.101) THEN
        CALL G1HRDW(3)
        CALL G1HRDW(7)
      ENDIF
C
      GO TO 14
C
   11 IF (ABS(RDATA(1)).GE.RMINI) SCALYC= RDATA(1)
      IF (KFONT1.GE.101) THEN
        CALL G1HRDW(3)
        CALL G1HRDW(7)
      ENDIF
C
      GO TO 14
C
C          THIS SETS THE ROTATION FACTOR (RADIANS).
C
   12 ROTATC= RDATA(1)
      IF (KFONT1.GE.101) CALL G1HRDW(2)
      GO TO 14
C
C          THIS SETS THE DEVICE-REFERENCE-POINT. (WHEN
C          NO DATA IS GIVEN, IT FOLLOWS THE PICTURE ONE).
C
   13 SHIFT1= .FALSE.
      IF (LENGTH.EQ.0) GO TO 14
C
      RDEVXC= RDATA(1)
      RDEVYC= RDATA(2)
      SHIFT1= .TRUE.
C
C          THIS SECTION RECALCULATES CURRENT TRANS. COEFFICIENTS.
C          THE PICTURE-REFERENCE-POINT IS AT THE CURRENT POSITION.
C
   14 RPICXC= XPLOTB
      RPICYC= YPLOTB
      IF (SHIFT1) GO TO 15
      RDEVXC= RPICXC
      RDEVYC= RPICYC
   15 COSROC= COS(ROTATC)
      SINROC= SIN(ROTATC)
      XCCX=  SCALXC*COSROC
      XCCY= -SCALYC*SINROC
      YCCX=  SCALXC*SINROC
      YCCY=  SCALYC*COSROC
C
C          THE CURRENT POSITION IS RESET TO ENSURE CORRECT PLACING.
C
      CALL G1LINE(XPLOTB,YPLOTB,.FALSE.)
C
C          THIS PART CALCULATES A NEW CURRENT REVERSE TRANSFORM
C          WHENEVER THE PROGRAM-LEVEL CURRENT TRANSFORM IS CHANGED.
C
      IF (INDLVL.NE.0) RETURN
C
      TEMPX= XCCX*XCCX+YCCX*YCCX
      TEMPY= XCCY*XCCY+YCCY*YCCY
      XRVX=  XCCX/TEMPX
      XRVY= -XCCY/TEMPY
      YRVX= -YCCX/TEMPX
      YRVY=  YCCY/TEMPY
      RPICXR= RPICXC
      RPICYR= RPICYC
      RDEVXR= RDEVXC
      RDEVYR= RDEVYC
      RETURN
C
C          THIS SECTION PERFORMS A TRANSFORMATION INDENT.
C
   16 INDLVL= INDLVL+1
      TEMPX= RDEVXC-RPICXB
      TEMPY= RDEVYC-RPICYB
      RDEVXB= RDEVXB+(XCBX*TEMPX+XCBY*TEMPY)
      RDEVYB= RDEVYB+(YCBX*TEMPX+YCBY*TEMPY)
      RPICXB= RPICXC
      RPICYB= RPICYC
      XTEMPX= XCBX*XCCX+XCBY*YCCX
      XTEMPY= XCBX*XCCY+XCBY*YCCY
      YTEMPX= YCBX*XCCX+YCBY*YCCX
      YTEMPY= YCBX*XCCY+YCBY*YCCY
      XCBX= XTEMPX
      XCBY= XTEMPY
      YCBX= YTEMPX
      YCBY= YTEMPY
      SCALXS= SCALXC
      SCALYS= SCALYC
      ROTATS= ROTATC
      RDEVXS= RDEVXC
      RDEVYS= RDEVYC
      RDEVXC= 0.0
      RDEVYC= 0.0
      RPICXC= 0.0
      RPICYC= 0.0
      XCCX= 1.0
      XCCY= 0.0
      YCCX= 0.0
      YCCY= 1.0
      SCALXC= 1.0
      SCALYC= 1.0
      ROTATC= 0.0
      IF (KFONT1.GE.101) THEN
        CALL G1HRDW(3)
        CALL G1HRDW(7)
        CALL G1HRDW(2)
      ENDIF

      SHIFT1= .FALSE.
      RETURN
C
C          THIS SECTION PERFORMS A TRANSFORMATION UNDENT.
C
   17 INDLVL= INDLVL-1
      SCALXC= SCALXS
      SCALYC= SCALYS
      ROTATC= ROTATS
      IF (KFONT1.GE.101) THEN
        CALL G1HRDW(3)
        CALL G1HRDW(7)
        CALL G1HRDW(2)
      ENDIF

      COSROC= COS(ROTATC)
      SINROC= SIN(ROTATC)
      XCCX=  SCALXC*COSROC
      XCCY= -SCALYC*SINROC
      YCCX=  SCALXC*SINROC
      YCCY=  SCALYC*COSROC
      RPICXC= RPICXB
      RPICYC= RPICYB
      RDEVXC= RDEVXS
      RDEVYC= RDEVYS
      XTEMPX= XCBX*COSROC/SCALXC-XCBY*SINROC/SCALYC
      XTEMPY= XCBY*COSROC/SCALYC+XCBX*SINROC/SCALXC
      YTEMPX= YCBX*COSROC/SCALXC-YCBY*SINROC/SCALYC
      YTEMPY= YCBY*COSROC/SCALYC+YCBX*SINROC/SCALXC
      XCBX= XTEMPX
      XCBY= XTEMPY
      YCBX= YTEMPX
      YCBY= YTEMPY
C
C          THE NEW SAVED VALUES ARE TAKEN FROM THE INPUT DATA.
C
      SCALXS= RDATA(1)
      SCALYS= RDATA(2)
      ROTATS= RDATA(3)
      RDEVXS= RDATA(4)
      RDEVYS= RDATA(5)
C
C          THE NEW BASE REFERENCE-POINTS ARE FOUND. (THE DEVICE
C          ONE IS A KNOWN POSITION WHEN GOING TO PICTURE-LEVEL 0).
C
      RPICXB= RDATA(6)
      RPICYB= RDATA(7)
      TEMPX= RDEVXC-RPICXB
      TEMPY= RDEVYC-RPICYB
      RDEVXB= RDEVXB-(XCBX*TEMPX+XCBY*TEMPY)
      RDEVYB= RDEVYB-(YCBX*TEMPX+YCBY*TEMPY)
      IF (INDLVL.GT.0) RETURN
C
      RDEVXB= 0.0
      RDEVYB= 0.0
      RETURN
C
C          THIS SETS THE CLIPPING-AREA TRANSFORMATION MODE.
C
   18 KLIPM1= IDATA(1)
      RETURN
C
C          THIS SETS THE TRANSFORMATION RANGE. THE CURRENT
C          TRANSFORMATION STATE IS SET ACCORDINGLY. THE
C          POSITION IS REAFFIRMED TO ENSURE CORRECT PLACING.
C
   19 MTRAN1= IDATA(1)
      CURTRA= .TRUE.
      IF (MTRAN1.EQ.0.OR.MTRAN1.EQ.2) CURTRA= .FALSE.
C
      CALL G1LINE(XPLOTB,YPLOTB,.FALSE.)
      RETURN
C
C          THIS SECTION IS FOR LOG.-MAPPING ERRORS.
C
  901 SCAMX1= 0.0
      SCAMY1= 0.0
      VALIM= 1.0
      IF (ABS(X2MAP1).GE.RMINI) VALIM= SIGN(VALIM,X2MAP1)
      IF (ABS(X1MAP1).GT.RMINI) VALIM= SIGN(VALIM,X1MAP1)
C
      X1MAP1= VALIM
      ORIMX1= VALIM
      VALIM= 1.0
      IF (ABS(Y2MAP1).GE.RMINI) VALIM= SIGN(VALIM,Y2MAP1)
      IF (ABS(Y1MAP1).GE.RMINI) VALIM= SIGN(VALIM,Y1MAP1)
C
      Y1MAP1= VALIM
      ORIMY1= VALIM
      NUMERR= 1001
      IF (.NOT.ERRON) RETURN
C
      CALL G1FILB(0,0,-84,0)
      CALL G1ERMS
C
      RETURN
      END

max_stars_repo_name: ZedThree/GHOST

max_issues_repo_name: ZedThree/GHOST

max_forks_repo_name: ZedThree/GHOST


PROGRAM CALLF2
  IMPLICIT NONE

  INTERFACE
     SUBROUTINE F2( N, M )
       INTEGER, INTENT( IN )  :: N
       INTEGER, INTENT( OUT ) :: M
     END SUBROUTINE F2
  END INTERFACE

  INTEGER :: NB, RES
  NB = 8
  CALL F2( NB, RES )

END PROGRAM


text:
!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     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, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     this function enable to determine the discharge coefficient of
!     preswirl nozzles
!
!     author: Yannick Muller
!
      subroutine cd_preswirlnozzle(ps2,pt1,number,curve,x_tab,y_tab,cd)
!
!
!     in : SImultation of the secondary air system of aero engines
!          K.J.KUTZ T.M. SPEER
!          Transactions of the ASME vol.116 April 1994
!
      implicit none
!
      integer id,number,curve,n11
!
      real*8 x_tab(15),y_tab(15)
!
      real*8 cdxp(11)
      data cdxp
     &     /0.4d0,0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0,
     &      0.80d0,0.85d0,0.90d0/
!
      real*8 cdyp(11)
      data cdyp
     &     /0.942d0,0.939d0,0.932d0,0.929d0,0.925d0,0.921d0,0.917d0,
     &      0.910d0,0.899d0,0.881d0,0.873d0/
!
      data n11 /11/
!
!     determination of cd with the caracteristics by interpolation
!
      real*8 ps2,pt1,ps2vpt1,cd
!
      ps2vpt1=ps2/pt1
      if(number.eq.0) then
         call ident(cdxp,ps2vpt1,n11,id)
         if(id.eq.0.6d0) then
            cd=cdyp(1)
         elseif(id.ge.1) then
            cd=cdyp(11)
         else
            cd=cdyp(id)+(cdyp(id+1)-cdyp(id))
     &           *(ps2vpt1-cdxp(id))/(cdxp(id+1)-cdxp(id))
         endif
      else
         call ident(x_tab,ps2vpt1,number,id)
         if(id.le.1d0) then
            cd=y_tab(1)
         elseif(id.ge.15) then
            cd=y_tab(15)
         else
            cd=y_tab(id)+(y_tab(id+1)-y_tab(id))
     &           *(ps2vpt1-x_tab(id))/(x_tab(id+1)-x_tab(id))
         endif
      endif
!
      return
      end

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
      program external07

C     Check the type consistency check option: PARSER_TYPE_CHECK_CALL_SITES
C     (it does not seem to work)
C     Check two parsing orders: F before or after EXTERNAL07
C     When F is called first, MakeAtom understands "call g(f)" as call "g(f())"

      external f

      call g(f)

      call f(i, j)

      call h

      end

      subroutine f(i)

      print *, i

      end

      subroutine h
      stop
      end


text:
!
! This files tests halting failure in FrontEnd where
! the FrontEnd repeatedly prints "Parser exiting normally"
! without halting.
!
include "bug-3053141_inc.f90"


text:
! Copyright (c), The Regents of the University of California
! Terms of use are as specified in LICENSE.txt
module normal_termination_m
    implicit none
    private
    public :: caf_stop

    interface caf_stop

      module subroutine caf_stop_integer(stop_code)
        !! synchronize, stop the executing image, and provide the stop_code (or 0 if not present) as the process exit status
        integer, intent(in), optional :: stop_code
      end subroutine

      module subroutine caf_stop_character(stop_code)
        !! synchronize, stop the executing image, and provide the stop_code as the process exit status
        character(len=*), intent(in) :: stop_code
      end subroutine

    end interface

end module normal_termination_m

max_stars_repo_name: BerkeleyLab/caffeine

max_issues_repo_name: BerkeleyLab/caffeine

max_forks_repo_name: BerkeleyLab/caffeine


text:
   program crosssections

    use timer
    use accuracy
    !
    use spectrum,only : Readinput,verbose,intensity
     !
     if (verbose>=1) call TimerStart('Spectrum')
     !
     ! initializing some constants
     !
     call accuracyInitialize
     !
     ! read input data
     !
     call ReadInput
     !
     call intensity
     !
     if (verbose>=1) call MemoryReport
     !
     if (verbose>=1) call TimerStop('Spectrum')
     !
     if (verbose>=1) call TimerReport
     !
    end program crosssections

max_stars_repo_name: ideasrule/exocross

max_issues_repo_name: ideasrule/exocross

max_forks_repo_name: ideasrule/exocross


text:
! Sieve of Eratosthenes Fortran 95 Module
module sieve
   implicit none
   contains
      subroutine smsv(n, parr, cnt)
         ! find and count the prime nos. <= n
         ! dummy arguments
         integer, intent(in) :: n
         integer, intent(out), dimension(:) :: parr
         integer, intent(out) :: cnt
         ! local data
         integer :: i, j
         logical, dimension(n) :: sv
         ! processing
         sv(1) = .false.
         sv(2:) = .true.
         do i = 2, int(sqrt(real(n)))
            do j = i*i, n, i
               sv(j) = .false.
            end do
         end do
         cnt = 0
         do i = 2, n
            if (sv(i)) then
               cnt = cnt+1
               parr(cnt) = i
            end if
         end do
      end subroutine smsv

      subroutine cmpseg(lo, hi, n, p, s)
         ! dummy argumentes
         integer, intent(in) :: lo, hi, n
         integer, intent(in), dimension(n) :: p
         logical, intent(out), dimension(hi-lo+1) :: s
         ! local data
         integer :: i, j, k
         ! processing
         s = .true.
         do i = 1, n
            j = (lo/p(i))*p(i)
            !j = lo-mod(lo, p(i))
            if (j < lo) j = j+p(i)
            do k = j, hi, p(i)
               s(k-lo+1) = .false.
            end do
         end do
      end subroutine cmpseg

      subroutine sgsv(n, parr, cnt)
         ! find and count the prime nos. <= n
         ! dummy arguments
         integer, intent(in) :: n
         integer, intent(out), dimension(:) :: parr
         integer, intent(out) :: cnt
         ! local data
         integer :: i, ssiz, psiz, lo, hi
         logical, dimension(int(sqrt(real(n)))+1) :: sieve
         ! processing
         ! compute base primes
         ssiz = int(sqrt(real(n)))+1
         call smsv(ssiz, parr, cnt)
         psiz = cnt
         ! compute subsequent segments
         do lo = ssiz+1, n, ssiz
            ! compute current segment
            hi = min(lo+ssiz-1, n)
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! compute and count primes found in current segement
            do i = lo, hi
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  parr(cnt) = i
               end if
            end do
         end do
      end subroutine sgsv

      subroutine pp(n)
         ! print the primes p where p <= n
         ! dummy argument
         integer, intent(in) :: n
         ! local data
         integer :: i, cnt, ssiz, psiz, lo, hi
         integer, dimension(npub(int(sqrt(real(n)))+1)) :: parr
         logical, dimension(int(sqrt(real(n)))+1) :: sieve
         ! processing
         print *, size(sieve), size(parr)
         ssiz = int(sqrt(real(n))) + 1
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         do i = 1, min(cnt, n)
            write (*,'(i12)',advance='no') parr(i)
            if (mod(i, 6) == 0) print *,
         end do
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         do lo = ssiz+1, n, ssiz
            ! compute the next sieve segment
            hi = min(lo+ssiz-1, n)
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! print primes in segment above
            do i = lo, hi
               if (i > n) then
                  print *,
                  return
               end if
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  write (*,'(i12)',advance='no') i
                  if (mod(cnt, 6) == 0) print *,
               end if
            end do
         end do
         if (mod(cnt, 6) /= 0) print *,
      end subroutine pp

      subroutine gaps()
         ! local data
         integer, parameter :: SIZ = 2**34
         integer :: i, gap, maxgap, p1, p2, psiz, ssiz, lo, hi
         integer, dimension(npub(SIZ)) :: p
         logical, dimension(int(sqrt(real(SIZ)))) :: seg
         ! processing
         ssiz = int(sqrt(real(SIZ)))
         call smsv(ssiz, p, psiz)
         maxgap = 0
         do i = 2, psiz
            gap = p(i)-p(i-1)-1
            if (gap > maxgap) then
               print *, p(i-1), p(i), gap
               maxgap = gap
            end if
         end do
         p1 = p(psiz)
         do lo = ssiz+1, SIZ, ssiz
            hi = min(lo+ssiz-1, SIZ)
            call cmpseg(lo, hi, psiz, p, seg)
            do i = lo, hi
               if (seg(i-lo+1)) then
                  p2 = i
                  gap = p2-p1-1
                  if (gap > maxgap) then
                     print *, p1, p2, gap
                     maxgap = gap
                  end if
                  p1 = p2
               end if
            end do
         end do
      end subroutine gaps

      ! number theoretic size of logical array allocation on the stack
      function np(n) result(parr)
         ! find and return the first n prime nos.
         ! dummy arguments
         integer, intent(in) :: n
         ! function result
         integer, dimension(npub(nthpub(n))) :: parr
         ! local variables
         integer :: i, ssiz, psiz, cnt, lo, hi
         logical, dimension(nthpub(n)) :: sieve
         ! processing
         ssiz = nthpub(n)
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         lo = ssiz+1
         do
            ! compute current segment
            hi = lo+ssiz-1
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! compute the primes in the segment above
            do i = 1, ssiz
               if (sieve(i)) then
                  cnt = cnt+1
                  parr(cnt) = lo+i-1
                  if (cnt == n) return
               end if
            end do
            lo = lo+ssiz
         end do
      end function np

      function nthp(n) result(p)
         ! find and return the nth prime no. p
         ! dummy arguments
         integer, intent(in) :: n
         ! function result location
         integer :: p
         ! local data
         integer :: i, ssiz, psiz, cnt, lo, hi
         integer, dimension(npub(nthpub(n))) :: parr
         logical, dimension(nthpub(n)) :: sieve
         ! processing
         ssiz = nthpub(n)
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         if (cnt > n) then
            p = parr(n)
            return
         end if
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         lo = ssiz+1
         do
            ! compute the next sieve segment
            hi = lo+ssiz-1
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! count primes found in current sieve segment
            do i = lo, hi
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  if (cnt == n) then
                     p = i
                     return
                  end if
               end if
            end do
         lo = lo+ssiz
         end do
      end function nthp

      ! auxiliary pure functions return sizes for automatic array allocation
      pure function nthpub(n) result(ub)
         ! dummy argument
         integer, intent(in) :: n
         ! function result location
         integer :: ub
         ! processing
         ub = INT(SQRT(n*LOG(REAL(n)) + n*LOG(LOG(REAL(n)))))+1
      end function nthpub

      pure function npub(n) result(ub)
         ! dummy argument
         integer, intent(in) :: n
         ! function result location
         integer :: ub
         ! processing
         ub = INT(1.25506*(n/LOG(REAL(n))))
      end function npub
end module sieve

max_stars_repo_name: joshroybal/fortran-sieve

max_issues_repo_name: joshroybal/fortran-sieve

max_forks_repo_name: joshroybal/fortran-sieve


text:
c-----------------------------------------------------------------------
      subroutine scanout(string,input,len,infile,outfile)
c
c     scan through infile until input is found and output
c     all lines save that containing input to "outfile"
c
      character*80 string
      character*1 input(1)
      integer infile,outfile
c
      character*1 string1(80)
c
      do line=1,100000
         call blank(string,80)
         read (infile ,80,end=100,err=100) string
c        write(6,*) string
         if (indx1(string,input,len).ne.0) return
         call chcopy(string1,string,80)
         lout = ltrunc(string1,80)
         write (outfile,81) (string1(j),j=1,lout)
      enddo
   80 format(a80)
   81 format(80a1)
c
 100  continue
      return
      end

c-----------------------------------------------------------------------
      subroutine scanoutafter(string,input,len,infile,outfile)
c
c     scan through infile until input is found and output
c     all lines after save that containing input to "outfile"
c
      character*80 string
      character*1 input(1)
      integer infile,outfile
c
      character*1 string1(80)
c
      do line=1,100000
         call blank(string,80)
         read (infile ,80,end=100,err=100) string
         if (indx1(string,input,len).ne.0) return
         call chcopy(string1,string,80)
         lout = ltrunc(string1,80)
         write (outfile,81) (string1(j),j=1,lout)
      enddo
   80 format(a80)
   81 format(80a1)
c
 100  continue
      return
      end

c-----------------------------------------------------------------------
      subroutine copy8(a,b,n)
      real*8 a(1)
      real*8 b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine copy(a,b,n)
      real a(1), b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine copy48(a,b,n)
      real*8 a(1)
      real*4 b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine icopy(a,b,n)
      integer a(1), b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine chcopy(a,b,n)
      character*1 a(1), b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine copyi4(a,b,n)
      integer a(1)
      real*8  b(1)
      do 100 i = 1, n
 100     a(i) = b(i)
      return
      end
c-----------------------------------------------------------------------
      subroutine blank(s,n)
      character*1 s(1)
      do i=1,n
        s(i)=' '
      enddo
      return
      end
c-----------------------------------------------------------------------
c     comes from n2to3
      function ltrunc(s,n)
      character*1 s(1)
      ltrunc = 0
      do j=n,1,-1
         if (s(j).ne.' ') then
            ltrunc = j
            return
         endif
      enddo
      return
      end
c-----------------------------------------------------------------------
c     comes from n2to3
      INTEGER FUNCTION INDX1(S1,S2,L2)
      CHARACTER*80 S1,S2
C
      N1=80-L2+1
      INDX1=0
      IF (N1.LT.1) RETURN
C
      DO 300 I=1,N1
         I2=I+L2-1
         IF (S1(I:I2).EQ.S2(1:L2)) THEN
            INDX1=I
            RETURN
         ENDIF
300   CONTINUE
C
      RETURN
      END
c-----------------------------------------------------------------------
c     comes from n2to3
      subroutine rzero(x,n)
      real x(1)
      do i=1,n
         x(i) = 0.0
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine izero(x,n)
      integer x(1)
      do i=1,n
         x(i) = 0
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine lineout(io,s,n)
      character*1 s(n)
      m = ltrunc(s,n)
      write(io,1) (s(k),k=1,m)
    1 format(132a1)
      return
      end
c-----------------------------------------------------------------------
      subroutine fbyte_write(s,n)
      character*4 s(n)

      common /byte_flag/ ifbyte
      logical ifbyte

      if (ifbyte) then
         call byte_write(s,n)
      else
         call lineout(6,s,n)
      endif

      return
      end
c-----------------------------------------------------------------------

max_stars_repo_name: RonRahaman/nekRS

max_issues_repo_name: neams-th-coe/nekRS

max_forks_repo_name: neams-th-coe/nekRS


text:
 subroutine apply_solar_spectrum( &
   ngeomax,       nwave_fine,             nsmax,                 &
   ns_elas,       dnu,                    wavenr_fine,           &
   nwave_aux,     wavenr_aux,             solar_irradiance_aux,  &
   R_final_fine,  solar_irradiance_fine,  earth_radiance_fine)

!-----------------------------------------------------------
! Subroutine:
!
! Purpose:
!
! Output:
!
!-----------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8) !double precision

  integer,intent(in):: &
    ngeomax,  &
    nwave_fine, &
    nwave_aux, &
    nsmax, &
    ns_elas

  real(kind=dp),intent(in):: &
    wavenr_fine(nwave_fine),             &
    wavenr_aux(nwave_aux),     &
    solar_irradiance_aux(nwave_aux), &
    dnu,              &
    R_final_fine(0:nsmax,nwave_fine,ngeomax), &
    solar_irradiance_fine(nwave_fine)

  integer::iv,n,ns,nsp,naux

  real(kind=dp):: &
    wavenr_fine_ns(0:nsmax), &
    wavenr_fineshift_ns(0:nsmax), &
    wavelength_ns(0:nsmax), &
    fsun_ns(0:nsmax)

  real(kind=dp),intent(out):: &
    earth_radiance_fine(nwave_fine,ngeomax)

  do n=1,nwave_fine

     naux = n+nsmax !points to naux index for each n

     do ns=0,nsmax

        wavenr_fineshift_ns(ns) = dble(-nsmax/2+ns) * dnu
        wavenr_fine_ns(ns) = wavenr_fine(n) + wavenr_fineshift_ns(ns)

!       nsp = -nsmax/2+ns+n !points to ns index for each n
!       fsun_ns(ns) = 0.d0 !zero if outside range
!       if((nsp.ge.1).and.(nsp.le.nwave_fine)) &
!           fsun_ns(ns) = solar_irradiance_fine(nsp)

        nsp = -nsmax/2+ns+naux !points to ns index for each naux
        fsun_ns(ns) = 0.d0 !zero if outside range
        if((nsp.ge.1).and.(nsp.le.nwave_aux)) &
            fsun_ns(ns) = solar_irradiance_aux(nsp)

     enddo

     do iv=1,ngeomax
        earth_radiance_fine(n,iv) = 0.d0
        do ns=0,nsmax
           earth_radiance_fine(n,iv) = &
              earth_radiance_fine(n,iv) + &
                 R_final_fine(ns,n,iv) * fsun_ns(ns) !* dnu
        enddo
     enddo

!    force elastic scattering
!    do iv=1,ngeomax
!       earth_radiance_fine(n,iv) = 0.d0
!       do ns=ns_elas,ns_elas
!          earth_radiance_fine(n,iv) = &
!            earth_radiance_fine(n,iv) + &
!              R_final_fine(ns,n,iv) * fsun_ns(ns) !* dnu
!       enddo
!    enddo

  enddo

  return
  end subroutine apply_solar_spectrum

max_stars_repo_name: rutgervandeelen/das

max_issues_repo_name: rutgervandeelen/das

max_forks_repo_name: rutgervandeelen/das