text:
C
C	$Id: setrng.f,v 1.4 2008-07-27 00:59:05 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE SETRNG(IOS,STATUS)
C
C  SET THE RANGE INFO IF THE USER WANTS TO USE SOME SCALING OPTION
C
C  OUTPUT
C       IOS- THE I/O STATUS VALID WHEN STATUS SET TO AN I/O ERROR
C       STATUS-THE ERROR STATUS DEFINED BY COMMON TREROR
C
C
C
      COMMON/TREROR/ ALLOK, MFRCHK, MTOPER, METRDC, REDERR, TYPCHG
     1             ,INVTYP, MINVLD, TYPERR, FRMEND, ENCINT, IVDCDT
     2             ,GCOERR, GCRERR, GCCERR, FCOERR, FCRERR, FCCERR
     3             ,PLIDXG, PMIDXG, TXIDXG, PGIDXG, INVLMT, CELERR
     4             ,COIERR, COLNRM, UNKNOW, UNKOPC, ENDMTF, VNEROR
     5             ,BADRSZ, DEVOUT, NOVERS, BADFNT, PGMERR, FASERR
     6             ,HINERR, VDWERR, RDWERR, RIXLIM
      INTEGER        ALLOK, MFRCHK, MTOPER, METRDC, REDERR, TYPCHG
     1             ,INVTYP, MINVLD, TYPERR, FRMEND, ENCINT, IVDCDT
     2             ,GCOERR, GCRERR, GCCERR, FCOERR, FCRERR, FCCERR
     3             ,PLIDXG, PMIDXG, TXIDXG, PGIDXG, INVLMT, CELERR
     4             ,COIERR, COLNRM, UNKNOW, UNKOPC, ENDMTF, VNEROR
     5             ,BADRSZ, DEVOUT, NOVERS, BADFNT, PGMERR, FASERR
     6             ,HINERR, VDWERR, RDWERR, RIXLIM
      COMMON /TRINST/ OPCL, OPID, LEN, CONT
      INTEGER OPCL, OPID, LEN
      LOGICAL CONT
      COMMON /TRMTYP/ FOURBT, MULTBT, TWOBT, PTSFLG, CURCOL, IPWRIT,
     1                IFRAME, ISETOP, IRANG, IPTS, ICAS, IINT, IORNT,
     2                ISIZE, IFONT, IPAT, ISSIZ, ICENT, ICOLR,
     3                MCENT, MSIZE, MOR, OLDX, OLDY, MCASE, MINTEN,
     4                MFONT, MDASH, MSPOT, MCOLOR, MLIMIT, PTSYM,
     5                SAVX, SAVY
      INTEGER FOURBT, MULTBT, TWOBT, PTSFLG, CURCOL, IPWRIT,
     1                IFRAME, ISETOP, IRANG, IPTS, ICAS, IINT, IORNT,
     2                ISIZE, IFONT, IPAT, ISSIZ, ICENT, ICOLR,
     3                MCENT, MSIZE, MOR, OLDX, OLDY, MCASE, MINTEN,
     4                MFONT, MDASH, MSPOT, MCOLOR(3), MLIMIT(4), PTSYM,
     5                SAVX, SAVY
C
      INTEGER IOS, STATUS
      INTEGER BYTE8, W16, K
C
C  DEFINE THE BYTE SIZE FOR COUNT AND OPTION CODE
C
      DATA BYTE8/8/,W16/16/
C
C  INITIALIZE THE STATUS FIELD TO ALL OK
C
      STATUS = ALLOK
C
C  SKIP OVER THE NEXT BYTE THEN READ IN THE NEXT 4 16 BIT PACKETS
C
      CALL MNINST(BYTE8,IOS,STATUS)
      DO 100 K = 1,4
        CALL MNINST(W16,IOS,STATUS)
        MLIMIT(K) = OPCL
        IF (STATUS.NE.ALLOK) RETURN
 100  CONTINUE
C
      RETURN
      END


text:
!> Main module file for the {{cookiecutter.project_name|lower}} library
module {{cookiecutter.project_name|lower}}
  use {{cookiecutter.project_name|lower}}_version, only : get_version
  implicit none

  private
  public :: get_version

end module {{cookiecutter.project_name|lower}}

max_stars_repo_name: aradi/cookiecutter-fortran-cmake

max_issues_repo_name: aradi/cookiecutter-fortran-cmake

max_forks_repo_name: aradi/cookiecutter-fortran-cmake


program test_math_angle
    use forlab_math, only: angle
    use stdlib_kinds, only: sp
    implicit none
    complex(sp) :: c, cX(2)

    c = (1.0, 2.0)
    cX = (2.0, 3.0)

    print *, angle(c)
    print *, angle(cX)

end program test_math_angle


!
!     ------------------------------------------------------------------
!       I N T A C T
!     ------------------------------------------------------------------
!
      SUBROUTINE INTACT(L, LP, IEQUIV)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE ENAV_C
      USE EAV_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE rme_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: L
      INTEGER  :: LP
      INTEGER , INTENT(IN) :: IEQUIV
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , DIMENSION(0:4) :: ICBPTR
      INTEGER :: I, K, L1, L2
!-----------------------------------------------
      DATA ICBPTR/ 1, 6, 14, 23, 31/
!
!     THIS SUBROUTINE GIVES THE INTERACTION ENERGY BETWEEN TWO SHELLS,
!     ONE WITH ORBITAL ANGULAR MOMENTUM  L , THE OTHER WITH ORBITAL
!     ANGULAR MOMENTUM  LP .   NOTICE THAT THE FIRST TERM OF THIS
!     INTERACTION ENERGY IS ALWAYS   F0(L,LP)   AND THIS IS NOT GIVEN
!     IN THIS SUBROUTINE.   THUS ONLY THE EXTRA TERMS ARE HERE PRODUCED.
!     FOR EQUIVALENT ELECTRONS (IEQUIV = 1) ,  THERE WILL BE  FK
!     INTEGRALS ONLY.   FOR NON-EQUIVALENT ELECTRONS (IEQUIV = 2) ,
!     THERE WILL BE  GK  INTEGRALS ONLY.
!
!     THE EXPRESSIONS FOR THE INTERACTION ENERGIES ARE GIVEN BY
!     R. D. COWAN, THE THEORY OF ATOMIC SPECTRA, EQUATIONS (6.38)
!      AND (6.39).
!
      I = 0
      IF (IEQUIV == 1) THEN
         DO K = 2, 2*L, 2
            I = I + 1
            KVALUE(I) = K
            IF (L <= 4) THEN
               COEFCT(I) = -CCA((L*(L-1)+K)/2)
            ELSE
               COEFCT(I) = -RME(L,L,K)**2/((2*L + 1)*(4*L + 1))
            ENDIF
         END DO
      ELSE
         DO K = IABS(L - LP), L + LP, 2
            I = I + 1
            KVALUE(I) = K
            IF (L <= LP) THEN
               L1 = L
               L2 = LP
            ELSE
               L1 = LP
               L2 = L
            ENDIF
            IF (L2 <= 4) THEN
               COEFCT(I) = -CCB(ICBPTR(L1)+(K+L1-L2)/2+(L1+1)*(L2-L1))
            ELSE
               COEFCT(I) = -RME(L,LP,K)**2/(2*(2*L + 1)*(2*LP + 1))
            ENDIF
         END DO
      ENDIF
      NINTS = I
      RETURN
      END SUBROUTINE INTACT


text:
 ! helm results

 integer, parameter ::  &
            &   h_ptot = 1, &
            &   h_dpt = 2,  &
            &   h_dpd = 3,  &
            &   h_dpa = 4,  &
            &   h_dpz = 5,  &
            &   h_dpdd = 6, &
            &   h_dpdt = 7, &
            &   h_dpda = 8, &
            &   h_dpdz = 9, &
            &   h_dptt = 10,    &
            &   h_dpta = 11,    &
            &   h_dptz = 12,    &
            &   h_dpaa = 13,    &
            &   h_dpaz = 14,    &
            &   h_dpzz = 15

 integer, parameter ::  &
            &   x_p = 15

 integer, parameter ::  &
            &   h_etot = x_p + 1,   &
            &   h_det = x_p + 2,    &
            &   h_ded = x_p + 3,    &
            &   h_dea = x_p + 4,    &
            &   h_dez = x_p + 5,    &
            &   h_dedd = x_p + 6,   &
            &   h_dedt = x_p + 7,   &
            &   h_deda = x_p + 8,   &
            &   h_dedz = x_p + 9,   &
            &   h_dett = x_p + 10,  &
            &   h_deta = x_p + 11,  &
            &   h_detz = x_p + 12,  &
            &   h_deaa = x_p + 13,  &
            &   h_deaz = x_p + 14,  &
            &   h_dezz = x_p + 15

 integer, parameter ::  &
            &   x_e = x_p + 15

 integer, parameter ::  &
            &   h_stot = x_e + 1,   &
            &   h_dst = x_e + 2,    &
            &   h_dsd = x_e + 3,    &
            &   h_dsa = x_e + 4,    &
            &   h_dsz = x_e + 5,    &
            &   h_dsdd = x_e + 6,   &
            &   h_dsdt = x_e + 7,   &
            &   h_dsda = x_e + 8,   &
            &   h_dsdz = x_e + 9,   &
            &   h_dstt = x_e + 10,  &
            &   h_dsta = x_e + 11,  &
            &   h_dstz = x_e + 12,  &
            &   h_dsaa = x_e + 13,  &
            &   h_dsaz = x_e + 14,  &
            &   h_dszz = x_e + 15

 integer, parameter ::  &
            &   x_s = x_e + 15

 !..radiation contributions
 integer, parameter ::  &
            &   h_prad = x_s + 1,   &
            &   h_dpradt = x_s + 2, &
            &   h_dpradd = x_s + 3, &
            &   h_dprada = x_s + 4, &
            &   h_dpradz = x_s + 5, &
            &   h_dpraddd = x_s + 6,    &
            &   h_dpraddt = x_s + 7,    &
            &   h_dpradda = x_s + 8,    &
            &   h_dpraddz = x_s + 9,    &
            &   h_dpradtt = x_s + 10,   &
            &   h_dpradta = x_s + 11,   &
            &   h_dpradtz = x_s + 12,   &
            &   h_dpradaa = x_s + 13,   &
            &   h_dpradaz = x_s + 14,   &
            &   h_dpradzz = x_s + 15

 integer, parameter ::  &
            &   x_pr = x_s + 15

 integer, parameter ::  &
            &   h_erad = x_pr + 1,  &
            &   h_deradt = x_pr + 2,    &
            &   h_deradd = x_pr + 3,    &
            &   h_derada = x_pr + 4,    &
            &   h_deradz = x_pr + 5,    &
            &   h_deraddd = x_pr + 6,   &
            &   h_deraddt = x_pr + 7,   &
            &   h_deradda = x_pr + 8,   &
            &   h_deraddz = x_pr + 9,   &
            &   h_deradtt = x_pr + 10,  &
            &   h_deradta = x_pr + 11,  &
            &   h_deradtz = x_pr + 12,  &
            &   h_deradaa = x_pr + 13,  &
            &   h_deradaz = x_pr + 14,  &
            &   h_deradzz = x_pr + 15

 integer, parameter ::  &
            &   x_er = x_pr + 15

 integer, parameter ::  &
            &   h_srad = x_er + 1,  &
            &   h_dsradt = x_er + 2,    &
            &   h_dsradd = x_er + 3,    &
            &   h_dsrada = x_er + 4,    &
            &   h_dsradz = x_er + 5,    &
            &   h_dsraddd = x_er + 6,   &
            &   h_dsraddt = x_er + 7,   &
            &   h_dsradda = x_er + 8,   &
            &   h_dsraddz = x_er + 9,   &
            &   h_dsradtt = x_er + 10,  &
            &   h_dsradta = x_er + 11,  &
            &   h_dsradtz = x_er + 12,  &
            &   h_dsradaa = x_er + 13,  &
            &   h_dsradaz = x_er + 14,  &
            &   h_dsradzz = x_er + 15

 integer, parameter ::  &
            &   x_sr = x_er + 15

 !..gas contributions
 integer, parameter ::  &
            &   h_pgas = x_sr + 1,  &
            &   h_dpgast = x_sr + 2,    &
            &   h_dpgasd = x_sr + 3,    &
            &   h_dpgasa = x_sr + 4,    &
            &   h_dpgasz = x_sr + 5,    &
            &   h_dpgasdd = x_sr + 6,   &
            &   h_dpgasdt = x_sr + 7,   &
            &   h_dpgasda = x_sr + 8,   &
            &   h_dpgasdz = x_sr + 9,   &
            &   h_dpgastt = x_sr + 10,  &
            &   h_dpgasta = x_sr + 11,  &
            &   h_dpgastz = x_sr + 12,  &
            &   h_dpgasaa = x_sr + 13,  &
            &   h_dpgasaz = x_sr + 14,  &
            &   h_dpgaszz = x_sr + 15

 integer, parameter ::  &
            &   x_pg = x_sr + 15

 integer, parameter ::  &
            &   h_egas = x_pg + 1,  &
            &   h_degast = x_pg + 2,    &
            &   h_degasd = x_pg + 3,    &
            &   h_degasa = x_pg + 4,    &
            &   h_degasz = x_pg + 5,    &
            &   h_degasdd = x_pg + 6,   &
            &   h_degasdt = x_pg + 7,   &
            &   h_degasda = x_pg + 8,   &
            &   h_degasdz = x_pg + 9,   &
            &   h_degastt = x_pg + 10,  &
            &   h_degasta = x_pg + 11,  &
            &   h_degastz = x_pg + 12,  &
            &   h_degasaa = x_pg + 13,  &
            &   h_degasaz = x_pg + 14,  &
            &   h_degaszz = x_pg + 15

 integer, parameter ::  &
            &   x_eg = x_pg + 15

 integer, parameter ::  &
            &   h_sgas = x_eg + 1,  &
            &   h_dsgast = x_eg + 2,    &
            &   h_dsgasd = x_eg + 3,    &
            &   h_dsgasa = x_eg + 4,    &
            &   h_dsgasz = x_eg + 5,    &
            &   h_dsgasdd = x_eg + 6,   &
            &   h_dsgasdt = x_eg + 7,   &
            &   h_dsgasda = x_eg + 8,   &
            &   h_dsgasdz = x_eg + 9,   &
            &   h_dsgastt = x_eg + 10,  &
            &   h_dsgasta = x_eg + 11,  &
            &   h_dsgastz = x_eg + 12,  &
            &   h_dsgasaa = x_eg + 13,  &
            &   h_dsgasaz = x_eg + 14,  &
            &   h_dsgaszz = x_eg + 15

 integer, parameter ::  &
            &   x_sg = x_eg + 15

 !..ion contributions
 integer, parameter ::  &
            &   h_pion = x_sg + 1,  &
            &   h_dpiont = x_sg + 2,    &
            &   h_dpiond = x_sg + 3,    &
            &   h_dpiona = x_sg + 4,    &
            &   h_dpionz = x_sg + 5,    &
            &   h_dpiondd = x_sg + 6,   &
            &   h_dpiondt = x_sg + 7,   &
            &   h_dpionda = x_sg + 8,   &
            &   h_dpiondz = x_sg + 9,   &
            &   h_dpiontt = x_sg + 10,  &
            &   h_dpionta = x_sg + 11,  &
            &   h_dpiontz = x_sg + 12,  &
            &   h_dpionaa = x_sg + 13,  &
            &   h_dpionaz = x_sg + 14,  &
            &   h_dpionzz = x_sg + 15

 integer, parameter ::  &
            &   x_pi = x_sg + 15

 integer, parameter ::  &
            &   h_eion = x_pi + 1,  &
            &   h_deiont = x_pi + 2,    &
            &   h_deiond = x_pi + 3,    &
            &   h_deiona = x_pi + 4,    &
            &   h_deionz = x_pi + 5,    &
            &   h_deiondd = x_pi + 6,   &
            &   h_deiondt = x_pi + 7,   &
            &   h_deionda = x_pi + 8,   &
            &   h_deiondz = x_pi + 9,   &
            &   h_deiontt = x_pi + 10,  &
            &   h_deionta = x_pi + 11,  &
            &   h_deiontz = x_pi + 12,  &
            &   h_deionaa = x_pi + 13,  &
            &   h_deionaz = x_pi + 14,  &
            &   h_deionzz = x_pi + 15

 integer, parameter ::  &
            &   x_ei = x_pi + 15

 integer, parameter ::  &
            &   h_sion = x_ei + 1,  &
            &   h_dsiont = x_ei + 2,    &
            &   h_dsiond = x_ei + 3,    &
            &   h_dsiona = x_ei + 4,    &
            &   h_dsionz = x_ei + 5,    &
            &   h_dsiondd = x_ei + 6,   &
            &   h_dsiondt = x_ei + 7,   &
            &   h_dsionda = x_ei + 8,   &
            &   h_dsiondz = x_ei + 9,   &
            &   h_dsiontt = x_ei + 10,  &
            &   h_dsionta = x_ei + 11,  &
            &   h_dsiontz = x_ei + 12,  &
            &   h_dsionaa = x_ei + 13,  &
            &   h_dsionaz = x_ei + 14,  &
            &   h_dsionzz = x_ei + 15

 integer, parameter ::  &
            &   x_si = x_ei + 15

 integer, parameter ::  &
            &   h_etaion = x_si + 1,    &
            &   h_detait = x_si + 2,    &
            &   h_detaid = x_si + 3,    &
            &   h_detaia = x_si + 4,    &
            &   h_detaiz = x_si + 5,    &
            &   h_detaidd = x_si + 6,   &
            &   h_detaidt = x_si + 7,   &
            &   h_detaida = x_si + 8,   &
            &   h_detaidz = x_si + 9,   &
            &   h_detaitt = x_si + 10,  &
            &   h_detaita = x_si + 11,  &
            &   h_detaitz = x_si + 12,  &
            &   h_detaiaa = x_si + 13,  &
            &   h_detaiaz = x_si + 14,  &
            &   h_detaizz = x_si + 15

 integer, parameter ::  &
            &   x_etai = x_si + 15

 integer, parameter ::  &
            &   h_xni = x_etai + 1, &
            &   h_dxnit = x_etai + 2,   &
            &   h_dxnid = x_etai + 3,   &
            &   h_dxnia = x_etai + 4,   &
            &   h_dxniz = x_etai + 5,   &
            &   h_dxnidd = x_etai + 6,  &
            &   h_dxnidt = x_etai + 7,  &
            &   h_dxnida = x_etai + 8,  &
            &   h_dxnidz = x_etai + 9,  &
            &   h_dxnitt = x_etai + 10, &
            &   h_dxnita = x_etai + 11, &
            &   h_dxnitz = x_etai + 12, &
            &   h_dxniaa = x_etai + 13, &
            &   h_dxniaz = x_etai + 14, &
            &   h_dxnizz = x_etai + 15

 integer, parameter ::  &
            &   x_xni = x_etai + 15

 !..electron-positron contributions

 integer, parameter ::  &
            &   h_etaele = x_xni + 1,   &
            &   h_etapos = x_xni + 2,   &
            &   h_detat = x_xni + 3,    &
            &   h_detad = x_xni + 4,    &
            &   h_detaa = x_xni + 5,    &
            &   h_detaz = x_xni + 6,    &
            &   h_detadd = x_xni + 7,   &
            &   h_detadt = x_xni + 8,   &
            &   h_detada = x_xni + 9,   &
            &   h_detadz = x_xni + 10,  &
            &   h_detatt = x_xni + 11,  &
            &   h_detata = x_xni + 12,  &
            &   h_detatz = x_xni + 13,  &
            &   h_detaaa = x_xni + 14,  &
            &   h_detaaz = x_xni + 15,  &
            &   h_detazz = x_xni + 16

 integer, parameter ::  &
            &   x_etae = x_xni + 16

 integer, parameter ::  &
            &   h_pele = x_etae + 1,    &
            &   h_ppos = x_etae + 2,    &
            &   h_dpept = x_etae + 3,   &
            &   h_dpepd = x_etae + 4,   &
            &   h_dpepa = x_etae + 5,   &
            &   h_dpepz = x_etae + 6,   &
            &   h_dpepdd = x_etae + 7,  &
            &   h_dpepdt = x_etae + 8,  &
            &   h_dpepda = x_etae + 9,  &
            &   h_dpepdz = x_etae + 10, &
            &   h_dpeptt = x_etae + 11, &
            &   h_dpepta = x_etae + 12, &
            &   h_dpeptz = x_etae + 13, &
            &   h_dpepaa = x_etae + 14, &
            &   h_dpepaz = x_etae + 15, &
            &   h_dpepzz = x_etae + 16

 integer, parameter ::  &
            &   x_pep = x_etae + 16

 integer, parameter ::  &
            &   h_eele = x_pep + 1, &
            &   h_epos = x_pep + 2, &
            &   h_deept = x_pep + 3,    &
            &   h_deepd = x_pep + 4,    &
            &   h_deepa = x_pep + 5,    &
            &   h_deepz = x_pep + 6,    &
            &   h_deepdd = x_pep + 7,   &
            &   h_deepdt = x_pep + 8,   &
            &   h_deepda = x_pep + 9,   &
            &   h_deepdz = x_pep + 10,  &
            &   h_deeptt = x_pep + 11,  &
            &   h_deepta = x_pep + 12,  &
            &   h_deeptz = x_pep + 13,  &
            &   h_deepaa = x_pep + 14,  &
            &   h_deepaz = x_pep + 15,  &
            &   h_deepzz = x_pep + 16

 integer, parameter ::  &
            &   x_eep = x_pep + 16

 integer, parameter ::  &
            &   h_sele = x_eep + 1, &
            &   h_spos = x_eep + 2, &
            &   h_dsept = x_eep + 3,    &
            &   h_dsepd = x_eep + 4,    &
            &   h_dsepa = x_eep + 5,    &
            &   h_dsepz = x_eep + 6,    &
            &   h_dsepdd = x_eep + 7,   &
            &   h_dsepdt = x_eep + 8,   &
            &   h_dsepda = x_eep + 9,   &
            &   h_dsepdz = x_eep + 10,  &
            &   h_dseptt = x_eep + 11,  &
            &   h_dsepta = x_eep + 12,  &
            &   h_dseptz = x_eep + 13,  &
            &   h_dsepaa = x_eep + 14,  &
            &   h_dsepaz = x_eep + 15,  &
            &   h_dsepzz = x_eep + 16

 integer, parameter ::  &
            &   x_sep = x_eep + 16

 integer, parameter ::  &
            &   h_xne = x_sep + 1,  &
            &   h_xnp = x_sep + 2,  &
            &   h_xnem = x_sep + 3, &
            &   h_dxnet = x_sep + 4,    &
            &   h_dxned = x_sep + 5,    &
            &   h_dxnea = x_sep + 6,    &
            &   h_dxnez = x_sep + 7,    &
            &   h_dxnedd = x_sep + 8,   &
            &   h_dxnedt = x_sep + 9,   &
            &   h_dxneda = x_sep + 10,  &
            &   h_dxnedz = x_sep + 11,  &
            &   h_dxnett = x_sep + 12,  &
            &   h_dxneta = x_sep + 13,  &
            &   h_dxnetz = x_sep + 14,  &
            &   h_dxneaa = x_sep + 15,  &
            &   h_dxneaz = x_sep + 16,  &
            &   h_dxnezz = x_sep + 17

 integer, parameter ::  &
            &   x_xne = x_sep + 17

 !..ionization potential contributions
 integer, parameter ::  &
            &   h_pip = x_xne + 1,  &
            &   h_eip = x_xne + 2,  &
            &   h_sip = x_xne + 3

 integer, parameter ::  &
            &   x_ip = x_xne + 3

 !..coulomb contributions
 integer, parameter ::  &
            &   h_pcou = x_ip + 1,  &
            &   h_dpcout = x_ip + 2,    &
            &   h_dpcoud = x_ip + 3,    &
            &   h_dpcoua = x_ip + 4,    &
            &   h_dpcouz = x_ip + 5,    &
            &   h_ecou = x_ip + 6,  &
            &   h_decout = x_ip + 7,    &
            &   h_decoud = x_ip + 8,    &
            &   h_decoua = x_ip + 9,    &
            &   h_decouz = x_ip + 10,   &
            &   h_scou = x_ip + 11, &
            &   h_dscout = x_ip + 12,   &
            &   h_dscoud = x_ip + 13,   &
            &   h_dscoua = x_ip + 14,   &
            &   h_dscouz = x_ip + 15,   &
            &   h_plasg = x_ip + 16

 integer, parameter ::  &
            &   x_cou = x_ip + 16

 !..thermodynamic consistency checks; maxwell relations
 integer, parameter ::  &
            &   h_dse = x_cou + 1,  &
            &   h_dpe = x_cou + 2,  &
            &   h_dsp = x_cou + 3

 integer, parameter ::  &
            &   x_mxwll = x_cou + 3

 !..derivative based quantities for the gas
 integer, parameter ::  &
            &   h_cp_gas = x_mxwll + 1, &
            &   h_dcp_gasdd = x_mxwll + 2,  &
            &   h_dcp_gasdt = x_mxwll + 3,  &
            &   h_dcp_gasda = x_mxwll + 4,  &
            &   h_dcp_gasdz = x_mxwll + 5,  &
            &   h_cv_gas = x_mxwll + 6, &
            &   h_dcv_gasdd = x_mxwll + 7,  &
            &   h_dcv_gasdt = x_mxwll + 8,  &
            &   h_dcv_gasda = x_mxwll + 9,  &
            &   h_dcv_gasdz = x_mxwll + 10, &
            &   h_gam1_gas = x_mxwll + 11,  &
            &   h_dgam1_gasdd = x_mxwll + 12,   &
            &   h_dgam1_gasdt = x_mxwll + 13,   &
            &   h_dgam1_gasda = x_mxwll + 14,   &
            &   h_dgam1_gasdz = x_mxwll + 15,   &
            &   h_gam2_gas = x_mxwll + 16,  &
            &   h_dgam2_gasdd = x_mxwll + 17,   &
            &   h_dgam2_gasdt = x_mxwll + 18,   &
            &   h_dgam2_gasda = x_mxwll + 19,   &
            &   h_dgam2_gasdz = x_mxwll + 20,   &
            &   h_gam3_gas = x_mxwll + 21,  &
            &   h_dgam3_gasdd = x_mxwll + 22,   &
            &   h_dgam3_gasdt = x_mxwll + 23,   &
            &   h_dgam3_gasda = x_mxwll + 24,   &
            &   h_dgam3_gasdz = x_mxwll + 25,   &
            &   h_nabad_gas = x_mxwll + 26, &
            &   h_dnab_gasdd = x_mxwll + 27,    &
            &   h_dnab_gasdt = x_mxwll + 28,    &
            &   h_dnab_gasda = x_mxwll + 29,    &
            &   h_dnab_gasdz = x_mxwll + 30,    &
            &   h_cs_gas = x_mxwll + 31,    &
            &   h_dcs_gasdd = x_mxwll + 32, &
            &   h_dcs_gasdt = x_mxwll + 33, &
            &   h_dcs_gasda = x_mxwll + 34, &
            &   h_dcs_gasdz = x_mxwll + 35

 integer, parameter ::  &
            &   x_dgas = x_mxwll + 35

 !..derivative based quantities for the totals
 integer, parameter ::  &
            &   h_cp = x_dgas + 1,  &
            &   h_dcpdd = x_dgas + 2,   &
            &   h_dcpdt = x_dgas + 3,   &
            &   h_dcpda = x_dgas + 4,   &
            &   h_dcpdz = x_dgas + 5,   &
            &   h_cv = x_dgas + 6,  &
            &   h_dcvdd = x_dgas + 7,   &
            &   h_dcvdt = x_dgas + 8,   &
            &   h_dcvda = x_dgas + 9,   &
            &   h_dcvdz = x_dgas + 10,  &
            &   h_gam1 = x_dgas + 11,   &
            &   h_dgam1dd = x_dgas + 12,    &
            &   h_dgam1dt = x_dgas + 13,    &
            &   h_dgam1da = x_dgas + 14,    &
            &   h_dgam1dz = x_dgas + 15,    &
            &   h_gam2 = x_dgas + 16,   &
            &   h_dgam2dd = x_dgas + 17,    &
            &   h_dgam2dt = x_dgas + 18,    &
            &   h_dgam2da = x_dgas + 19,    &
            &   h_dgam2dz = x_dgas + 20,    &
            &   h_gam3 = x_dgas + 21,   &
            &   h_dgam3dd = x_dgas + 22,    &
            &   h_dgam3dt = x_dgas + 23,    &
            &   h_dgam3da = x_dgas + 24,    &
            &   h_dgam3dz = x_dgas + 25,    &
            &   h_nabad = x_dgas + 26,  &
            &   h_dnabdd = x_dgas + 27, &
            &   h_dnabdt = x_dgas + 28, &
            &   h_dnabda = x_dgas + 29, &
            &   h_dnabdz = x_dgas + 30, &
            &   h_cs = x_dgas + 31, &
            &   h_dcsdd = x_dgas + 32,  &
            &   h_dcsdt = x_dgas + 33,  &
            &   h_dcsda = x_dgas + 34,  &
            &   h_dcsdz = x_dgas + 35,  &
            &   h_chit = x_dgas + 36,   &
            &   h_dchitdd = x_dgas + 37,    &
            &   h_dchitdt = x_dgas + 38,    &
            &   h_dchitda = x_dgas + 39,    &
            &   h_dchitdz = x_dgas + 40,    &
            &   h_chid = x_dgas + 41,   &
            &   h_dchiddd = x_dgas + 42,    &
            &   h_dchiddt = x_dgas + 43,    &
            &   h_dchidda = x_dgas + 44,    &
            &   h_dchiddz = x_dgas + 45

 integer, parameter ::  &
            &   x_dtot = x_dgas + 45

 !  random cr.p for debugging
 integer, parameter ::  &
            &   h_crp = x_dtot + 1, &
            &   h_dcrpt = x_dtot + 2,   &
            &   h_dcrpd = x_dtot + 3,   &
            &   h_dcrpa = x_dtot + 4,   &
            &   h_dcrpz = x_dtot + 5,   &
            &   h_dcrpdd = x_dtot + 6,  &
            &   h_dcrpdt = x_dtot + 7,  &
            &   h_dcrpda = x_dtot + 8,  &
            &   h_dcrpdz = x_dtot + 9,  &
            &   h_dcrptt = x_dtot + 10, &
            &   h_dcrpta = x_dtot + 11, &
            &   h_dcrptz = x_dtot + 12, &
            &   h_dcrpaa = x_dtot + 13, &
            &   h_dcrpaz = x_dtot + 14, &
            &   h_dcrpzz = x_dtot + 15

 ! validity flag
 ! nonzero if the previous entries were actually computed by helm
 ! zero if we didn't call helm
 integer, parameter :: h_valid = h_dcrpzz + 1

 integer, parameter :: num_helm_results = h_valid

 ! end helm results

ext: f

max_stars_repo_name: LBJ-Wade/dStar

max_issues_repo_name: LBJ-Wade/dStar

max_forks_repo_name: LBJ-Wade/dStar


text:
Sports Chat, otherwise known as The Brett and Chuck Power Hour, is a onehour sports radio stations radio program on local community radio KDRT. The show airs live each week from 11:00am12:00pm each Friday midday. The show reairs on Saturday morning from 8:009:00.

Sports Chat is cohosted by Davis residents Brett Andersen and C.J. Garcia. The show discusses national sports news, including but not limited to football, basketball, baseball and soccer. The local flavor discussed on the show includes the UC Davis Aggies and the Davis High Blue Devils. Listeners can phone in (530)7921648 to contribute to the thoughts on the show or ridicule the hosts biased sports commentary.

Special guests previously on the show include Yahoo! sports writer Michael Silver, and local (and one now distant) Davis residents Will Robinson and Evan Ream, writers on the renowned blog The Sack Lunch Blog.

The Sports Chat cohosts have a radio bucket list, which is a group of 10 individuals who the pair dream of having on the air at some point in time. There is varying reason for the ten on the list, some reasons which are sensible and some which even the hosts cannot explain. The ten include:

1. Bruce Bochy, San Francisco Giants manager
2. Dez Bryant, Dallas Cowboys wide receiver
3. John Isner/Nicolas Mahut, who in 2010 played the longest tennis match in history
4. Eric Musselman, head coach of the NBA Development League, Reno Bighorns
5. Iniesta, Spanish futbol player
6. Tyler Thomas, former Oregon State offensive lineman
7. Martin Truax Jr., NASCAR driver
8. Rusty Bumgarner, USA Slowpitch softball phenomenon
9. Jeff Shaw, KDRT head honcho
10. Daunte Culpepper or Dennis Green, quarterback and head coach, respectively, of the Sacramento Mountain Lions UFL football team

If you or anyone you know has access to getting one of these individuals featured on Sports Chat, you will go down in history as one of the greatest Sports Chat supporters ever and be forever a legend on their show.

To contact the guys, email brettandchuck@gmail.com

You can also follow their blog at http://brettandchuckpowerhour.blogspot.com

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Random facts about me:
  I came from a flyover state in June 2008.
  I am much happier here.
  I have lived in Davis, Oak Park in Sacramento, and now North Oakland.
  Despite the name, apparently Im no longer new here.
  Im a bit of a computer/Internet geeks geek.

20100220 14:25:03 nbsp You http://daviswiki.org/Users/IAmNewHere?actionuserinfo used to be. Users/JasonAller

20100313 21:21:41 nbsp Nearly two years!  I dont think youre still new here.  :) Users/JabberWokky Evan JabberWokky Edwards

20100322 23:00:20 nbsp Even as I near the two year mark here, I try to look at things with fresh eyes.  Does that count? Users/IAmNewHere

20100322 23:30:54 nbsp Yes, but in the interest of preserving the psychological stability of fellow wiki editors and gnomes, I hereby propose a rule outlawing user handles with an intrinsic expiration date. (…Kidding, of course, but I’m sure you’d be grandfathered in anyway.) Users/EBT

20100323 01:51:24 nbsp Hey, at least you exist in the first place! Users/IDoNotExist
 I thought I saw a comment here, but I can’t seem to find it anymore…?


text:
C PR tree-optimization/36922
C { dg-do compile }
C { dg-options "-O2 -ftree-loop-linear" }
      SUBROUTINE PR36922(N,F,Z,C)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION C(23821),Z(0:2*N+1),F(0:2*N)
      I=0
      DO L=0,N
        DO M=0,L
          DO M2=M,L
            I=I+1
            C(I)=F(L+M)*F(L-M)*Z(L-M2)/(F(M2+M)*F(M2-M)*F(L-M2)*F(L-M2))
          ENDDO
        ENDDO
      ENDDO
      END

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
C+*****************************************
C Set of routines to make C and Fortran programs run identically
C
C JLP
C Version 14-09-95
C--**********************************************
C ALPHA in radians
C**********************************************
       SUBROUTINE JLP_COS(COS1,ALPHA)
       REAL COS1, ALPHA
       COS1=COS(ALPHA)
       RETURN
       END
C**********************************************
       SUBROUTINE JLP_SIN(SIN1,ALPHA)
       REAL SIN1, ALPHA
       SIN1=SIN(ALPHA)
       RETURN
       END
C**********************************************
       SUBROUTINE JLP_ATAN2(ALPHA,IM1,RE1)
       REAL ALPHA, RE1, IM1
       ALPHA = ATAN2(IM1,RE1)
       RETURN
       END

ext: for


text:
Question 12. of the 2006 City Council Election/Questions to candidates 2006 City Council Questions to Candidates

>
<

This City Council will be responsible for the creation of the 2010 General Plan, so what are your visions for that General Plan, and how would you change it from the current General Plan?

  Stan Forbes: I would keep most of the existing General Plan intact. I would like to see some principles established such as not building one class one farm ground or land that is in the 100 year flood plain. I would also establish a principle that projects will be reverse plannedthat is we will determine our capacitiesroads, water treatment etc.and then design projects that will not exceed that capacity rather than have a developer design a project and then try and squeeze it in. I also would initiate a process of community driven planning rather than developer driven. The community should be in at the beginning of planning so that the project meets community rather developer needs.

  Lamar Heystek: I envision the next General Plan to emphasize a small, compact form, just as the current Plan does. I favor the designation of additional land for affordable highdensity marketrate housing such as townhouses and condominiums. The City Council needs to hold the line against McMansions by taking proactive steps to encourage housing that actually meets the needs of Davisites.

  Rob Roy: As I stated earlier I want a stated ordinanced uniqueness to Davis in the General Plan  ad that means controlling the type of businesses that are in Davis. Instead of solely dividing things up by type and square footage I want distinctions to include whether or not a business is unique to Davis or whether or not it is owned by a local business owner i.e. a franchisee). I want to be sure that Davis has unique businesses such as Alphabet Moon, Armadillo Records, Delta of Venus, and the Coop.

  Michael Levy: I want to be sure that the General Plan reflects the vision of the broader community.  When changing the General Plan, I would ensure that the process is broadbased and inclusive.

  Ruth Asmundson: The General Plan for Davis should never be the reflection of one individual  rather it needs to reflect the interests and visions of the Davis citizens.  As a member of the School Board I worked on the committees that drafted the current general plan, and I anticipate a similar involvement of all city leaders and citizens in the creation of the 2010 plan. The city needs effective and creative community engagement in the process.


text:
      program sort01

C     Check that proper values are retained from equations for
C     substitution in inequalities

      if(i.lt.3) then
C     you are not interested in i#init
         i = i + 1
         print *, i
      endif

c      j = i
c      if(j.lt.3) then
C     You want the information on i
c         print *, i
c      endif

      end


text:
      function bulgedens(r,z)
      common /flags/ idiskflag, ibulgeflag, ihaloflag

      bulgedens=0
      psi = pot(r,z)
      psi0= pot(0.,0.)
      if(ibulgeflag.EQ.1)
     &       bulgedens = bulgedens+ bulgedenspsi(psi,psi0)
      if(ibulgeflag.EQ.3)
     &       bulgedens = bulgedens+ bulgedfdenspsi(psi,psi0)
      return
      end

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
      PROGRAM FGKE03
C
C  Define error file, Fortran unit number, and workstation type,
C  and workstation ID.
C
      PARAMETER (IERRF=6, LUNIT=2, IWKID=1)
C
C  Illustrate creating multiple metafiles in the same job.
C
      CHARACTER*80 FNAME,CDUM
C
C  Open GKS.
C
      CALL GOPKS (IERRF, ISZDM)
C
C  Open and activate a metafile with the name META01.
C
      FNAME = 'META01'
      CALL GESC(-1391,1,FNAME,1,1,CDUM)
      CALL GOPWK (IWKID, LUNIT, 1)
      CALL GACWK (IWKID)
C
C  Draw a single polymarker in the center of the picture.
C
      CALL GPM(1,.5,.5)
      CALL FRAME
C
C  Deactivate and close the META01 metafile.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
C
C  Open and activate META02.
C
      FNAME = 'META02'
      CALL GESC(-1391,1,FNAME,1,1,CDUM)
      CALL GOPWK (IWKID, LUNIT, 1)
      CALL GACWK (IWKID)
C
C  Draw a single polymarker in the upper half of the picture.
C
      CALL GPM(1,.5,.75)
      CALL FRAME
C
C  Deactivate and close the META02 metafile.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
C
C  Close GKS.
C
      CALL GCLKS
C
      STOP
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
      INCLUDE 'fortport'
C     PROGRAM TO PRODUCE DISCRETE LEVEL NOISE
C
      INTEGER PBUF(2,256)
      REAL*4  THRESH(256),RANNUM
      BYTE OUT(3600),LNOV(256)
      INTEGER LOG,IO
      EQUIVALENCE (NVAL,LOG)
C
      CALL IFMESSAGE('POLYNOIS version 05-SEP-94')
C
      CALL XVEACTION('SA',' ')
      CALL XVPARM('SEEDS',IO,ICNT,IDEF,2)
      IO = 0
      CALL XVPARM('NOISE',PBUF,ICNT,IDEF,512)
      NLEV=ICNT/2
      IF (NLEV * 2 .NE. ICNT) THEN
          CALL XVMESSAGE(
     + '*** ERROR-NOISE PARAMETERS MUST COME IN PAIRS',' ')
          CALL ABEND
      END IF
C     DETERMINE THE NOISE LEVELS AND PROBABILITIES
      VN=0.0
      DO I=1,NLEV
           NVAL=PBUF(1,I)
           IF((NVAL.LT.0).AND.(NVAL.GT.255)) THEN
               CALL XVMESSAGE(
     + '*** INVALID NOISE INTENSITY LEVEL',' ')
               CALL ABEND
           END IF
C     FIX INTEGER OVERFLOW PROBLEM i.e. log=140
C     (USE SUBROUTINE ITLA INSTEAD OF "=")
C          LNOV(I)=LOG
           CALL ITLA(LOG,LNOV(I),1)
C           LNOV(I)=INT2BYTE(LOG)
           THRESH(I)=PBUF(2,I)
           IF(THRESH(I).LE.0.0) THEN
              CALL XVMESSAGE('*** NONPOSITIVE NOISE PROBABILITY',' ')
              CALL ABEND
           END IF
           VN=VN+THRESH(I)
      END DO
C     DETERMINE NOISE PROB. AS RATIO AGAINST TOTAL ACCUMULATIVE PROBS.
      V=0.0
      DO I=1,NLEV
           V=V+THRESH(I)/VN
           THRESH(I)=V
      END DO
      CALL XVPARM('NSO',NSO,ICNT,IDEF,1)
      CALL XVPARM('NLO',NLO,ICNT,IDEF,1)
      IF((NSO.LE.0).OR.(NLO.LE.0)) THEN
          CALL XVMESSAGE('*** INVALID SIZE FIELD PARAMETERS',' ')
          CALL ABEND
      END IF
      CALL XVUNIT(OUTUNIT,'OUT',1,STATUS,' ')
      CALL XVOPEN(OUTUNIT,STATUS,'OP','WRITE','U_NL',NLO,'U_NS',
     +NSO,'O_FORMAT','BYTE','U_FORMAT','BYTE',' ')
C     FOR THE FIRST PROB. GREATER THAN THE RANDOM NUMBER, THE
C     ASSOCIATED NOISE INTENSITY LEVEL IS GENERATED.
      DO I=1,NLO
         DO 10 J=1,NSO
                 CALL RANGEN(IO,RANNUM)
                 V=RANNUM
                   DO K=1,NLEV
                        IF(V.LT.THRESH(K)) GO TO 10
                   END DO
                CALL XVMESSAGE('*** NOISE ENCODING ERROR',' ')
                CALL ABEND
   10    OUT(J)=LNOV(K)
         CALL XVWRIT(OUTUNIT,OUT,STATUS,'NSAMPS',NSO,' ')
      END DO
      CALL XVMESSAGE('*** POLYNOIS TASK COMPLETED',' ')
      END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


!------------------------------------------------------------------------------
! BSD 2-Clause License
!
! Copyright (c) 2020, Science and Technology Facilities Council.
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! * Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!
! * Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!------------------------------------------------------------------------------
! Author: A. R. Porter, STFC Daresbury Laboratory

!> Tests for the global-sum functionality of the dl_esm_inf library.
!! Domain size must be supplied via the JPIGLO and JPJGLO environment
!! variables.
program test_gsum
  use kind_params_mod
  use parallel_mod
  use grid_mod
  use field_mod
  use gocean_mod
  implicit none
  ! Total size of the model domain
  integer :: jpiglo = 0, jpjglo = 0
  ! (Uniform) grid resolution
  real(go_wp) :: dx = 1.0
  real(go_wp) :: dy = 1.0
  !> The grid on which our fields are defined
  type(grid_type), target :: model_grid
  !> An example field
  type(r2d_field) :: u_field, v_field, t_field, f_field
  ! Local definition of the T-point mask which defines whether T points are
  ! wet (1), dry (0) or outside (-1) the simulation domain.
  integer, allocatable :: tmask(:,:)
  integer :: my_rank
  integer :: ierr
  character(len=10) :: env
  real(go_wp) :: expected_sum, actual_sum
  real(go_wp) :: TOL_ZERO = 1.0D-8

  call get_environment_variable("JPIGLO", env)
  read(env, '(i10)') jpiglo
  call get_environment_variable("JPJGLO", env)
  read(env, '(i10)') jpjglo
  if(jpiglo < 1 .or. jpjglo < 1)then
     stop 'Domain size must be set via $JPIGLO and $JPJGLO'
  end if

  call gocean_initialise()

  !> Create our grid object
  model_grid = grid_type(GO_ARAKAWA_C, &
                         (/GO_BC_EXTERNAL,GO_BC_EXTERNAL,GO_BC_NONE/), &
                         GO_OFFSET_NE)

  !> Generate a domain decomposition. This automatically uses the number
  !! of MPI ranks available.
  call model_grid%decompose(jpiglo, jpjglo)
  my_rank = get_rank()

  if(my_rank == 1) then
     write(*,"('Using global domain size of ',I4,'x',I4)") jpiglo, jpjglo
  end if

  !> Create a T-point mask describing the (local) domain
  allocate(tmask(model_grid%subdomain%global%nx,  &
                 model_grid%subdomain%global%ny), Stat=ierr)
  if(ierr /= 0)then
     call gocean_stop('Failed to allocate T-mask')
  end if
  ! To keep things simple we set all points to be wet and within the domain
  tmask = 1

  !> Complete the initialisation of the grid using the T-mask and
  !! grid resolution
  call grid_init(model_grid, dx, dy, tmask)

  !> Create fields on U,V,T,F-points of the grid
  u_field = r2d_field(model_grid, GO_U_POINTS)
  v_field = r2d_field(model_grid, GO_V_POINTS)
  t_field = r2d_field(model_grid, GO_T_POINTS)
  f_field = r2d_field(model_grid, GO_F_POINTS)

  !> Set internal field points to 1.0, external to -100.0
  call init_field(u_field)
  call init_field(v_field)
  call init_field(t_field)
  call init_field(f_field)

  ! Global sum should be equal to the number of points in the domain
  expected_sum = jpiglo*jpjglo
  actual_sum = field_checksum(u_field)
  if(ABS(expected_sum - actual_sum) > TOL_ZERO)then
     call gocean_stop('Checksum of U field incorrect!')
  else
     write(*,"(I3,' Global sum for u: ', E15.8)") my_rank, actual_sum
  end if
  actual_sum = field_checksum(v_field)
  if(ABS(expected_sum - actual_sum) > TOL_ZERO)then
     call gocean_stop('Checksum of V field incorrect!')
  else
     write(*,"(I3,' Global sum for v: ', E15.8)") my_rank, actual_sum
  end if
  actual_sum = field_checksum(t_field)
  if(ABS(expected_sum - actual_sum) > TOL_ZERO)then
     call gocean_stop('Checksum of T field incorrect!')
  else
     write(*,"(I3,' Global sum for t: ', E15.8)") my_rank, actual_sum
  end if
  actual_sum = field_checksum(f_field)
  if(ABS(expected_sum - actual_sum) > TOL_ZERO)then
     call gocean_stop('Checksum of F field incorrect!')
  else
     write(*,"(I3,' Global sum for t: ', E15.8)") my_rank, actual_sum
  end if

  call gocean_finalise()

contains

  subroutine init_field(field)
    type(r2d_field), intent(inout) :: field
    integer :: ji, jj
    integer :: istart, istop, jstart, jstop
    istart = field%internal%xstart
    istop =  field%internal%xstop
    jstart = field%internal%ystart
    jstop =  field%internal%ystop

    field%data(:,:) = -100.0
    do jj = jstart, jstop
       do ji = istart, istop
          field%data(ji,jj) = 1.0
       end do
    end do

  end subroutine init_field

end program test_gsum


text:
      SUBROUTINE UPBB(NVAL,NBITS,IBIT,IBAY)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    UPBB
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER
C   CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1).
C   THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPB, EXCEPT IN
C   UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF ARGUMENTS IS
C   DIFFERENT).
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C                           LINING CODE WITH FPP DIRECTIVES
C 2003-11-04  J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS
C                           IN DECODER VERSION)
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- ADDED CHECK FOR NBITS EQUAL TO ZERO;
C                           MODIFIED LOGIC TO MAKE IT CONSISTENT WITH
C                           LOGIC IN UPB; UNIFIED/PORTABLE FOR WRF;
C                           ADDED DOCUMENTATION (INCLUDING HISTORY)
C
C USAGE:    CALL UPBB (NVAL, NBITS, IBIT, IBAY)
C   INPUT ARGUMENT LIST:
C     NBITS    - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK
C                NVAL
C     IBIT     - INTEGER: BIT POINTER WITHIN IBAY TO START UNPACKING
C                FROM
C     IBAY     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED
C                NVAL
C
C   OUTPUT ARGUMENT LIST:
C     NVAL     - INTEGER: UNPACKED INTEGER
C
C REMARKS:
C    THIS ROUTINE CALLS:        IREV
C    THIS ROUTINE IS CALLED BY: RCSTPL   RDTREE   UFBGET   UFBTAB
C                               UFBTAM   UPB      WRITLC
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)

      DIMENSION IBAY(*)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

C  IF NBITS=0, THEN JUST SET NVAL=0 AND RETURN
C  -------------------------------------------

      IF(NBITS.EQ.0)THEN
        NVAL=0
        GOTO 100
      ENDIF

      NWD = IBIT/NBITW + 1
      NBT = MOD(IBIT,NBITW)
      INT = ISHFT(IREV(IBAY(NWD)),NBT)
      INT = ISHFT(INT,NBITS-NBITW)
      LBT = NBT+NBITS
      IF(LBT.GT.NBITW) THEN
         JNT = IREV(IBAY(NWD+1))
         INT = IOR(INT,ISHFT(JNT,LBT-2*NBITW))
      ENDIF
      NVAL = INT

C  EXIT
C  ----

100   RETURN
      END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak


           program demo_strtok
           use M_strings, only : strtok
           implicit none
           character(len=264)          :: inline
           character(len=*),parameter  :: delimiters=' ;,'
           integer                     :: ios, itoken, istart, iend
              do ! read lines from stdin until end-of-file or error
                 read (unit=*,fmt="(a)",iostat=ios) inline
                 if(ios.ne.0)stop
                 ! must set ITOKEN=0 before looping on strtok(3f)
                 ! on a new string.
                 itoken=0
                 do while &
                 &( strtok(inline,itoken,istart,iend,delimiters) )
                    print *, itoken,&
                    & 'TOKEN=['//(inline(istart:iend))//']',istart,iend
                 enddo
              enddo
           end program demo_strtok


text:
subroutine ppmlr

! Using the 1D arrays of rho, u, and P, perform a 1D lagrangian hydrodynamics evolution:
!   - set boundary conditions by filling ghost zones
!   - obtain parabolic interpolations of rho, u, P
!   - compute input states from these interpolations for Riemann problem
!   - call the Riemann solver to find the time averages umid, pmid
!   - evolve the finite difference equations to get updated values of rho, u, and E
! Then perform a conservative remap back to the Eulerian grid
!-----------------------------------------------------------------------

! GLOBALS
use global
use sweeps

IMPLICIT NONE

! LOCALS
INTEGER :: n
REAL(kind=8) :: xwag
REAL(kind=8), DIMENSION(maxsweep) :: dr, du, dp, r6, u6, p6, rl, ul, pl
REAL(kind=8), DIMENSION(maxsweep) :: rrgh, urgh, prgh, rlft, ulft, plft, umid, pmid
REAL(kind=8), DIMENSION(maxsweep) :: xaf, dxf

!-----------------------------------------------------------------------
if (ngeom<3) radius = 1.0

! Apply boundary conditions by filling ghost zones
call boundary

! Calculate flattening coefficients for smoothing near shocks
call flatten

! Compute parabolic coefficients
call paraset( nmin-4, nmax+5, para, dx, xa )

! Interpolate parabolae for fluid variables
call parabola(nmin-4, nmax+4, para, p, dp, p6, pl, flat)
call parabola(nmin-4, nmax+4, para, r, dr, r6, rl, flat)
call parabola(nmin-4, nmax+4, para, u, du, u6, ul, flat)

! Integrate parabolae to get input states for Riemann problem
call states( pl, ul, rl, p6, u6, r6, dp, du, dr, plft, ulft, rlft, prgh, urgh, rrgh )

! Call the Riemann solver to obtain the zone face averages, umid and pmid
call riemann( nmin-3, nmax+4, gam, prgh, urgh, rrgh, plft, ulft, rlft, pmid, umid )

! do lagrangian update using umid and pmid
call evolve( umid, pmid )

!#########################################################################
! EXTRA DISSIPATION TO REDUCE CARBUNCLE NOISE
xwag = sum(flat)
if (xwag*xwig /= 0.0) then ! wiggle grid, remap, then remap back to Eulerian grid

 ! save Eulerian coordinates for second remap
 xaf = xa0
 dxf = dx0

 ! wiggle grid where there is a shock, leaving edges unchanged
 do n = nmin+1, nmax
  if (max(flat(n-1),flat(n)) > 0.0) xa0(n) = xa0(n) + xwig*dx0(n)
  dx0(n-1) = xa0(n) - xa0(n-1)
 enddo
 dx0(nmax) = xa0(nmax+1) - xa0(nmax)

 call remap

 ! put wiggled grid into xa(n), but keep ghost cells untouched
 do n = nmin, nmax+1
  xa(n)   = xa0(n)
  dx(n-1) = xa(n) - xa(n-1)
 enddo
 call volume(nmin, nmax, ngeom, radius, xa, dx, dvol)

 ! put Eulerian grid back into xa0
 xa0 = xaf
 dx0 = dxf

endif
!#########################################################################

! remap onto original Eulerian grid
call remap

return
end

max_stars_repo_name: samgeen/Weltgeist

max_issues_repo_name: samgeen/Weltgeist

max_forks_repo_name: samgeen/Weltgeist


text:
subroutine  GETTBL
  use simsphere_mod
  implicit none

! This subroutine takes the precipitable water content (OMEGA) and
! calc's the transmission coefficient for absorbtion using a lookup
! table.  Interpolate linearly on OMEGA.  The lookup table contains
! 46-entry tables for OMEGA from 0 to 5 in increments of 0.5.

! Note that the maximum value allowed for OMEGA is 5.0.

! The subroutine also copies the scattering (SCATBL) and the
! backscattering (BSCTBL) tables from file into the common block.

  real :: A(46) , B(46) , C(46)
  real :: FRACT, FRACT2
  integer :: I,J,K,L

!      INCLUDE 'modvars.h'

  OPEN (UNIT = 14, FILE = f_precip_lut )

  I = INT(1 + OMEGA * 2)
  J = I - 1
  IF ( I .GT. 11 ) I = 11

! For no precipitable water use 1st 46 values, otherwise skip J blocks
! of 46 table entries and read appropriate values.

  IF ( J .EQ. 0 ) THEN
    do L = 1 , 46
      READ ( 14 , 1000 ) ABSTBL(L) , SCATBL(L) , BSCTBL(L)
    end do
  ELSE
    do K = 1 , J
      do L = 1 , 46
        READ ( 14 , 1000 ) A(L) , B(L) , C(L)
      end do
    end do
    do L = 1 , 46
      READ ( 14 , 1000 ) ABSTBL(L) , SCATBL(L) , BSCTBL(L)
    end do
  ENDIF

! For a maximum OMEGA no interpolation is performed but for all other
! values of OMEGA interpol'n is done using weighting factors FRACT2 &
! FRACT.  Values are written to channel 69.

  IF ( I .EQ. 11 ) THEN
!  WRITE ( 19 , 6901 ) OMEGA
!  DO 25 L = 1 , 46
!   25   WRITE ( 19 , 1000 ) ABSTBL(L) , SCATBL(L) , BSCTBL(L)
    continue
  ELSE
    do L = 1 , 46
      READ ( 14 , 1000 ) A(L) , B(L) , C(L)
    end do
    FRACT = 2 * OMEGA - J
    FRACT2 = 1 - FRACT
    do L = 1 , 46
      ABSTBL(L) = ABSTBL(L) * FRACT2 + A(L) * FRACT
    end do
!  WRITE (19,6947) FRACT , FRACT2
!  WRITE (19,6901) OMEGA
!  DO 40 L = 1 , 46
!    WRITE ( 19 , 1000 ) ABSTBL(L) , SCATBL(L) , BSCTBL(L)
!   40  CONTINUE
  ENDIF

  REWIND 14
  CLOSE (UNIT = 14)

! Format statements

1000 FORMAT (3F12.7)
! 6947 FORMAT (//,' GETTBL.  INTERPOLATION FACTORS:',2(2X,F10.7))
! 6901 FORMAT (//,' LOOKUP TABLE FOR OMEGA:  ',F10.7,/)

  return
end

max_stars_repo_name: derekmorr/simsphere

max_issues_repo_name: derekmorr/simsphere

max_forks_repo_name: derekmorr/simsphere


text:
      SUBROUTINE profil3d(rmn, zmn, lreset)
      USE vmec_main
      USE vmec_params
      USE vsvd, torflux_svd => torflux
      USE vspline, ONLY: sknots, pknots, hstark, hthom
      USE realspace
      USE xstuff
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec), DIMENSION(ns,0:ntor,0:mpol1,ntmax),
     1    INTENT(inout) ::  rmn, zmn
      LOGICAL, INTENT(in) :: lreset
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: js, l, lk, lt, lz, ntype, m, n, mn
      REAL(rprec), DIMENSION(0:ntor,ntmax) :: rold, zold
      REAL(rprec) :: sm0, t1, facj, si, rax1, zax1
      INTEGER :: jcount, jk, k
      REAL(rprec), EXTERNAL :: torflux
C-----------------------------------------------

!
!                INDEX OF LOCAL VARIABLES
!
!        phip     radial derivative of phi/(2*pi) on half-grid
!        shalf    sqrt(s) ,two-dimensional array on half-grid
!        sqrts    sqrt(s), two-dimensional array on full-grid
!        wint     two-dimensional array for normalizing angle integrations
!        ireflect two-dimensional array for computing 2pi-v angle

      DO js = 1, ns
         phip(js:nrzt:ns) = phips(js)
      END DO

      phip(nrzt+1) = zero

      faclam(:ns,0:ntor,0:mpol1,:ntmax) = zero

      DO js = 1, ns
         si = hs*ABS(js - 1.5_dp)
         si = torflux(si)
         shalf(js:nrzt:ns) = SQRT(si)
         si = hs*(js - 1)
         si = torflux(si)
         sqrts(js:nrzt:ns) = SQRT(si)
      END DO
      sqrts(ns:nrzt:ns) = one     !!Avoid round-off

      lk = 0
      DO lt = 1, ntheta3
         DO lz = 1, nzeta
            lk = lk + 1
            IF (lasym) THEN
               DO js = 2, ns
                  wint(js+ns*(lk-1)) = one/(nzeta*ntheta1)
               END DO
            ELSE
               DO js = 2, ns
                  wint(js+ns*(lk-1)) = cosmui(lt,0)/mscale(0)
               END DO
            END IF
         END DO
      END DO

      shalf(nrzt+1) = 1
      wint(1:nrzt:ns) = 0

!
!     COMPUTE ARRAY FOR REFLECTING v = -v (ONLY needed for lasym)
!
      jcount = 0
      DO k = 1, nzeta
         jk = nzeta + 2 - k
         IF (k .eq. 1) jk = 1
         DO js = 1,ns
           jcount = jcount+1
           ireflect(jcount) = js+ns*(jk-1)           !Index for -zeta[k]
         ENDDO
      END DO

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

      DO js = 2,ns
         sm(js) = shalf(js)/sqrts(js)
         sp(js) = shalf(js+1)/sqrts(js)
      ENDDO
      sm(1) = 0
      sp(0) = 0
      sp(1) = sm(2)

!
!     COMPUTE INITIAL R AND Z FOURIER COEFFICIENTS,
!     FROM SCALED BOUNDARY VALUES, AND SCALXC ARRAY
!     (1/SQRTS FACTOR FOR ODD M VALUES)
!
!
!     ALLOW FOR lreset == F RESTART PERTURBATION OF FIXED-BDY (LFREEB=F)
!

      DO js = 1, ns
         si = sqrts(js)*sqrts(js)
         sm0 = one - si
         DO ntype = 1, ntmax
            DO m = 0, mpol1
               DO n = 0, ntor
                  t1 = one/(mscale(m)*nscale(n))
                  mn = n + ntor1*m
                  l = js + ns*mn + (ntype - 1)*mns
                  IF (MOD(m,2) .eq. 0) THEN
                     scalxc(l) = one
                  ELSE
                     scalxc(l) = one/MAX(sqrts(js),sqrts(2))
                  ENDIF
                  IF (.not.lreset .and. lfreeb) CYCLE
                  IF (m .eq. 0) THEN
                     rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + si*
     1                  (rmn_bdy(n,m,ntype)*t1 - rmn(ns,n,m,ntype))
                     zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + si*
     1                  (zmn_bdy(n,m,ntype)*t1 - zmn(ns,n,m,ntype))
                     IF (lreset) THEN
                        IF (js .eq. 1) THEN
                           rold(n,ntype) = rmn(1,n,0,ntype)
                           zold(n,ntype) = zmn(1,n,0,ntype)
                        ENDIF
                        IF (ntype .eq. rcc) rax1 = raxis_cc(n)
                        IF (ntype .eq. zcs) zax1 =-zaxis_cs(n)
                        IF (ntype .eq. rcs) rax1 =-raxis_cs(n)
                        IF (ntype .eq. zcc) zax1 = zaxis_cc(n)
                        IF (ntype.eq.rcc .or. ntype.eq.rcs)
     1                     rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + sm0*
     2                                        (rax1*t1 - rold(n,ntype))
                        IF (ntype.eq.zcs .or. ntype.eq.zcc)
     1                     zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + sm0*
     2                                        (zax1*t1 - zold(n,ntype))
                     ENDIF
                  ELSE
                     facj = sqrts(js)**m        !!TURN OFF NEXT 3 LINES IF THIS ONE ACTIVATED
!                       IF (MOD(m,2) .eq. 0) THEN
!                           facj = sqrts(js)*sqrts(js)
!                       ELSE IF (MOD(m,2) .eq. 1) THEN
!                          facj = sqrts(js)**MIN(m,3)
!                       END IF
                     rmn(js,n,m,ntype) = rmn(js,n,m,ntype) + (rmn_bdy
     1                  (n,m,ntype)*t1 - rmn(ns,n,m,ntype))*facj
                     zmn(js,n,m,ntype) = zmn(js,n,m,ntype) + (zmn_bdy
     1                  (n,m,ntype)*t1 - zmn(ns,n,m,ntype))*facj
                  ENDIF
               END DO
            END DO
         END DO
      END DO

      scalxc(1+irzloff:2*irzloff)   = scalxc(:irzloff)              !Z-components
      scalxc(1+2*irzloff:3*irzloff) = scalxc(:irzloff)              !Lamda-components

!
!     STORE PHIFAC IN XC(NEQS1) ARRAY ELEMENT
!     STORE DEL-RMSE IN XC(NEQS2) ARRAY ELEMENT
!
      xc(neqs1) = phifac
      scalxc(neqs1) = 1
      scalxc(neqs2) = 1

      IF (lrecon) THEN
!
!       COMPUTE SPLINE SEGMENTS FOR INTEGRALS OF FUNCTIONS IN SPLININT
!       THESE ARE FIXED DURING THE ITERATION SEQUENCE FOR FIXED SK,PK-NOTS,
!       BUT MAY CHANGE IF SKNOTS, PKNOTS CHANGE FOR DIFFERENT DATA FILES
!
        CALL setup_int (sknots, shalf(2), hstark, w_ia, w1_ia, u_ia,
     1       u1_ia, nk_ia, isnodes, ns1)
c-08-96 CALL setup_int(pknots,shalf(2),hthom,w_pa,w1_pa,u_pa,u1_pa,
c-08-96 >  nk_pa,ipnodes,ns1)
!
!       COMPUTE SPLINE SEGMENTS FOR INTEGRALS OF DERIVATIVES IN SPLININT
!
        CALL setup_int (sknots, sqrts, hstark, w_ib, w1_ib, u_ib,
     1       u1_ib, nk_ib, isnodes, ns)
        CALL setup_int (pknots, sqrts, hthom, w_pb, w1_pb, u_pb,
     1       u1_pb, nk_pb, ipnodes, ns)
      ENDIF

      END SUBROUTINE profil3d


text:
C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  December 27, 1994
C   Authors:        Esmond G. Ng and Barry W. Peyton
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C**********     CHORDR ..... CHILD REORDERING                ***********
C***********************************************************************
C***********************************************************************
C
C   PURPOSE:
C       REARRANGE THE CHILDREN OF EACH VERTEX SO THAT THE LAST ONE
C       MAXIMIZES (AMONG THE CHILDREN) THE NUMBER OF NONZEROS IN THE
C       CORRESPONDING COLUMN OF L.  ALSO DETERMINE AN NEW POSTORDERING
C       BASED ON THE STRUCTURE OF THE MODIFIED ELIMINATION TREE.
C
C   INPUT PARAMETERS:
C       NEQNS           -   NUMBER OF EQUATIONS.
C       (XADJ,ADJNCY)   -   THE ADJACENCY STRUCTURE.
C
C   UPDATED PARAMETERS:
C       (PERM,INVP)     -   ON INPUT, THE GIVEN PERM AND INVERSE PERM
C                           VECTORS.  ON OUTPUT, THE NEW PERM AND
C                           INVERSE PERM VECTORS OF THE NEW
C                           POSTORDERING.
C       COLCNT          -   COLUMN COUNTS IN L UNDER INITIAL ORDERING;
C                           MODIFIED TO REFLECT THE NEW ORDERING.
C
C   OUTPUT PARAMETERS:
C       PARENT          -   THE PARENT VECTOR OF THE ELIMINATION TREE
C                           ASSOCIATED WITH THE NEW ORDERING.
C
C   WORKING PARAMETERS:
C       FSON            -   THE FIRST SON VECTOR.
C       BROTHR          -   THE BROTHER VECTOR.
C       INVPOS          -   THE INVERSE PERM VECTOR FOR THE
C                           POSTORDERING.
C
C   PROGRAM SUBROUTINES:
C       BTREE2, EPOST2, INVINV.
C
C***********************************************************************
C
      SUBROUTINE  CHORDR (  NEQNS , XADJ  , ADJNCY, PERM  , INVP  ,
     &                      COLCNT, PARENT, FSON  , BROTHR, INVPOS  )
C
C***********************************************************************
C
        INTEGER             ADJNCY(*)     , BROTHR(*)     ,
     &                      COLCNT(*)     , FSON(*)       ,
     &                      INVP(*)       , INVPOS(*)     ,
     &                      PARENT(*)     , PERM(*)
C
        INTEGER             XADJ(*)
        INTEGER             NEQNS
C
C***********************************************************************
C
C       ----------------------------------------------------------
C       COMPUTE A BINARY REPRESENTATION OF THE ELIMINATION TREE,
C       SO THAT EACH "LAST CHILD" MAXIMIZES AMONG ITS SIBLINGS THE
C       NUMBER OF NONZEROS IN THE CORRESPONDING COLUMNS OF L.
C       ----------------------------------------------------------
        CALL  BTREE2  ( NEQNS , PARENT, COLCNT, FSON  , BROTHR,
     &                  INVPOS                                  )
C
C       ----------------------------------------------------
C       POSTORDER THE ELIMINATION TREE (USING THE NEW BINARY
C       REPRESENTATION.
C       ----------------------------------------------------
        CALL  EPOST2  ( NEQNS , FSON  , BROTHR, INVPOS, PARENT,
     &                  COLCNT, PERM                            )
C
C       --------------------------------------------------------
C       COMPOSE THE ORIGINAL ORDERING WITH THE NEW POSTORDERING.
C       --------------------------------------------------------
        CALL  INVINV  ( NEQNS , INVP  , INVPOS, PERM    )
C
        RETURN
      END

max_stars_repo_name: Pangqiyuangh/SeIInv

max_issues_repo_name: Pangqiyuangh/SeIInv

max_forks_repo_name: Pangqiyuangh/SeIInv


text:
About
Classroom Survivor, the comic that distinguished Users/JohnDudek as a competent comedian and comic artist, was brought onto the scene in the school year of 0203. The original idea behind the story was that eight students from a high school class would be locked in that classroom until only one was left surviving. This story was backed with comical interpretations of various students within the classroom, and their antics. The comic gained a large fan base within the underground comic community at Holmes Junior High School, and now at Davis Senior High

Issues
  The original Classroom Survivor is currently lost.
  The second Classroom Survivor, written in the 0304 school year, is hidden away somewhere in Users/JohnDudeks room, along with a thousand other drawings and comics.
  Last year, Classroom Survivor failed to even start after a failure of ideas.

It is rumoured that Users/JohnDudek is currently working on character sketches for a new 0506 Classroom Survivor, but rumours have not been proven true.

A cover picture will be posted soon for the 0304 Issue

Other Work
  Ghost: The Beginning: The story of a cat and a fox who get lost in another dimension
  S.F.A.: Cowritten with Walter Moulton, a stick figure comic series about a team of superheroes
  The Enlightenment: Cowritten with Walter Moulton, a weekly edition story about three guys trying to find enlightenment, for their own reasons. The idea died away after a while due to a lack of fan base.

20060518 14:16:54 nbsp Hey Jon, how bout an update? Users/ArlenAbraham


text:
! a module for storing the geometric information so we don't have to pass it
!
! This module provides the coordinate value for the left edge of a base-state
! zone (r_edge_loc) and the zone center (r_cc_loc).  As always, it is assumed that
! the base state arrays begin with index 0, not 1.

module geometry

  use bl_types
  use ml_layout_module

  implicit none

  integer   , save :: nlevs_radial
  integer   , save :: spherical
  real(dp_t), save :: center(3)
  integer   , save :: nr_fine, nr_irreg
  real(dp_t), save :: dr_fine
  real(dp_t), allocatable, save :: dr(:), r_cc_loc(:,:), r_edge_loc(:,:)
  integer   , allocatable, save :: numdisjointchunks(:)
  integer   , allocatable, save :: r_start_coord(:,:), r_end_coord(:,:), nr(:)
  integer   , allocatable, save :: anelastic_cutoff_coord(:)
  integer   , allocatable, save :: base_cutoff_density_coord(:)
  integer   , allocatable, save :: burning_cutoff_density_coord(:)
  real(dp_t), save :: sin_theta, cos_theta, omega
  logical   , save :: radial_initialized = .false., cutoff_initialized = .false.
  logical   , save :: multilevel_initialized = .false.

  private

  public :: nlevs_radial, spherical, center, nr_fine, dr_fine, nr_irreg
  public :: dr, r_cc_loc, r_edge_loc
  public :: numdisjointchunks
  public :: r_start_coord, r_end_coord, nr
  public :: anelastic_cutoff_coord
  public :: base_cutoff_density_coord
  public :: burning_cutoff_density_coord
  public :: sin_theta, cos_theta, omega
  public :: init_spherical, init_center, init_radial, init_cutoff, &
       initialize_dx, &
       compute_cutoff_coords, init_multilevel, init_rotation, destroy_geometry

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine init_spherical()

    use probin_module, only: spherical_in

    spherical = spherical_in

  end subroutine init_spherical

  subroutine initialize_dx(dx,mba,num_levs)

    use probin_module, only: prob_lo, prob_hi

    real(dp_t)       , pointer     :: dx(:,:)
    type(ml_boxarray), intent(in ) :: mba
    integer          , intent(in ) :: num_levs

    integer :: n,d,dm

    dm = mba%dim

    allocate(dx(num_levs,dm))

    do d=1,dm
       dx(1,d) = (prob_hi(d)-prob_lo(d)) / real(extent(mba%pd(1),d),kind=dp_t)
    end do
    do n=2,num_levs
       dx(n,:) = dx(n-1,:) / mba%rr(n-1,:)
    end do

  end subroutine initialize_dx

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine init_center()

    use probin_module, only: prob_lo, prob_hi, octant, dm_in
    use bl_constants_module

    if (.not. octant) then
       center(1:dm_in) = HALF * (prob_lo(1:dm_in) + prob_hi(1:dm_in))
    else
       if (.not. (spherical == 1 .and. dm_in == 3 .and. &
                  prob_lo(1) == ZERO .and. &
                  prob_lo(2) == ZERO .and. &
                  prob_lo(3) == ZERO)) then
          call bl_error("ERROR: octant requires spherical with prob_lo = 0.0")
       endif
       center(1:dm_in) = ZERO
    endif

  end subroutine init_center

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine init_radial(num_levs,mba)

    ! computes dr, nr, r_cc_loc, r_edge_loc

    use probin_module, only: prob_lo
    use bl_constants_module

    integer          , intent(in   ) :: num_levs
    type(ml_boxarray), intent(inout) :: mba

    ! local
    integer :: n,i

    if (spherical .eq. 0) then

       allocate(dr(num_levs))
       allocate(nr(num_levs))

       allocate(  r_cc_loc(num_levs,0:nr_fine-1))
       allocate(r_edge_loc(num_levs,0:nr_fine))

       nr(num_levs) = nr_fine
       dr(num_levs) = dr_fine
       do n=num_levs-1,1,-1
          nr(n) = nr(n+1)/mba%rr(n,mba%dim)
          dr(n) = dr(n+1)*dble(mba%rr(n,mba%dim))
       enddo

       do n=1,num_levs
          do i = 0,nr(n)-1
             r_cc_loc(n,i) = prob_lo(mba%dim) + (dble(i)+HALF)*dr(n)
          end do
          do i = 0,nr(n)
             r_edge_loc(n,i) = prob_lo(mba%dim) + (dble(i))*dr(n)
          end do
       enddo

    else

       allocate(dr(1))
       allocate(nr(1))

       allocate(  r_cc_loc(1,0:nr_fine-1))
       allocate(r_edge_loc(1,0:nr_fine))

       nr(1) = nr_fine
       dr(1) = dr_fine

       do i=0,nr_fine-1
          r_cc_loc(1,i) = (dble(i)+HALF)*dr(1)
       end do

       do i=0,nr_fine
          r_edge_loc(1,i) = (dble(i))*dr(1)
       end do

    end if

    radial_initialized = .true.

  end subroutine init_radial

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine init_cutoff(num_levs)

    ! allocates the cutoff coordinate arrays

    integer, intent(in)    :: num_levs

    if (spherical .eq. 0) then
       allocate(      anelastic_cutoff_coord(num_levs))
       allocate(   base_cutoff_density_coord(num_levs))
       allocate(burning_cutoff_density_coord(num_levs))
    else
       allocate(      anelastic_cutoff_coord(1))
       allocate(   base_cutoff_density_coord(1))
       allocate(burning_cutoff_density_coord(1))
    end if

    cutoff_initialized = .true.

  end subroutine init_cutoff

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine compute_cutoff_coords(rho0)

    use probin_module, only: anelastic_cutoff, base_cutoff_density, burning_cutoff_density

    real(kind=dp_t), intent(in   ) :: rho0(:,0:)

    ! local
    integer :: i,n,r,which_lev
    logical :: found

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! compute the coordinates of the anelastic cutoff
    found = .false.

    ! find the finest level containing the anelastic cutoff density,
    ! and set the anelastic cutoff coord for this level
    do n=nlevs_radial,1,-1
       do i=1,numdisjointchunks(n)

          if (.not. found) then
             do r=r_start_coord(n,i),r_end_coord(n,i)
                if (rho0(n,r) .le. anelastic_cutoff) then
                   anelastic_cutoff_coord(n) = r
                   which_lev = n
                   found = .true.
                   exit
                end if
             end do
          end if

       end do
    end do

    ! if the anelastic cutoff density was not found anywhere, then set
    ! it to above the top of the domain on the finest level
    if (.not. found) then
       which_lev = nlevs_radial
       anelastic_cutoff_coord(nlevs_radial) = nr(nlevs_radial)
    endif

    ! set the anelastic cutoff coordinate on the finer levels
    do n=which_lev+1,nlevs_radial
       anelastic_cutoff_coord(n) = 2*anelastic_cutoff_coord(n-1)+1
    end do

    ! set the anelastic cutoff coordinate on the coarser levels
    do n=which_lev-1,1,-1
       if (mod(anelastic_cutoff_coord(n+1),2) .eq. 0) then
          anelastic_cutoff_coord(n) = anelastic_cutoff_coord(n+1) / 2
       else
          anelastic_cutoff_coord(n) = anelastic_cutoff_coord(n+1) / 2 + 1
       end if
    end do
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! compute the coordinates of the base cutoff density
    found = .false.

    ! find the finest level containing the base cutoff density,
    ! and set the base cutoff coord for this level
    do n=nlevs_radial,1,-1
       do i=1,numdisjointchunks(n)

          if (.not. found) then
             do r=r_start_coord(n,i),r_end_coord(n,i)
                if (rho0(n,r) .le. base_cutoff_density) then
                   base_cutoff_density_coord(n) = r
                   which_lev = n
                   found = .true.
                   exit
                end if
             end do
          end if

       end do
    end do

    ! if the base cutoff density was not found anywhere, then set
    ! it to above the top of the domain on the finest level
    if (.not. found) then
       which_lev = nlevs_radial
       base_cutoff_density_coord(nlevs_radial) = nr(nlevs_radial)
    endif

    ! set the base cutoff coordinate on the finer levels
    do n=which_lev+1,nlevs_radial
       base_cutoff_density_coord(n) = 2*base_cutoff_density_coord(n-1)+1
    end do

    ! set the base cutoff coordinate on the coarser levels
    do n=which_lev-1,1,-1
       if (mod(base_cutoff_density_coord(n+1),2) .eq. 0) then
          base_cutoff_density_coord(n) = base_cutoff_density_coord(n+1) / 2
       else
          base_cutoff_density_coord(n) = base_cutoff_density_coord(n+1) / 2 + 1
       end if
    end do
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! compute the coordinates of the burning cutoff density
    found = .false.

    ! find the finest level containing the burning cutoff density,
    ! and set the burning cutoff coord for this level
    do n=nlevs_radial,1,-1
       do i=1,numdisjointchunks(n)

          if (.not. found) then
             do r=r_start_coord(n,i),r_end_coord(n,i)
                if (rho0(n,r) .le. burning_cutoff_density) then
                   burning_cutoff_density_coord(n) = r
                   which_lev = n
                   found = .true.
                   exit
                end if
             end do
          end if

       end do
    end do

    ! if the burning cutoff density was not found anywhere, then set
    ! it to above the top of the domain on the finest level
    if (.not. found) then
       which_lev = nlevs_radial
       burning_cutoff_density_coord(nlevs_radial) = nr(nlevs_radial)
    endif

    ! set the burning cutoff coordinate on the finer levels
    do n=which_lev+1,nlevs_radial
       burning_cutoff_density_coord(n) = 2*burning_cutoff_density_coord(n-1)+1
    end do

    ! set the burning cutoff coordinate on the coarser levels
    do n=which_lev-1,1,-1
       if (mod(burning_cutoff_density_coord(n+1),2) .eq. 0) then
          burning_cutoff_density_coord(n) = burning_cutoff_density_coord(n+1) / 2
       else
          burning_cutoff_density_coord(n) = burning_cutoff_density_coord(n+1) / 2 + 1
       end if
    end do
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  end subroutine compute_cutoff_coords

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine init_multilevel(mf)

    ! computes numdisjointchunks, r_start_coord, r_end_coord

    use bl_constants_module

    type(multifab) , intent(in   ) :: mf(:)

    ! local
    integer :: i,j,n,maxdisjointchunks,temp,dm,nlevs

    integer :: lo(get_dim(mf(1))),hi(get_dim(mf(1)))

    type(layout)   :: la
    type(boxarray) ::  validboxarr(size(mf))
    type(boxarray) :: diffboxarray(size(mf))
    type(box)      ::  boundingbox(size(mf))

    dm = get_dim(mf(1))
    nlevs = size(mf)

    if (spherical .eq. 0) then

       ! create a "bounding box" for each level
       ! this the smallest possible box that fits every grid at a particular level
       ! this even includes the empty spaces if there are gaps between grids
       do n=1,nlevs
          boundingbox(n) = get_box(mf(n)%la,1)
          do i=2, nboxes(mf(n)%la)
             boundingbox(n) = box_bbox(boundingbox(n),get_box(mf(n)%la,i))
          end do
       end do

       ! compute diffboxarray
       ! each box in diffboxarray corresponds to an "empty space" between valid regions
       ! at each level, excluding the coarsest level.
       ! I am going to use this to compute all of the intermediate r_start_coord and
       ! r_end_coord
       do n=1,nlevs
          call boxarray_build_copy(validboxarr(n),get_boxarray(mf(n)))
          la = get_layout(mf(n))
          call layout_boxarray_diff(diffboxarray(n),boundingbox(n),la)
          call boxarray_simplify(diffboxarray(n))
       end do

       if (allocated(numdisjointchunks)) then
          deallocate(numdisjointchunks)
       end if
       allocate(numdisjointchunks(nlevs))

       do n=1,nlevs
          numdisjointchunks(n) = nboxes(diffboxarray(n)) + 1
       end do

       maxdisjointchunks = 1
       do n=2,nlevs
          maxdisjointchunks = max(maxdisjointchunks,numdisjointchunks(n))
       end do

       if (allocated(r_start_coord)) then
          deallocate(r_start_coord)
       end if
       allocate(r_start_coord(nlevs,maxdisjointchunks))
       if (allocated(r_end_coord)) then
          deallocate(r_end_coord)
       end if
       allocate(r_end_coord(nlevs,maxdisjointchunks))

       do n=1,nlevs

          lo = lwb(boundingbox(n))
          hi = upb(boundingbox(n))
          r_start_coord(n,1) = lo(dm)
          r_end_coord(n,1)   = hi(dm)

          if (nboxes(diffboxarray(n)) .gt. 0) then
             do i=1,nboxes(diffboxarray(n))
                lo = lwb(boxarray_get_box(diffboxarray(n),i))
                hi = upb(boxarray_get_box(diffboxarray(n),i))
                r_start_coord(n,i+1) = hi(dm)+1
                r_end_coord(n,i+1)   = lo(dm)-1
             end do

             ! sort start and end coords
             do i=1,nboxes(diffboxarray(n))+1
                do j=1,nboxes(diffboxarray(n))+1-i

                   if (r_start_coord(n,j) .gt. r_start_coord(n,j+1)) then
                      temp = r_start_coord(n,j+1)
                      r_start_coord(n,j+1) = r_start_coord(n,j)
                      r_start_coord(n,j)   = temp
                   end if
                   if (r_end_coord(n,j) .gt. r_end_coord(n,j+1)) then
                      temp = r_end_coord(n,j+1)
                      r_end_coord(n,j+1) = r_end_coord(n,j)
                      r_end_coord(n,j)   = temp
                   end if

                end do
             end do
          end if

       end do

       do n=1,nlevs
          call destroy(validboxarr(n))
          call destroy(diffboxarray(n))
       end do

    else

       if (allocated(numdisjointchunks)) deallocate(numdisjointchunks)
       if (allocated(r_start_coord)) deallocate(r_start_coord)
       if (allocated(r_end_coord)) deallocate(r_end_coord)

       allocate(numdisjointchunks(1))
       allocate(r_start_coord(1,1))
       allocate(r_end_coord(1,1))

       numdisjointchunks(1) = 1
       r_start_coord(1,1) = 0
       r_end_coord(1,1) = nr_fine-1

    end if

    multilevel_initialized = .true.
  end subroutine init_multilevel

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! rotation
!
! co_latitude, rotation_radius, theta_in_rad, sin_theta and cos_theta
! are only important when wanting to rotate a plane-parallel patch
! which lives at an angle co_latitude from the rotation axis and at a
! distance rotation_radius from center().  mk_vel_force should
! calculate the rotational forcing terms for the points within the
! patch.
!
! for spherical problems, the only important variable from
! init_rotation() is omega, the angular frequency - mk_vel_force will
! calculate the appropriate terms for a given coordinate
!
! NOTE: it is currently unclear how to handle BC's with a
!       plane-parallel patch and it is not advisable to utilize
!       rotation for such problems.
!

  subroutine init_rotation()

    use probin_module, only: rotational_frequency, co_latitude
    use bl_constants_module, only: M_PI, ZERO

    real(dp_t) :: theta_in_rad

    theta_in_rad = M_PI * co_latitude / 180_dp_t

    sin_theta = sin(theta_in_rad)
    cos_theta = cos(theta_in_rad)

    omega = 2 * M_PI * rotational_frequency

  end subroutine init_rotation

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine destroy_geometry()

    if(radial_initialized) then
      deallocate(dr, nr, r_cc_loc, r_edge_loc)
    endif
    if(cutoff_initialized) then
      deallocate(anelastic_cutoff_coord,base_cutoff_density_coord)
      deallocate(burning_cutoff_density_coord)
    endif
    if(multilevel_initialized) then
      deallocate(numdisjointchunks,r_start_coord,r_end_coord)
    endif

  end subroutine destroy_geometry

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

end module geometry

max_stars_repo_name: sailoridy/MAESTRO

max_issues_repo_name: sailoridy/MAESTRO

max_forks_repo_name: sailoridy/MAESTRO


text:
 Users/PrestaSchraeder
http://1.bp.blogspot.com/eBiph53M0kY/TYTWHIuix7I/AAAAAAAAAKk/mXPADzDV_GA/s320/forever_alone_meme.jpg

20110414 13:03:34 nbsp Welcome to the Wiki! Users/TomGarberson

20110414 21:40:20 nbsp Hi Tom, thanks for the info Users/PrestaSchraeder


    Program zunmtr_example

!     ZUNMTR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zscal
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: dstebz, zhetrd, zstein, zunmtr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: vl, vu
      Integer :: i, ifail, info, k, lda, ldc, lwork, m, n, nsplit
      Character (1) :: uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), c(:, :), tau(:), work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:), w(:)
      Integer, Allocatable :: iblock(:), ifailv(:), isplit(:), iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZUNMTR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      lwork = 64*n
      Allocate (a(lda,n), c(ldc,n), tau(n), work(lwork), d(n), e(n), &
        rwork(5*n), w(n), iblock(n), ifailv(n), isplit(n), iwork(3*n))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
      End If

!     Reduce A to tridiagonal form T = (Q**H)*A*Q
      Call zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)

!     Calculate the two smallest eigenvalues of T (same as A)

      Call dstebz('I', 'B', n, vl, vu, 1, 2, zero, d, e, m, nsplit, w, iblock, &
        isplit, rwork, iwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:m)

!       Calculate the eigenvectors of T, storing the result in C
        Call zstein(n, d, e, m, w, iblock, isplit, c, ldc, rwork, iwork, &
          ifailv, info)

        If (info>0) Then
          Write (nout, *) 'Failure to converge.'
        Else

!         Calculate the eigenvectors of A = Q * (eigenvectors of T)
          Call zunmtr('Left', uplo, 'No transpose', n, m, a, lda, tau, c, ldc, &
            work, lwork, info)

!         Print eigenvectors
          Write (nout, *)
          Flush (nout)

!         Normalize the eigenvectors so that the element of largest absolute
!         value is real.
          Do i = 1, m
            rwork(1:n) = abs(c(1:n,i))
            k = maxloc(rwork(1:n), 1)
            Call zscal(n, conjg(c(k,i))/cmplx(abs(c(k,i)),kind=dp), c(1,i), 1)
          End Do

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, m, &
            c, ldc, 'Bracketed', 'F7.4', 'Eigenvectors', 'Integer', rlabs, &
            'Integer', clabs, 80, 0, ifail)

        End If
      End If

100   Format (8X, 4(F7.4,11X,:))
    End Program


text:
!==============================================================================!
  real function Y_Plus_Rough_Walls(u_tau, wall_dist, kin_vis)
!------------------------------------------------------------------------------!
!   Calculates y+ for rough walls.                                             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: TINY
  use Rans_Mod,  only: z_o
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real :: u_tau, wall_dist, kin_vis
!==============================================================================!

  Y_Plus_Rough_Walls = (wall_dist + z_o) * u_tau / kin_vis

  end function

max_stars_repo_name: MassimoBorrelliPhysicist/T-Flows

max_issues_repo_name: MassimoBorrelliPhysicist/T-Flows

max_forks_repo_name: MassimoBorrelliPhysicist/T-Flows


text:
      double complex function amp_3gam1g_mppppm(j1,j2,j3,j4,j5,j6,za,zb)
c--- -i*Amplitude for the process
c---       0  -->  qb(j5) + q(j6) + g(j1) + gam(j2) + gam(j3) + gam(j4)
c--- helicities:     +       -      -         +         +         +
c---
c--- Taken from "Multi-Photon Amplitudes for Next-to-Leading Order QCD"
c---  V. Del Duca, W. Kilgore and F. Maltoni, hep-ph/9910253
c---
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6

c--- Equation (2.9) with r=1, m=3 and labels permuted appropriately
c--- negative helicity gluon i=1
      amp_3gam1g_mppppm=
     & za(j5,j1)*za(j6,j1)**3/(za(j5,j6)*za(j6,j1)*za(j1,j5))
     & *za(j6,j5)/(za(j6,j2)*za(j2,j5))
     & *za(j6,j5)/(za(j6,j3)*za(j3,j5))
     & *za(j6,j5)/(za(j6,j4)*za(j4,j5))

      return
      end

      double complex function amp_3gam1g_pmpppm(j1,j2,j3,j4,j5,j6,za,zb)
c--- -i*Amplitude for the process
c---       0  -->  qb(j5) + q(j6) + g(j1) + gam(j2) + gam(j3) + gam(j4)
c--- helicities:     +       -      +         -         +         +
c---
c--- Taken from "Multi-Photon Amplitudes for Next-to-Leading Order QCD"
c---  V. Del Duca, W. Kilgore and F. Maltoni, hep-ph/9910253
c---
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6

c--- Equation (2.9) with r=1, m=3 and labels permuted appropriately
c--- negative helicity photon i=2
      amp_3gam1g_pmpppm=
     & za(j5,j2)*za(j6,j2)**3/(za(j5,j6)*za(j6,j1)*za(j1,j5))
     & *za(j6,j5)/(za(j6,j2)*za(j2,j5))
     & *za(j6,j5)/(za(j6,j3)*za(j3,j5))
     & *za(j6,j5)/(za(j6,j4)*za(j4,j5))

      return
      end

      double complex function amp_3gam1g_ppmppm(j1,j2,j3,j4,j5,j6,za,zb)
c--- -i*Amplitude for the process
c---       0  -->  qb(j5) + q(j6) + g(j1) + gam(j2) + gam(j3) + gam(j4)
c--- helicities:     +       -      +         +         -         +
c---
c--- Taken from "Multi-Photon Amplitudes for Next-to-Leading Order QCD"
c---  V. Del Duca, W. Kilgore and F. Maltoni, hep-ph/9910253
c---
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6

c--- Equation (2.9) with r=1, m=3 and labels permuted appropriately
c--- negative helicity photon i=3
      amp_3gam1g_ppmppm=
     & za(j5,j3)*za(j6,j3)**3/(za(j5,j6)*za(j6,j1)*za(j1,j5))
     & *za(j6,j5)/(za(j6,j2)*za(j2,j5))
     & *za(j6,j5)/(za(j6,j3)*za(j3,j5))
     & *za(j6,j5)/(za(j6,j4)*za(j4,j5))

      return
      end

      double complex function amp_3gam1g_pppmpm(j1,j2,j3,j4,j5,j6,za,zb)
c--- -i*Amplitude for the process
c---       0  -->  qb(j5) + q(j6) + g(j1) + gam(j2) + gam(j3) + gam(j4)
c--- helicities:     +       -      +         +         +         -
c---
c--- Taken from "Multi-Photon Amplitudes for Next-to-Leading Order QCD"
c---  V. Del Duca, W. Kilgore and F. Maltoni, hep-ph/9910253
c---
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6

c--- Equation (2.9) with r=1, m=3 and labels permuted appropriately
c--- negative helicity photon i=4
      amp_3gam1g_pppmpm=
     & za(j5,j4)*za(j6,j4)**3/(za(j5,j6)*za(j6,j1)*za(j1,j5))
     & *za(j6,j5)/(za(j6,j2)*za(j2,j5))
     & *za(j6,j5)/(za(j6,j3)*za(j3,j5))
     & *za(j6,j5)/(za(j6,j4)*za(j4,j5))

      return
      end

      double complex function amp_3gam1g_mmpppm(j1,j2,j3,j4,j5,j6,za,zb)
c--- -i*Amplitude for the process
c---       0  -->  qb(j5) + q(j6) + g(j1) + gam(j2) + gam(j3) + gam(j4)
c--- helicities:     +       -      -         -         +         +
c---
c--- Taken from "Multi-Photon Amplitudes for Next-to-Leading Order QCD"
c---  V. Del Duca, W. Kilgore and F. Maltoni, hep-ph/9910253
c---
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5,j6,k1(2),k2(2),k3(2),k4(2),i12,i34
      double precision t

c--- Equation (5.1)
      amp_3gam1g_mmpppm=
     & s(j5,j6)*t(j6,j1,j2)
     & *(za(j6,j3)*zb(j3,j5)+za(j6,j4)*zb(j4,j5))
     & /(za(j5,j3)*za(j3,j6)*za(j5,j4)*za(j4,j6)
     &  *zb(j5,j1)*zb(j1,j6)*zb(j5,j2)*zb(j2,j6))

c--- Initialize arrays for permutations
      k1(1)=j1
      k2(1)=j2
      k1(2)=j2
      k2(2)=j1
      k3(1)=j3
      k4(1)=j4
      k3(2)=j4
      k4(2)=j3

      do i12=1,2
      do i34=1,2
c--- There appear to be errors in this equation in the paper
c--- (even in the journal version) that I have corrected here
      amp_3gam1g_mmpppm=amp_3gam1g_mmpppm
     & +zb(j5,k3(i34))*za(j6,k2(i12))
     & *(zb(k4(i34),j5)*za(j5,k1(i12))
     &  +zb(k4(i34),k3(i34))*za(k3(i34),k1(i12)))
     & /(za(j5,k3(i34))*zb(j6,k2(i12))*za(j6,k4(i34))*zb(j5,k1(i12)))
     & /t(j6,k4(i34),k2(i12))
      enddo
      enddo

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
module model_spalart_allmaras_turbulent_model_fields
#include <messenger.h>
    use mod_kinds,              only: rk
    use mod_constants,          only: ZERO, HALF, ONE, TWO, THREE
    use mod_fluid,              only: cp
    use mod_spalart_allmaras,   only: SA_c_v1, SA_Pr_t
    use type_model,             only: model_t
    use type_chidg_worker,      only: chidg_worker_t
    use DNAD_D

    implicit none

    !>  An equation of state model for an ideal gas.
    !!
    !!  Model Fields:
    !!      - Pressure
    !!      - Temperature
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: spalart_allmaras_turbulent_model_fields_t

    contains

        procedure   :: init
        procedure   :: compute

    end type spalart_allmaras_turbulent_model_fields_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(spalart_allmaras_turbulent_model_fields_t), intent(inout)   :: self

        call self%set_name('Spalart Allmaras Turbulent Model Fields')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Turbulent Viscosity')
        call self%add_model_field('Second Coefficient of Turbulent Viscosity')
        call self%add_model_field('Turbulent Thermal Conductivity')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the contributions to:
    !!      'Viscosity'
    !!      'Second Coefficient of Viscosity'
    !!      'Thermal Conductivity'
    !!
    !!  from the turbulent eddy viscosity.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(spalart_allmaras_turbulent_model_fields_t),     intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable ::              &
            density, mu, nu, density_nutilde, mu_t, nutilde, lamda_t,   &
            chi, f_v1, k_t

        !
        ! Interpolate solution to quadrature nodes
        !
        density         = worker%get_field('Density',           'value')
        density_nutilde = worker%get_field('Density * NuTilde', 'value')

        !
        ! Get viscosity: compute nu, nutilde
        !
        mu      = worker%get_field('Laminar Viscosity', 'value')
        nu      = mu/density
        nutilde = density_nutilde/density

        !
        ! Compute chi, f_v1
        !
        chi = nutilde/nu
        f_v1 = chi*chi*chi/(chi*chi*chi + SA_c_v1*SA_c_v1*SA_c_v1)

        !
        ! Initialize derivatives, compute mu_t
        !
        mu_t = density
        where (nutilde >= 0)
            mu_t = density * nutilde * f_v1
        else where
            mu_t = ZERO
        end where

        !
        ! Compute:
        !   - Second Coefficient of Turbulent Viscosity, Stokes' Hypothesis.
        !   - Turbulent Thermal Conductivity, Reynolds' analogy.
        !
        lamda_t = (-TWO/THREE)*mu_t
        k_t = cp*mu_t/SA_Pr_t

        call worker%store_model_field('Turbulent Viscosity',                       'value', mu_t   )
        call worker%store_model_field('Second Coefficient of Turbulent Viscosity', 'value', lamda_t)
        call worker%store_model_field('Turbulent Thermal Conductivity',            'value', k_t    )

    end subroutine compute
    !***************************************************************************************

end module model_spalart_allmaras_turbulent_model_fields

max_stars_repo_name: wanglican/ChiDG

max_issues_repo_name: haohb/ChiDG

max_forks_repo_name: haohb/ChiDG


text:
needs debugger

: f inline{ 89 C3 AD 89 C1 21 D9 AD F7 D3 21 D8 09 C8 }  ;

see f

max_stars_repo_name: ronaaron/reva

max_issues_repo_name: ronaaron/reva

max_forks_repo_name: ronaaron/reva


text:
!RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | FileCheck %s --check-prefixes="FIRDialect,OMPDialect"
!RUN: %flang_fc1 -emit-fir -fopenmp %s -o - | fir-opt --cfg-conversion | fir-opt --fir-to-llvm-ir | FileCheck %s --check-prefixes="OMPDialect,LLVMDialect"

!===============================================================================
! Parallel sections construct
!===============================================================================

!FIRDialect: func @_QPomp_parallel_sections
subroutine omp_parallel_sections(x, y)
  integer, intent(inout) :: x, y
  !OMPDialect: omp.parallel {
  !OMPDialect: omp.sections {
  !$omp parallel sections
    !OMPDialect: omp.section {
    !$omp section
      !FIRDialect: fir.load
      !FIRDialect: arith.addi
      !FIRDialect: fir.store
      x = x + 12
      !OMPDialect: omp.terminator
    !OMPDialect: omp.section {
    !$omp section
      !FIRDialect: fir.load
      !FIRDialect: arith.subi
      !FIRDialect: fir.store
      y = y - 5
      !OMPDialect: omp.terminator
  !OMPDialect: omp.terminator
  !OMPDialect: omp.terminator
  !$omp end parallel sections
end subroutine omp_parallel_sections

!===============================================================================
! Parallel sections construct with allocate clause
!===============================================================================

!FIRDialect: func @_QPomp_parallel_sections
subroutine omp_parallel_sections_allocate(x, y)
  use omp_lib
  integer, intent(inout) :: x, y
  !FIRDialect: %[[allocator:.*]] = arith.constant 1 : i32
  !LLVMDialect: %[[allocator:.*]] = llvm.mlir.constant(1 : i32) : i32
  !OMPDialect: omp.parallel allocate(%[[allocator]] : i32 -> %{{.*}} : !fir.ref<i32>) {
  !OMPDialect: omp.sections {
  !$omp parallel sections allocate(omp_high_bw_mem_alloc: x)
    !OMPDialect: omp.section {
    !$omp section
      x = x + 12
      !OMPDialect: omp.terminator
    !OMPDialect: omp.section {
    !$omp section
      y = y + 5
      !OMPDialect: omp.terminator
  !OMPDialect: omp.terminator
  !OMPDialect: omp.terminator
  !$omp end parallel sections
end subroutine omp_parallel_sections_allocate

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


! Like array_constructor_6.f90, but check constructors that apply
! an elemental function to an array.
! { dg-do run }
program main
  implicit none
  call build (200)
contains
  subroutine build (order)
    integer :: order, i

    call test (order, (/ (abs ((/ i, -i, -i * 2 /)), i = 1, order) /))
    call test (order, abs ((/ ((/ -i, -i, i * 2 /), i = 1, order) /)))
    call test (order, (/ abs ((/ ((/ i, i, -i * 2 /), i = 1, order) /)) /))
  end subroutine build

  subroutine test (order, values)
    integer, dimension (3:) :: values
    integer :: order, i

    if (size (values, dim = 1) .ne. order * 3) STOP 1
    do i = 1, order
      if (values (i * 3) .ne. i) STOP 2
      if (values (i * 3 + 1) .ne. i) STOP 3
      if (values (i * 3 + 2) .ne. i * 2) STOP 4
    end do
  end subroutine test
end program main


text: The turkey dump is when a freshman goes back to their home town over Thanksgiving break and dumps their romantic partner from high school.