text:
*DECK DBVDER
      SUBROUTINE DBVDER (X, Y, YP, G, IPAR)
C***BEGIN PROLOGUE  DBVDER
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (BVDER-S, DBVDER-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     NFC = Number of base solution vectors
C
C     NCOMP = Number of components per solution vector
C
C              1 -- Nonzero particular solution
C     INHOMO =
C              2 or 3 -- Zero particular solution
C
C             0 -- Inhomogeneous vector term G(X) identically zero
C     IGOFX =
C             1 -- Inhomogeneous vector term G(X) not identically zero
C
C     G = Inhomogeneous vector term G(X)
C
C     XSAV = Previous value of X
C
C     C = Normalization factor for the particular solution
C
C           0   ( if  NEQIVP = 0 )
C     IVP =
C           Number of differential equations integrated due to
C           the original boundary value problem   ( if  NEQIVP .GT. 0 )
C
C     NOFST - For problems with auxiliary initial value equations,
C             NOFST communicates to the routine DFMAT how to access
C             the dependent variables corresponding to this initial
C             value problem.  For example, during any call to DFMAT,
C             the first dependent variable for the initial value
C             problem is in position  Y(NOFST + 1).
C             See example in SAND77-1328.
C **********************************************************************
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DML8SZ, DMLIVP
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910701  Corrected ROUTINES CALLED section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920618  Minor restructuring of code.  (RWC, WRB)
C***END PROLOGUE  DBVDER
      INTEGER IGOFX, INHOMO, IPAR, IVP, J, K, L, NA, NCOMP, NFC, NOFST
      DOUBLE PRECISION C, G(*), X, XSAV, Y(*), YP(*)
C
C **********************************************************************
C
      COMMON /DML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC
C
C **********************************************************************
C     The COMMON block below is used to communicate with the user
C     supplied subroutine DFMAT.  The user should not alter this
C     COMMON block.
C
      COMMON /DMLIVP/ NOFST
C **********************************************************************
C
C***FIRST EXECUTABLE STATEMENT  DBVDER
      IF (IVP .GT. 0) CALL DUIVP(X,Y(IVP+1),YP(IVP+1))
      NOFST = IVP
      NA = 1
      DO 10 K=1,NFC
         CALL DFMAT(X,Y(NA),YP(NA))
         NOFST = NOFST - NCOMP
         NA = NA + NCOMP
   10 CONTINUE
C
      IF (INHOMO .NE. 1) RETURN
      CALL DFMAT(X,Y(NA),YP(NA))
C
      IF (IGOFX .EQ. 0) RETURN
      IF (X .NE. XSAV) THEN
         IF (IVP .EQ. 0) CALL DGVEC(X,G)
         IF (IVP .GT. 0) CALL DUVEC(X,Y(IVP+1),G)
         XSAV = X
      ENDIF
C
C     If the user has chosen not to normalize the particular
C     solution, then C is defined in DBVPOR to be 1.0
C
C     The following loop is just
C     CALL DAXPY (NCOMP, 1.0D0/C, G, 1, YP(NA), 1)
C
      DO 20 J=1,NCOMP
         L = NA + J - 1
         YP(L) = YP(L) + G(J)/C
   20 CONTINUE
      RETURN
      END


text:
      PROGRAM AGEX06
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C Define the data arrays.
C
      REAL XDRA(501),YDRA(501)
C
C Define the graph-window parameter array.
C
      REAL GWND (4,4)
C
C Define variables used in setting up informational labels.
C
      CHARACTER*35 GLAB
      CHARACTER*23 BACK(4)
      CHARACTER*12 LNLG(4)
C
      DATA (GWND(I,1),I=1,4) / 0.0 , 0.5 , 0.5 , 1.0 /
      DATA (GWND(I,2),I=1,4) / 0.5 , 1.0 , 0.5 , 1.0 /
      DATA (GWND(I,3),I=1,4) / 0.0 , 0.5 , 0.0 , 0.5 /
      DATA (GWND(I,4),I=1,4) / 0.5 , 1.0 , 0.0 , 0.5 /
C
      DATA BACK(1) / '(PERIMETER BACKGROUND)$' /
      DATA BACK(2) / '(GRID BACKGROUND)$     ' /
      DATA BACK(3) / '(HALF-AXIS BACKGROUND)$' /
      DATA BACK(4) / '(NO BACKGROUND)$       ' /
C
      DATA LNLG(1) / 'LINEAR$' /
      DATA LNLG(2) / 'LOGARITHMIC$' /
C
C Initialize GKS.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Fill the data arrays.
C
      DO 101 I=1,501
        THETA=.031415926535898*REAL(I-1)
        XDRA(I)=500.+.9*REAL(I-1)*COS(THETA)
        YDRA(I)=500.+.9*REAL(I-1)*SIN(THETA)
  101 CONTINUE
C
C Suppress the frame advance.
C
      CALL AGSETI ('FRAME.',2)
C
C Do four graphs on the same frame, using different
C backgrounds.
C
      DO 102 IGRF = 1,4
C
C Position the graph window.
C
        CALL AGSETP ('GRAPH WINDOW.',GWND(1,IGRF),4)
C
C Declare the background type.
C
        CALL AGSETI ('BACKGROUND TYPE.',IGRF)
C
C Setting the background type may have turned informational
C labels off.  In that case, turn them back on.
C
        IF (IGRF.EQ.4) CALL AGSETI ('LABEL/CONTROL.',2)
C
C Set up parameters determining linear/log nature of axes.
C
        ILLX=(IGRF-1)/2
        ILLY=MOD(IGRF-1,2)
C
C Declare the linear/log nature of the graph.
C
        CALL AGSETI ('X/LOGARITHMIC.',ILLX)
        CALL AGSETI ('Y/LOGARITHMIC.',ILLY)
C
C Change the x- and y-axis labels to reflect the linear/log
C nature of the graph.
C
        CALL AGSETC ('LABEL/NAME.','B')
        CALL AGSETI ('LINE/NUMBER.',-100)
        CALL AGSETC ('LINE/TEXT.',LNLG(ILLX+1))
C
        CALL AGSETC ('LABEL/NAME.','L')
        CALL AGSETI ('LINE/NUMBER.',100)
        CALL AGSETC ('LINE/TEXT.',LNLG(ILLY+1))
C
C Set up the label for the top of the graph.
C
        WRITE (GLAB,1001) IGRF,BACK(IGRF)
C
C Draw the graph, using EZXY.
C
        CALL EZXY (XDRA,YDRA,501,GLAB)
C
  102 CONTINUE
C
C Draw a boundary around the edge of the plotter frame.
C
      CALL BNDARY
C
C Advance the frame.
C
      CALL FRAME
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
C
C Format for encode.
C
 1001 FORMAT ('EXAMPLE 6-',I1,' ',A23)
      END
      SUBROUTINE BNDARY
C
C Routine to draw the plotter-frame edge.
C
      CALL PLOTIT (    0,    0,0)
      CALL PLOTIT (32767,    0,1)
      CALL PLOTIT (32767,32767,1)
      CALL PLOTIT (    0,32767,1)
      CALL PLOTIT (    0,    0,1)
      RETURN
      END

ext: f

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
// Generated Files
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_q2_master_top.sv
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_q2_master_concat.sv
${PROJ_DIR}/lpif/rtl/lpif_txrx/lpif_txrx_x16_q2_master_name.sv

// Logic Link files
-f ${PROJ_DIR}/llink/rtl/llink.f

// Common Files
-f ${PROJ_DIR}/common/rtl/common.f

max_stars_repo_name: chipsalliance/aib-protocols

max_issues_repo_name: chipsalliance/aib-protocols

max_forks_repo_name: chipsalliance/aib-protocols


text:
! An interface connecting ExactTS and your PES
!
! Initializing your potential energy surface
subroutine TSinit
call prepot
end subroutine

! Hock your PES here
! Unit: Hartree and Angstrom, please!
subroutine TSenergy(Natoms, coord, energy)
implicit none
integer, intent(in) :: Natoms
real(8), intent(in) :: coord(3, Natoms)
!real(8) coordT(Natoms, 3)
real(8), intent(out) :: energy
real(8) CART, PENGYGS
INTEGER NATOM
PARAMETER (NATOM=25)
COMMON/USROCM/ PENGYGS
COMMON/USRICM/ CART(NATOM,3)

cart = transpose(coord) / 0.5291772d0
call pot
energy = PENGYGS

end subroutine

max_stars_repo_name: fanwenbin-shu/ExactTS

max_issues_repo_name: fanwenbin-shu/ExactTS

max_forks_repo_name: fanwenbin-shu/ExactTS


text:
subroutine topol(s, q)

  implicit none

  real(8), parameter   :: pi2 = 2.0 * 3.141592653589793

  integer, parameter   :: np = 400
  integer, parameter   :: nnmax = 7
  integer, parameter   :: ndr = 2 * np

  real(8), intent(in)  :: s(-nnmax+1:np,3)
  real(8), intent(out) :: q
  real(8)              :: s1(np,3), s2(np,3), s3(np,3)
  integer              :: ldr(ndr,3)

  real(8)              :: siga
  real(8)              :: cc, cc1, cc2, cc3
  real(8)              :: ss, ss1, ss2, ss3
  integer              :: idr, n, is

  common /lattice/ ldr
  common /skratch/ s1,s2,s3

  siga = 0.0
  do idr = 0, ndr/2, ndr/2

     do n = 1,ndr/2
        s1(n,1) = s(ldr(idr+n,1),1)
        s1(n,2) = s(ldr(idr+n,1),2)
        s1(n,3) = s(ldr(idr+n,1),3)
     enddo

     do n = 1,ndr/2
        s2(n,1) = s(ldr(idr+n,2),1)
        s2(n,2) = s(ldr(idr+n,2),2)
        s2(n,3) = s(ldr(idr+n,2),3)
     enddo

     do n = 1,ndr/2
        s3(n,1) = s(ldr(idr+n,3),1)
        s3(n,2) = s(ldr(idr+n,3),2)
        s3(n,3) = s(ldr(idr+n,3),3)
     enddo

!     *****   cc = 1 + s1*s2 + s2*s3 + s3*s1   *****
!     *****   ss = s1 * ( s2 x s3 )            *****

     do is = 1, ndr/2
        cc1 = s1(is,1) * s2(is,1) + s1(is,2) * s2(is,2) + s1(is,3) * s2(is,3)
        cc2 = s2(is,1) * s3(is,1) + s2(is,2) * s3(is,2) + s2(is,3) * s3(is,3)
        cc3 = s3(is,1) * s1(is,1) + s3(is,2) * s1(is,2) + s3(is,3) * s1(is,3)
        cc  = 1.0 + cc1 + cc2 + cc3
        ss1 = s2(is,2) * s3(is,3) - s2(is,3) * s3(is,2)
        ss2 = s2(is,3) * s3(is,1) - s2(is,1) * s3(is,3)
        ss3 = s2(is,1) * s3(is,2) - s2(is,2) * s3(is,1)
        ss  = s1(is,1) * ss1 + s1(is,2) * ss2 + s1(is,3) * ss3
        siga = siga + atan2(ss,cc)
     enddo

  enddo

  q = siga / pi2

end

max_stars_repo_name: David-Loibl/cprog

max_issues_repo_name: David-Loibl/cprog

max_forks_repo_name: David-Loibl/cprog


text:
      program
      implicit none
      double precision t, mpi_wtime
      external mpi_wtime
      t = 0.0
      t = mpi_wtime()
      print *, t
      t = mpi_wtime()
      print *, t
      end


text:
      subroutine   furgps(
     i                    chezch)
c
c     + + + PURPOSE + + +
c     This subroutine calculates the coefficient and exponent for equation
c     relating flow rate to a power function of flow area.
c
c     Called from FURROW
c     Author(s): Eugene R. Kottwitz.
c     Reference in User Guide: Chapter 12
c
c     Changes:
c          1) Added local variables TMPVR1-7 to eliminate repeated & expensive
c             calculations, especially in "100" & "200" loops.  With test
c             files, the "100" loop was executed 4-9 times before convergence.
c          2) Restructured to eliminate a GOTO within an IF-ELSE_ENDIF
c             structure, which pointed outside the structure.
c          3) Added counter II to "100" loop to terminate loop if it doesn't
c             converge within 20 iterations.
c
c     Version: This module recoded from WEPP Version 93.06.
c     Date recoded: 06/17/93 - 06/18/93.
c                   06/30/93 - 07/01/93.
c     Recoded by: Charles R. Meyer.
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxsrg.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pntype.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real      chezch
c
c     + + + ARGUMENT DEFINITIONS + + +
c     chezch - Chezy friction coefficient (m**(0.5)/s)
c
c     + + + COMMON BLOCKS + + +
      include 'ccrpout.inc'
c       read: rh(mxplan)
c
      include 'ccrpprm.inc'
c       read: rw(mxcrop,mxplan)
c
      include 'cends4.inc'
c       read: rspace(mxplan)
c
      include 'ciraflo.inc'
c     modify: aqcnst,aqexp
c
      include 'cirfur2.inc'
c       read: irslp,qspply(mxsrg),surge
c     modify: srg
c
      include 'cirriga.inc'
c       read; noirr
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer   i,ii,nsteps
      real      area,deltaa,denom,flodep,flowd1,flowd2,flowr,
     1          flowr2,irsum1,irsum2,irsum3,irsum4,irsum5,natlna,natlnq,
     1          topwid,wperim
      real      tmpvr1,tmpvr2,tmpvr3,tmpvr4,tmpvr5,tmpvr6,tmpvr7
c
c     + + + LOCAL DEFINITIONS + + +
c     i      - do loop counter
c     ii     - counter on convergence loops
c     nsteps - number of flow area increments
c     area   - actual flow area based on the Chezy equation (m**2)
c     deltaa - flow area increment (m**2)
c     denom  - coefficient used as a denominator in calculating the
c              furrow geometry parameters (m**12/s**2)
c     flodep - flow depth (m)
c     flowd1 - current estimate of flow depth at the maximum flow rate,
c              used in a Newton-Raphson solution (m)
c     flowd2 - next estimate of flow depth at the maximum flow rate,
c              used in a Newton-Raphson solution (m)
c     flowr  - flow rate (m**3/s)
c     flowr2 - flowr*flowr (m**6/s**2)
c     irsum1 - summation of the square of flow rates (m**6/2**2)
c     irsum2 - summation of (the square of flow rates)*natlnt
c              (m**6/s**2)
c     irsum3 - summation of (the square of flow rates)*natlnt**2
c              (m**6/2**2)
c     irsum4 - summation of (the square of flow rates)*natlni
c              (m**6/2**2)
c     irsum5 - summation of (the square of flow rates)*natlnt*natlni
c              (m**6/2**2)
c     natlna - natural logarithm of flow area
c     natlnq - natural logarithm of flow rate
c     topwid - width of water surface (m)
c     wperim - wetted perimeter (m)
c
c     + + + DATA INITIALIZATIONS + + +
      data      nsteps/50/
c
c     + + + END SPECIFICATIONS + + +
c
c     Find the maximum of furrow supply rates
c
      flowr = qspply(1)
      if(noirr.eq.2 .and. surge.ge.2)then
        do 10 srg = 2, surge
          flowr = max(flowr,qspply(srg))
   10   continue
      endif
c
c     Determine flow depth corresponding to maximum furrow supply rate
c
      flowd2 = 0.5*rh(iplane)
      tmpvr1 = 2.0*sqrt(1.0+sidslp**2)
      tmpvr2 = flowr/chezch
      tmpvr4 = 2.0*sidslp
c
c      *** Begin L0 Loop ***
      ii = 0
  100 continue
        flowd1 = flowd2
        area = (botwid+sidslp*flowd1)*flowd1
        topwid = botwid+flowd1*tmpvr4
        wperim = botwid+flowd1*tmpvr1
c        Original Code:
c       flowd2 = flowd1-(wperim-(flowr*wperim/chezch)**2/irslp/
c    1           area**3)/(3.*topwid*wperim/area-2.*sqrt(1.+sidslp**2))
        flowd2 = flowd1-(wperim-(wperim*tmpvr2)**2/(irslp*area**3))/
     1           (3.0*topwid*wperim/area-tmpvr1)
        ii = ii + 1
c
c      *** End L0 Loop ***
      if(abs(flowd2-flowd1).gt.0.000001 .and. ii.lt.20) goto 100
c      ---- caution to user
      if(ii.ge.20) then
        write (6,*) ' FURGPS: Calculations suspended after 20',
     1             ' iterations.'
        write (6,*) ' Calculations DID NOT CONVERGE.'
      endif
c
c   NOTE:  When executing above loop and printing a counter with
c          test data sets, loop executes 4-9 times before converging.
c          The "effective duration" and point of maximum soil loss
c          seem to be REALLY SENSITIVE to the order of calculations
c          in the equation above.  Perhaps some double precision
c          calculations are in order? -- CRM -- 6/30/93.
c
c
      area = (botwid+sidslp*flowd2)*flowd2
c
c     Determine values for functions of flow rate and area
c
      natlnq = log(flowr)
      natlna = log(area)
c
c     Calculate summations
c
c      Original Code:
c     flowr2 = flowr**2
c     irsum1 = flowr2
c     irsum2 = flowr2*natlna
c     irsum3 = flowr2*natlna**2
c     irsum4 = flowr2*natlnq
c     irsum5 = flowr2*natlna*natlnq
c
      irsum1 = flowr**2
      irsum2 = irsum1*natlna
      irsum3 = irsum2*natlna
      irsum4 = irsum1*natlnq
      irsum5 = irsum2*natlnq
c
c     Determine flow area increment (deltaa)
c
      deltaa = area/float(nsteps)
      area = 0.0
c
      tmpvr3 = botwid**2
      tmpvr5 = 4.0*sidslp
      tmpvr6 = irslp/wperim
c
c     Calculation loop
c
      do 200  i = 1, nsteps-1
c
c       Increment flow area
c
        area = area+deltaa
c
c       Calculate flow depth, wetted perimeter, and flow rate
c       corresponding to flow area
c
c        Original Code:
c       flodep = (sqrt(botwid**2+4.*sidslp*area)-botwid)/2./sidslp
c       wperim = botwid+2.*flodep*sqrt(1.+sidslp**2)
c       flowr = chezch*sqrt(irslp*area**3/wperim)
        flodep = (sqrt(tmpvr3+tmpvr5*area)-botwid)/tmpvr4
        wperim = botwid+flodep*tmpvr1
c
c        ---- (WEPP Equation 12.9, using area/wperim in place of
c             hydraulic radius)
        flowr = chezch*sqrt(tmpvr6*area**3)
c
c       Determine values functions of flowr and area
c
        natlnq = log(flowr)
        natlna = log(area)
        flowr2 = flowr**2
c
c       Perform summations
c
c        Original Code:
c       irsum1 = irsum1+flowr2
c       irsum2 = irsum2+flowr2*natlna
c       irsum3 = irsum3+flowr2*natlna*natlna
c       irsum4 = irsum4+flowr2*natlnq
c       irsum5 = irsum5+flowr2*natlna*natlnq
c
        tmpvr7 = flowr2*natlna
        irsum1 = irsum1+flowr2
        irsum2 = irsum2+tmpvr7
        irsum3 = irsum3+tmpvr7*natlna
        irsum4 = irsum4+flowr2*natlnq
        irsum5 = irsum5+tmpvr7*natlnq
  200 continue
c
c     Determine constant and exponent relating flow area to flow rate
c
      denom = irsum2**2-irsum1*irsum3
      aqexp = (irsum2*irsum4-irsum1*irsum5)/denom
      aqcnst = exp((irsum2*irsum5-irsum3*irsum4)/denom)
c
      return
      end

ext: for

max_stars_repo_name: jarad/dep

max_issues_repo_name: jarad/dep

max_forks_repo_name: akrherz/idep


text:
#include "real.h"
module mod_init_disp_sinwave
use mod_grid
use mod_rwg
implicit none

real(kind=8), private :: T = 20.0d0 ! [s]
real(kind=8), private :: a = 0.03d0 ! [m]
integer(kind=4), private :: x_index = 0
integer(kind=4), private :: y_index = 0
! === FILE INPUT ===============================================================
character(len=64), private :: input_file = ''
real(kind=REAL_BYTE), private, allocatable, dimension(:) :: tlist, hlist
! === DEBUG for restart with sinwave/file-input 2016/02/18 =====================
!integer(kind=4), private :: lcount = 0, ccount = 0
integer(kind=4), private :: lcount = 0
integer(kind=4) :: ccount = 0
! ==============================================================================
! ==============================================================================

real(kind=8), private :: pi

contains

#ifndef MULTI
   subroutine specify_sinwave_params(file)
#else
   subroutine specify_sinwave_params(input_dirname, file)
#endif
      character(len=256), intent(in) :: file
#ifdef MULTI
      character(len=128), intent(in) :: input_dirname
      character(len=256) :: file_multi
#endif
! === FILE INPUT ===============================================================
!     namelist /sinwave/ T, a, x_index, y_index
      real(kind=REAL_BYTE) :: t_in, h_in
      namelist /sinwave/ T, a, x_index, y_index, input_file
! ==============================================================================

#ifndef MULTI
      open(1,file=trim(file),action='read',status='old',form='formatted')
#else
      file_multi = trim(input_dirname) // trim(file)
      open(1,file=trim(file_multi),action='read',status='old',form='formatted')
#endif
      read(1,sinwave)
      close(1)

! === FILE INPUT ===============================================================
      if(input_file == '') then
! ==============================================================================
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [Begin] ================='
         write(6,'(a)') '============================================================'
         write(6,'(a,a)') '- Filename: ', trim(file)
         write(6,'(a,f15.6)') '- Cycle[s] (T):       ', T
         write(6,'(a,f15.6)') '- Wave height[m] (a): ', a
         write(6,'(a,i8)')    '- X-index (x_index):  ', x_index
         write(6,'(a,i8)')    '- Y-index (y_index):  ', y_index
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [End] ==================='
         write(6,'(a)') '============================================================'

         pi = 2.0d0*dasin(1.0d0)
! === FILE INPUT ===============================================================
      else
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [Begin] ================='
         write(6,'(a)') '============================================================'
         write(6,'(a,a)') '- Filename: ', trim(file)
         write(6,'(a,a)')     '- Input File (input_file): ', trim(input_file)
         write(6,'(a,i8)')    '- X-index (x_index):       ', x_index
         write(6,'(a,i8)')    '- Y-index (y_index):       ', y_index
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [End] ==================='
         write(6,'(a)') '============================================================'

#ifndef MULTI
         open(1,file=trim(input_file),action='read',status='old',form='formatted')
#else
         file_multi = trim(input_dirname) // trim(input_file)
         open(1,file=trim(file_multi),action='read',status='old',form='formatted')
#endif

         lcount=0
         do
            read(1, *, end=100, err=200) t_in, h_in
            lcount = lcount+1
200         continue
         end do
100      continue

         allocate(hlist(lcount)); hlist = 0.0d0
         allocate(tlist(lcount)); tlist = 0.0d0

         rewind(1)
         lcount=0
         do
            read(1, *, end=101, err=201) t_in, h_in
            lcount = lcount+1
            hlist(lcount) = h_in
            tlist(lcount) = t_in
201         continue
         end do
101      continue
      end if
! ==============================================================================

      return
   end subroutine specify_sinwave_params

#ifndef MPI
   subroutine hrise_rwg_sin(wfld,time,nlon,nlat)
#else
   subroutine hrise_rwg_sin(wfld,time,nlon,nlat,kx,ky)
#endif
      type(wave_arrays), target, intent(inout) :: wfld
      real(kind=REAL_BYTE), intent(in) :: time
      integer(kind=4), intent(in) :: nlon, nlat
#ifdef MPI
      integer(kind=4), intent(in) :: kx, ky
#endif

      real(kind=REAL_BYTE), pointer, dimension(:,:) :: hz
      integer(kind=4) :: i, j
#ifdef MPI
      integer(kind=4) :: ig, jg
#endif

      hz => wfld%hz

! === FILE INPUT ===============================================================
      if(lcount == 0) then
! ==============================================================================
#ifndef MPI
         if(x_index /= 0) then
            i = x_index
!$omp parallel do
            do j = 1, nlat
               hz(i,j) = a*dsin(2.0d0*pi/T*time)
            end do
         end if

         if(y_index /= 0) then
            j = y_index
!$omp parallel do
            do i = 1, nlon
               hz(i,j) = a*dsin(2.0d0*pi/T*time)
            end do
         end if
#else
         if(x_index /= 0) then
            do i = 1, nlon
               ig = kx+i-1
               if(ig == x_index) then
!$omp parallel do
                  do j = 1, nlat
                     hz(i,j) = a*dsin(2.0d0*pi/T*time)
                  end do
               end if
            end do
         end if

         if(y_index /= 0) then
            do j = 1, nlat
               jg = ky+j-1
               if(jg == y_index) then
!$omp parallel do
                  do i = 1, nlon
                     hz(i,j) = a*dsin(2.0d0*pi/T*time)
                  end do
               end if
            end do
         end if
#endif
! === FILE INPUT ===============================================================
      else
         ccount = ccount + 1
         if(ccount > lcount) return
!        write(6,'(i8,3e15.6)') ccount, time, tlist(ccount), hlist(ccount)
#ifndef MPI
         if(x_index /= 0) then
            i = x_index
!$omp parallel do
            do j = 1, nlat
               hz(i,j) = hlist(ccount)
            end do
         end if

         if(y_index /= 0) then
            j = y_index
!$omp parallel do
            do i = 1, nlon
               hz(i,j) = hlist(ccount)
            end do
         end if
#else
         if(x_index /= 0) then
            do i = 1, nlon
               ig = kx+i-1
               if(ig == x_index) then
!$omp parallel do
                  do j = 1, nlat
                    hz(i,j) = hlist(ccount)
                  end do
               end if
            end do
         end if

         if(y_index /= 0) then
            do j = 1, nlat
               jg = ky+j-1
               if(jg == y_index) then
!$omp parallel do
                  do i = 1, nlon
                     hz(i,j) = hlist(ccount)
                  end do
               end if
            end do
         end if
#endif
      end if
! ==============================================================================

      return
   end subroutine hrise_rwg_sin

end module mod_init_disp_sinwave

max_stars_repo_name: J-Taniguchi/jagurs

max_issues_repo_name: J-Taniguchi/jagurs

max_forks_repo_name: J-Taniguchi/jagurs


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program cam_to_dart

!----------------------------------------------------------------------
! purpose: interface between CAM and DART
!
! method: Read CAM 'initial' file (netCDF format) for model state and time.
!         Reform fields into a DART state vector.
!         Write out state vector in "proprietary" format for DART
!
! author: Tim Hoar 4/4/2011
!
!----------------------------------------------------------------------

use        types_mod,    only : r8
use    utilities_mod,    only : initialize_utilities, finalize_utilities,   &
                                check_namelist_read, find_namelist_in_file, &
                                nmlfileunit, do_nml_file, do_nml_term
use        model_mod,    only : model_type, init_model_instance, &
                                end_model_instance, &
                                prog_var_to_vector, read_cam_init
use  assim_model_mod,    only : static_init_assim_model, get_model_size

use state_vector_io_mod, only : open_restart_write, awrite_state_restart, &
                                close_restart
use time_manager_mod,    only : time_type

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

!-----------------------------------------------------------------------
! namelist parameters with default values.
!-----------------------------------------------------------------------

character (len = 128) :: cam_to_dart_input_file  = 'caminput.nc'
character (len = 128) :: cam_to_dart_output_file = 'dart_ics'

namelist /cam_to_dart_nml/ cam_to_dart_input_file, cam_to_dart_output_file

! allocatable storage to read in a native format for cam state
real(r8), allocatable  :: statevector(:)
type(model_type)       :: var
type(time_type)        :: model_time
integer                :: iunit, x_size, io

call initialize_utilities('cam_to_dart')

! Read the namelist entry
call find_namelist_in_file("input.nml", "cam_to_dart_nml", iunit)
read(iunit, nml = cam_to_dart_nml, iostat = io)
call check_namelist_read(iunit, io, "cam_to_dart_nml")

! Record the namelist values
if (do_nml_file()) write(nmlfileunit, nml=cam_to_dart_nml)
if (do_nml_term()) write(     *     , nml=cam_to_dart_nml)

! Static init assim model sets the output file format (binary/ascii)
! and calls static_init_model
call static_init_assim_model()

! Allocate the local state vector
x_size = get_model_size()
allocate(statevector(x_size))

! Allocate the instance of the cam model type for storage
! I'll just point to the space I need, not;
call init_model_instance(var)

! Read the file cam state fragments into var;
! transform fields into state vector for DART

call read_cam_init(cam_to_dart_input_file, var, model_time)

call prog_var_to_vector(var, statevector)
call end_model_instance(var)

! write out state vector in "proprietary" format
iunit = open_restart_write(cam_to_dart_output_file)
call awrite_state_restart(model_time, statevector, iunit)
call close_restart(iunit)

call finalize_utilities('cam_to_dart')

end program cam_to_dart

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


program main
  use salmon_global
  use salmon_parallel
  use inputoutput
  use math_constants
  implicit none

  call set_math_constants

  call setup_parallel
  if (nproc_id_global == 0) then
    call print_software_version
  endif

  call read_input

  select case(theory)
  case('TDDFT')
    select case(iperiodic)
    case(0)
      call gceed
    case(3)
      select case(domain_parallel)
      case('y')
        call gceed
      case('n')
        call arted
      case default
        stop 'invalid domain_parallel'
      end select
    case default
      stop 'invalid iperiodic'
    end select
  case('Maxwell')
    call classic_em
  case default
    stop 'invalid theory'
  end select

  call end_parallel
contains
  subroutine print_software_version
    use salmon_xc, only: print_xc_info
    implicit none
    include 'versionf.h'
    print '(A)',         '##############################################################################'
    print '(A)',         '# SALMON: Scalable Ab-initio Light-Matter simulator for Optics and Nanoscience'
    print '(A)',         '#'
    print '(A,I1,".",I1,".",I1)', &
    &                    '#                             Version ', SALMON_VER_MAJOR, SALMON_VER_MINOR, SALMON_VER_MICRO
    if (GIT_FOUND) then
      print '(A)',       '#'
      print '(A,A,A,A)', '#   [Git revision] ', GIT_COMMIT_HASH, ' in ', GIT_BRANCH
    endif
    print '(A)',         '##############################################################################'

    call print_xc_info()
  end subroutine
end program main


! { dg-do compile }
! PR fortran/82934
! PR fortran/83318
program a
 character(len=42), allocatable :: f
 character(len=22), allocatable :: ff
 call alloc(f, ff)
 if (len(f) .ne. 42) STOP 1
 if (len(ff) .ne. 22) STOP 2
contains
 subroutine alloc( a, b )
  character(len=*), allocatable  :: a
  character(len=22), allocatable :: b
  character(len=:), allocatable :: c
  character, allocatable :: d
  allocate(character(len=*)::a,b) ! { dg-error "Incompatible allocate-object" }
  allocate(character(len=*)::c)   ! { dg-error "Incompatible allocate-object" }
  allocate(character(len=*)::d)   ! { dg-error "Incompatible allocate-object" }
 end subroutine
end program a


text:
! PR 19239.  Check for various kinds of vector subscript.  In this test,
! all vector subscripts are indexing single-dimensional arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n = 10
  integer :: i, j, calls
  integer, dimension (n) :: a, b, idx, id

  idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /)
  id = (/ (i, i = 1, n) /)
  b = (/ (i * 100, i = 1, n) /)

  !------------------------------------------------------------------
  ! Tests for a simple variable subscript
  !------------------------------------------------------------------

  a (idx) = b
  call test (idx, id)

  a = b (idx)
  call test (id, idx)

  a (idx) = b (idx)
  call test (idx, idx)

  !------------------------------------------------------------------
  ! Tests for constant ranges with non-default stride
  !------------------------------------------------------------------

  a (idx (1:7:3)) = b (10:6:-2)
  call test (idx (1:7:3), id (10:6:-2))

  a (10:6:-2) = b (idx (1:7:3))
  call test (id (10:6:-2), idx (1:7:3))

  a (idx (1:7:3)) = b (idx (1:7:3))
  call test (idx (1:7:3), idx (1:7:3))

  a (idx (1:7:3)) = b (idx (10:6:-2))
  call test (idx (1:7:3), idx (10:6:-2))

  a (idx (10:6:-2)) = b (idx (10:6:-2))
  call test (idx (10:6:-2), idx (10:6:-2))

  a (idx (10:6:-2)) = b (idx (1:7:3))
  call test (idx (10:6:-2), idx (1:7:3))

  !------------------------------------------------------------------
  ! Tests for subscripts of the form CONSTRANGE + CONST
  !------------------------------------------------------------------

  a (idx (1:5) + 1) = b (1:5)
  call test (idx (1:5) + 1, id (1:5))

  a (1:5) = b (idx (1:5) + 1)
  call test (id (1:5), idx (1:5) + 1)

  a (idx (6:10) - 1) = b (idx (1:5) + 1)
  call test (idx (6:10) - 1, idx (1:5) + 1)

  !------------------------------------------------------------------
  ! Tests for variable subranges
  !------------------------------------------------------------------

  do j = 5, 10
    a (idx (2:j:2)) = b (3:2+j/2)
    call test (idx (2:j:2), id (3:2+j/2))

    a (3:2+j/2) = b (idx (2:j:2))
    call test (id (3:2+j/2), idx (2:j:2))

    a (idx (2:j:2)) = b (idx (2:j:2))
    call test (idx (2:j:2), idx (2:j:2))
  end do

  !------------------------------------------------------------------
  ! Tests for function vectors
  !------------------------------------------------------------------

  calls = 0

  a (foo (5, calls)) = b (2:10:2)
  call test (foo (5, calls), id (2:10:2))

  a (2:10:2) = b (foo (5, calls))
  call test (id (2:10:2), foo (5, calls))

  a (foo (5, calls)) = b (foo (5, calls))
  call test (foo (5, calls), foo (5, calls))

  if (calls .ne. 8) call abort

  !------------------------------------------------------------------
  ! Tests for constant vector constructors
  !------------------------------------------------------------------

  a ((/ 1, 5, 3, 9 /)) = b (1:4)
  call test ((/ 1, 5, 3, 9 /), id (1:4))

  a (1:4) = b ((/ 1, 5, 3, 9 /))
  call test (id (1:4), (/ 1, 5, 3, 9 /))

  a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /))
  call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /))

  !------------------------------------------------------------------
  ! Tests for variable vector constructors
  !------------------------------------------------------------------

  do j = 1, 5
    a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j)
    call test ((/ 1, (i + 3, i = 2, j) /), id (1:j))

    a (1:j) = b ((/ 1, (i + 3, i = 2, j) /))
    call test (id (1:j), (/ 1, (i + 3, i = 2, j) /))

    a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /))
    call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /))
  end do

  !------------------------------------------------------------------
  ! Tests in which the vector dimension is partnered by a temporary
  !------------------------------------------------------------------

  calls = 0
  a (idx (1:6)) = foo (6, calls)
  if (calls .ne. 1) call abort
  do i = 1, 6
    if (a (idx (i)) .ne. i + 3) call abort
  end do
  a = 0

  calls = 0
  a (idx (1:6)) = foo (6, calls) * 100
  if (calls .ne. 1) call abort
  do i = 1, 6
    if (a (idx (i)) .ne. (i + 3) * 100) call abort
  end do
  a = 0

  a (idx) = id + 100
  do i = 1, n
    if (a (idx (i)) .ne. i + 100) call abort
  end do
  a = 0

  a (idx (1:10:3)) = (/ 20, 10, 9, 11 /)
  if (a (idx (1)) .ne. 20) call abort
  if (a (idx (4)) .ne. 10) call abort
  if (a (idx (7)) .ne. 9) call abort
  if (a (idx (10)) .ne. 11) call abort
  a = 0

contains
  subroutine test (lhs, rhs)
    integer, dimension (:) :: lhs, rhs
    integer :: i

    if (size (lhs, 1) .ne. size (rhs, 1)) call abort
    do i = 1, size (lhs, 1)
      if (a (lhs (i)) .ne. b (rhs (i))) call abort
    end do
    a = 0
  end subroutine test

  function foo (n, calls)
    integer :: i, n, calls
    integer, dimension (n) :: foo

    calls = calls + 1
    foo = (/ (i + 3, i = 1, n) /)
  end function foo
end program main

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


! ==============================================================================
! Subroutine: EBULGE (ISEQ,I,J,IP,JP,N,EB)
!
! Purpose: Computes the energy of an RNA buldge with two helices using the
!          empirical MFOLD 3.0 energy function.
!
! Method: Uses the MFOLD 3.0 energy function for RNA @ T=37 given by:
!
!         EB = E_entropic + E_stack + E_stack + E_asymmetry
!
!               5' (I) X ... W (IP) 3'
!               3' (J) Y ... Z (JP) 5'
!
!               NOTE: I < IP and JP < J
!
! Arguments:
!
!          ISEQ - Array of length N containing the sequence
!                 in numerical code (A=1,C=2,G=3,U=4)
!             I - Nucleotide position of the starting basepair 5'.
!             J - Nucleotide position of the starting basepair 3'.
!            IP - Nucleotide position of the ending basepair 3'.
!            JP - Nucleotide position of the ending basepair 5'.
!             N - Number of nucleotides in the sequence.
!            EB - (OUTPUT) MFOLD 3.0 bulge energy of the sequence.
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependencies:
!
! Modules - RNAvar
! Functions -
! Subroutines - TSTACK, TSTACKI, TINT11, TINT12, TINT22
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      SUBROUTINE EBULGE (ISEQ,I,J,IP,JP,N,EB)

        USE RNAvar, ONLY : eau,beta

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        INTEGER, INTENT(IN) :: i,j,ip,jp,n
        INTEGER, INTENT(IN) :: iseq(n)

        REAL, INTENT(OUT) :: eb

        !=== VARIABLES ===!

        INTEGER :: k,ibul,imin,imax
        INTEGER :: n1,n2,nt,na,list(8)

        REAL :: x,c,f(4)
        REAL :: elb(30),eli(30)

        DATA (  f(k),k=1,4 ) / 0.50e0,0.50e0,0.50e0,0.50e0 /

        DATA (elb(k),k=1,30) / 3.80e0,2.80e0,3.20e0,3.60e0,4.00e0,&
                             & 4.40e0,4.60e0,4.70e0,4.80e0,4.90e0,&
                             & 5.00e0,5.10e0,5.20e0,5.30e0,5.40e0,&
                             & 5.40e0,5.50e0,5.50e0,5.60e0,5.70e0,&
                             & 5.70e0,5.80e0,5.80e0,5.80e0,5.90e0,&
                             & 5.90e0,6.00e0,6.00e0,6.00e0,6.10e0 /

        DATA (eli(k),k=1,30) / 0.00e0,0.00e0,0.00e0,1.70e0,1.80e0,&
                             & 2.00e0,2.20e0,2.30e0,2.40e0,2.50e0,&
                             & 2.60e0,2.70e0,2.80e0,2.90e0,3.00e0,&
                             & 3.00e0,3.10e0,3.10e0,3.20e0,3.30e0,&
                             & 3.30e0,3.40e0,3.40e0,3.40e0,3.50e0,&
                             & 3.50e0,3.60e0,3.60e0,3.60e0,3.70e0 /

        eb = 0.0e0

        n1 = ip - i - 1
        n2 = j - jp - 1

        nt = n1 + n2
        na = IABS(n1-n2)

        imin = MIN(n1,n2)
        imax = MAX(n1,n2)

        c = 1.750e0 / REAL(beta)

        !=== Get Buldge Type ===!

        ibul = 6
        IF ( n1 == 0 .and. n2 == 1 ) ibul = 0
        IF ( n1 == 1 .and. n2 == 0 ) ibul = 0
        IF ( n1 == 0 .and. n2 >= 2 ) ibul = 1
        IF ( n1 >= 2 .and. n2 == 0 ) ibul = 1
        IF ( n1 == 1 .and. n2 == 1 ) ibul = 2
        IF ( n1 == 1 .and. n2 == 2 ) ibul = 3
        IF ( n1 == 2 .and. n2 == 1 ) ibul = 4
        IF ( n1 == 2 .and. n2 == 2 ) ibul = 5

        !=== TERM 1 --> Entropic Term ===!

        IF ( nt > 30 ) THEN

          x = REAL(nt) / 30.0d0
          x = c * LOG(x)

          IF ( ibul <= 1 ) eb = elb(30) + x
          IF ( ibul == 6 ) eb = eli(30) + x

        ELSE

          IF ( ibul <= 1 ) eb = elb(nt)
          IF ( ibul == 6 ) eb = eli(nt)

        ENDIF

        !=== TERM 2 & 3 --> Stacking Energy ===!

        SELECT CASE (ibul)

          CASE (0)

            ! 5' (i) A . X (ip) 3'
            ! 3' (j) U   Y (jp) 5'

            list(1) = iseq(i)
            list(2) = iseq(j)
            list(3) = iseq(ip)
            list(4) = iseq(jp)

            CALL TSTACK (list,eb)

          CASE (1)

            ! 5' (i) A .. X (ip) 3'
            ! 3' (j) U    Y (jp) 5'

            !=== Closing A-U / G-U Penalty ===!

            IF ( iseq(i) ==  4 ) eb = eb + eau
            IF ( iseq(j) ==  4 ) eb = eb + eau
            IF ( iseq(ip) == 4 ) eb = eb + eau
            IF ( iseq(jp) == 4 ) eb = eb + eau

          CASE (2)

            ! 5' (i) A . X (ip) 3'
            ! 3' (j) U . Y (jp) 5'

            list(1) = iseq(i)
            list(2) = iseq(j)
            list(3) = iseq(i+1)
            list(4) = iseq(j-1)
            list(5) = iseq(ip)
            list(6) = iseq(jp)

            CALL TINT11 (list,eb)

          CASE (3)

            ! 5' (i) A .   X (ip) 3'
            ! 3' (j) U . . Y (jp) 5'

            list(1) = iseq(i)
            list(2) = iseq(j)
            list(3) = iseq(i+1)
            list(4) = iseq(j-1)
            list(5) = iseq(j-2)
            list(6) = iseq(ip)
            list(7) = iseq(jp)

            CALL TINT12 (list,eb)

          CASE (4)

            ! 5' (i) A . . X (ip) 3'
            ! 3' (j) U   . Y (jp) 5'

            list(1) = iseq(jp)
            list(2) = iseq(ip)
            list(3) = iseq(jp+1)
            list(4) = iseq(ip-1)
            list(5) = iseq(ip-2)
            list(6) = iseq(j)
            list(7) = iseq(i)

            CALL TINT12 (list,eb)

          CASE (5)

            ! 5' (i) A . . X (ip) 3'
            ! 3' (j) U . . Y (jp) 5'

            list(1) = iseq(i)
            list(2) = iseq(j)
            list(3) = iseq(i+1)
            list(4) = iseq(j-1)
            list(5) = iseq(ip-1)
            list(6) = iseq(jp+1)
            list(7) = iseq(ip)
            list(8) = iseq(jp)

            CALL TINT22 (list,eb)

          CASE (6)

            ! 5' (i) A X .. G (ip) 3'
            ! 3' (j) U Y .. C (jp) 5'

            list(1) = iseq(i)
            list(2) = iseq(j)
            list(3) = iseq(i+1)
            list(4) = iseq(j-1)

            !=== GAIL Rule ===!

            IF ( imin == 1 .and. imax > 2 ) THEN

              list(3) = 1
              list(4) = 1

            ENDIF

            CALL TSTACKI (list,eb)

            ! 5' (i) A .. X G (ip) 3'
            ! 3' (j) U .. Y C (jp) 5'

            list(1) = iseq(jp)
            list(2) = iseq(ip)
            list(3) = iseq(jp+1)
            list(4) = iseq(ip-1)

            !=== GAIL Rule ===!

            IF ( imin == 1 .and. imax > 2 ) THEN

              list(3) = 1
              list(4) = 1

            ENDIF

            CALL TSTACKI (list,eb)

          CASE DEFAULT

            WRITE(*,*)'ERROR: ibul out of range [0-6]'
            STOP

        END SELECT

        !=== PART 4 ---> Asymmetry Penalty ===!

        IF ( ibul == 6 ) THEN

          k = MIN(4,n1,n2)

          x = REAL(na) * f(k)

          x = MIN(x,3.0d0)

          eb = eb + x

        ENDIF

        RETURN

      END SUBROUTINE EBULGE


module mod_read_gmsh

    type point
        integer(4) :: ident
        real(8)    :: x = 0.0d0
        real(8)    :: y = 0.0d0
        real(8)    :: z = 0.0d0
    end type

    type list_point
        type(point),pointer :: p => null()
    end type

    type node_ident
        integer(4),dimension(:),allocatable:: id_node
    end type

    type,extends(node_ident) :: node_ident_msh
        integer(4) :: ident
        integer(4) :: elem_typ
        integer(4) :: nb_tags
        integer(4) :: tag1
        integer(4) :: tag2
    end type

    type ptr_node_ident
        type(node_ident),pointer :: pn => null()
    end type

    type ptr_node_ident_msh
        type(node_ident_msh),pointer :: pn => null()
    end type

    type obj_gmsh_reader

        integer(4) :: nbnode
        integer(4) :: nbel_msh
        integer(4) :: nbelm
        type(ptr_node_ident), dimension(:), allocatable     :: id_nodes
        type(ptr_node_ident_msh), dimension(:), allocatable :: id_nodes_msh
        type(list_point), dimension(:), allocatable         :: coord_nodes

    contains
        procedure :: read_msh => read_mesh
        procedure :: assign_id_nodes => construct_id_nodes
    end type obj_gmsh_reader

    character(300), save :: fname
    real(8),        save :: rho_init, ux_init, uy_init, t_init

    contains
!----------------------------------------------------------------------
       subroutine read_mesh(this)
       implicit none

       namelist /mesh_file/ fname
       namelist /init_valu/ rho_init, ux_init, uy_init, t_init

       class(obj_gmsh_reader), intent(inout) :: this
       character(300) :: finput
       character(30) :: cline
       integer(4) :: i
       integer(4) :: elem_typ

       open(unit = 100, file = 'input.dat')
       read(100, nml = mesh_file)
       read(100, nml = init_valu)
       close(100)

       finput = trim(fname)//'.msh'

       write(6,'(a)') 'Input mesh file: ',finput

       open(unit = 20, file = finput, status = 'old')
       read(20,*)
       read(20,*)
       read(20,*)
       read(20,*)
       read(20,*) this%nbnode

       allocate(this%coord_nodes(1:this%nbnode))
       do i = 1, this%nbnode
         allocate(this%coord_nodes(i)%p)
       end do

       do i = 1, this%nbnode
        read(20,*) this%coord_nodes(i)%p%ident, this%coord_nodes(i)%p%x, this%coord_nodes(i)%p%y, this%coord_nodes(i)%p%z
       end do

       read(20,*)
       read(20,*)

       read(20,*) this%nbel_msh

       allocate(this%id_nodes_msh(1:this%nbel_msh))

       do i = 1, this%nbel_msh
        allocate(this%id_nodes_msh(i)%pn)
       end do

       this%nbelm = 0

       do i = 1, this%nbel_msh
        read(20,*) this%id_nodes_msh(i)%pn%ident, this%id_nodes_msh(i)%pn%elem_typ, this%id_nodes_msh(i)%pn%nb_tags, &
            & this%id_nodes_msh(i)%pn%tag1, this%id_nodes_msh(i)%pn%tag2
        elem_typ = this%id_nodes_msh(i)%pn%elem_typ
        select case (elem_typ)
            case (1) ! 2-node line.
                allocate(this%id_nodes_msh(i)%pn%id_node(1:7))
            case (3) ! 4-node quadrangle.
                allocate(this%id_nodes_msh(i)%pn%id_node(1:9))
                this%nbelm = this%nbelm + 1
            case (15) ! 1-node point.
                allocate(this%id_nodes_msh(i)%pn%id_node(1:6))
            case (37) ! 5-node edge quadrangle.
                allocate(this%id_nodes_msh(i)%pn%id_node(1:30))
                this%nbelm = this%nbelm + 1
            case (27) ! boundary 5-node edge.
                allocate(this%id_nodes_msh(i)%pn%id_node(1:10))
            case default
                print*,'comming soon !'
                stop
        end select
       end do

       close(unit = 20)

       open(unit = 20, file = finput, status = 'old')
       do
           read(20,*) cline
           cline = trim(cline)
           if (cline == '$Elements') exit
       enddo

       read(20,*)
       do i = 1, this%nbel_msh
           read(20,*) this%id_nodes_msh(i)%pn%id_node(:)
       enddo

       close(unit = 20)

       end subroutine
!----------------------------------------------------------------------
       subroutine construct_id_nodes(this)
       implicit none
       class(obj_gmsh_reader), intent(inout) :: this
       integer(4) :: i,j

       allocate(this%id_nodes(1:this%nbelm))
       do i = 1, this%nbelm
           allocate(this%id_nodes(i)%pn)

           if (this%id_nodes_msh(i)%pn%elem_typ == 3) then
                allocate(this%id_nodes(i)%pn%id_node(1:9))
           endif

           if (this%id_nodes_msh(i)%pn%elem_typ == 37) then
                allocate(this%id_nodes(i)%pn%id_node(1:30))
           endif

       enddo

       j = 0
       do i = 1, this%nbel_msh
           if (this%id_nodes_msh(i)%pn%elem_typ == 3) then
               j = j + 1
               this%id_nodes(j)%pn%id_node(:) = this%id_nodes_msh(i)%pn%id_node(:)
           endif

           if (this%id_nodes_msh(i)%pn%elem_typ == 37) then
               j = j + 1
               this%id_nodes(j)%pn%id_node(:) = this%id_nodes_msh(i)%pn%id_node(:)
           endif
       enddo

       end subroutine
!----------------------------------------------------------------------
end module


! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/56318
!
! Contributed by Alberto Luaces
!
SUBROUTINE mass_matrix
  DOUBLE PRECISION,PARAMETER::m1=1.d0
  DOUBLE PRECISION,DIMENSION(3,2),PARAMETER::A1=reshape([1.d0,0.d0, 0.d0, &
       0.d0,1.d0, 0.d0],[3,2])
  DOUBLE PRECISION,DIMENSION(2,2),PARAMETER::Mel=reshape([1.d0/3.d0, 0.d0, &
       0.d0, 1.d0/3.d0],[2,2])

  DOUBLE PRECISION,DIMENSION(3,3)::MM1

  MM1=m1*matmul(A1,matmul(Mel,transpose(A1)))
  !print '(3f8.3)', MM1
  if (any (abs (MM1 &
                - reshape ([1.d0/3.d0, 0.d0,      0.d0,  &
                            0.d0,      1.d0/3.d0, 0.d0,  &
                            0.d0,      0.d0,      0.d0], &
                           [3,3])) > epsilon(1.0d0))) &
    STOP 1
END SUBROUTINE mass_matrix

program name
  implicit none
  integer, parameter :: A(3,2) = reshape([1,2,3,4,5,6],[3,2])
  integer, parameter :: B(2,3) = reshape([3,17,23,31,43,71],[2,3])
  integer, parameter :: C(3)   = [-5,-7,-21]
  integer, parameter :: m1 = 1

!  print *, matmul(B,C)
   if (any (matmul(B,C) /= [-1079, -1793])) STOP 2
!  print *, matmul(C,A)
   if (any (matmul(C,A) /= [-82, -181])) STOP 3
!  print '(3i5)', m1*matmul(A,B)
  if (any (m1*matmul(A,B) /= reshape([71,91,111, 147,201,255, 327,441,555],&
                                     [3,3]))) &
     STOP 4
  call mass_matrix
end program name

! { dg-final { scan-tree-dump-times "matmul" 0 "original" } }


text:
// Developed by Simen Haugo.
// See LICENSE.txt for copyright and licensing details (standard MIT License).

uniform vec2      iResolution;
uniform int       iFrame;
uniform vec2      iCameraCenter;
uniform float     iCameraF;
uniform mat4      iView;
uniform int       iSamples;
uniform vec3      iToSun;
uniform vec3      iSunStrength;
uniform float     iCosSunSize;
uniform int       iDrawIsolines;
uniform vec3      iIsolineColor;
uniform float     iIsolineThickness;
uniform float     iIsolineSpacing;
uniform float     iIsolineMax;
uniform int       iMaterialGlossy;
uniform float     iMaterialSpecularExponent;
uniform vec3      iMaterialSpecularAlbedo;
uniform vec3      iMaterialAlbedo;
uniform int       iGroundReflective;
uniform float     iGroundHeight;
uniform float     iGroundSpecularExponent;
uniform float     iGroundReflectivity;
out vec4          fragColor;

#define EPSILON 0.0007
#define STEPS 512
#define M_PI 3.1415926535897932384626433832795
#define MAX_DISTANCE 100.0
#define MAX_DISTANCE_VISIBILITY_TEST 10.0

float model(vec3 p); // forward declaration

// Adapted from: lumina.sourceforge.net/Tutorials/Noise.html
vec2 seed = vec2(-1,1)*(iSamples*(1.0/12.0) + 1.0);
vec2 noise2f()
{
    seed += vec2(-1, 1);
    return vec2(fract(sin(dot(seed.xy, vec2(12.9898, 78.233))) * 43758.5453),
                fract(cos(dot(seed.xy, vec2(4.898, 7.23))) * 23421.631));
}

vec3 rayPinhole(vec2 fragOffset)
{
    vec2 uv = vec2(gl_FragCoord.x, iResolution.y - gl_FragCoord.y) + fragOffset - iCameraCenter;
    float d = 1.0/length(vec3(uv, iCameraF));
    return vec3(uv*d, -iCameraF*d);
}

// Adapted from Inigo Quilez
// Source: http://iquilezles.org/www/articles/normalsSDF/normalsSDF.htm
vec3 normal(vec3 p)
{
    vec3 n = vec3(0.0);
    for (int i = ZERO; i < 4; i++)
    {
        vec3 e = 0.5773*(2.0*vec3((((i+3)>>1)&1),((i>>1)&1),(i&1))-1.0);
        n += e*model(p + e*0.002);
    }
    return normalize(n);
}

float traceGround(vec3 ro, vec3 rd)
{
    if (rd.y == 0.0) return -1.0;
    else return (iGroundHeight - ro.y)/rd.y;
}

float traceModel(vec3 ro, vec3 rd)
{
    float t = 0.0;
    for (int i = ZERO; i < STEPS; i++)
    {
        vec3 p = ro + t*rd;
        float d = model(p);
        if (d <= EPSILON) return t;
        t += d;
        if (t > MAX_DISTANCE) break;
    }
    return -1.0;
}

bool isVisible(vec3 ro, vec3 rd)
{
    float tGround = traceGround(ro, rd);
    if (tGround > EPSILON)
        return false;
    float t = 0.0;
    for (int i = ZERO; i < STEPS; i++)
    {
        float d = model(ro + t*rd);
        t += d;
        if (d <= EPSILON)
            return false;
        if (t > MAX_DISTANCE_VISIBILITY_TEST)
            break;
    }
    return true;
}

vec3 cosineWeightedSample(vec3 normal)
{
    vec2 u = noise2f();
    float a = 0.99*(1.0 - 2.0*u[0]);
    float b = 0.99*(sqrt(1.0 - a*a));
    float phi = 6.2831853072*u[1];
    float x = normal.x + b*cos(phi);
    float y = normal.y + b*sin(phi);
    float z = normal.z + a;
    return normalize(vec3(x,y,z));
}

// The corresponding direction pdf is: (exponent + 2)/2pi pow(cosAlpha, exponent)
vec3 phongWeightedSample(vec3 dir, float exponent)
{
    vec3 tangent = vec3(1.0, 0.0, 0.0);
    if (abs(tangent.x) > 0.9)
        tangent = vec3(0.0, 1.0, 0.0);
    vec3 bitangent = cross(tangent, dir);
    tangent = cross(dir, bitangent);
    vec2 u = noise2f();
    float cosAlpha = pow(u[0], 1.0/(exponent + 1.0));
    float sinAlpha = sqrt(1.0 - cosAlpha*cosAlpha);
    float phi = 2.0*M_PI*u[1];
    float x = sinAlpha*cos(phi);
    float y = cosAlpha;
    float z = sinAlpha*sin(phi);
    return x*tangent + y*dir + z*bitangent;
}

vec3 colorModel(vec3 p, vec3 ro)
{
    vec3 n = normal(p);
    vec3 v = normalize(p - ro); // from eye to point
    ro = p + n*2.0*EPSILON;

    vec3 result = vec3(0.0);

    vec3 rd = cosineWeightedSample(n);
    if (isVisible(ro,rd))
        result += vec3(1.0);

    rd = iToSun;
    if (isVisible(ro,rd))
        result += vec3(1.0)*max(0.0,dot(n, rd));

    result *= iMaterialAlbedo;

    if (iMaterialGlossy == 1)
    {
        vec3 w_s = v - 2.0*dot(n, v)*n;
        rd = phongWeightedSample(w_s, iMaterialSpecularExponent);
        if (isVisible(ro, rd) && dot(rd, iToSun) >= iCosSunSize)
            result += iMaterialSpecularAlbedo;
    }
    return result;
}

// Computes a color alternating between white and gray where the gray lines
// indicate points of identical distance to the model.
vec3 colorIsolines(vec3 p)
{
    float d = model(p);
    float a = mod(d - iIsolineThickness*0.5, iIsolineSpacing);
    float t = step(iIsolineSpacing-iIsolineThickness, a) * (1.0 - step(iIsolineMax, d));
    return mix(vec3(1.0), iIsolineColor, t);
}

vec3 colorGround(vec3 p, vec3 ro)
{
    vec3 albedo = vec3(1.0);
    if (iDrawIsolines==1)
        albedo = colorIsolines(p);

    vec3 n = vec3(0.0, 1.0, 0.0);
    vec3 v = normalize(p - ro);
    ro = p + n*2.0*EPSILON;

    vec3 result = vec3(0.0);

    vec3 rd = cosineWeightedSample(n);
    if (isVisible(ro,rd))
        result += vec3(1.0);

    rd = iToSun;
    if (isVisible(ro,rd))
        result += vec3(1.0)*max(0.0,dot(n, rd));

    if (iGroundReflective == 1)
    {
        vec3 w_s = v - 2.0*dot(n, v)*n;
        rd = phongWeightedSample(w_s, iGroundSpecularExponent);
        float tModel = traceModel(ro, rd);
        if (tModel > 0.0)
            result = mix(result, colorModel(ro + tModel*rd, ro), iGroundReflectivity);
    }

    return result*albedo;
}

void main()
{
    vec3 rd = rayPinhole(2.0*(noise2f() - vec2(0.5)));
    vec3 ro = (iView * vec4(0.0, 0.0, 0.0, 1.0)).xyz;
    rd = normalize((iView * vec4(rd, 0.0)).xyz);

    fragColor.rgb = vec3(1.0);
    float tModel = traceModel(ro, rd);
    float tGround = traceGround(ro, rd);
    if (tGround > 0.0 && ((tModel > 0.0 && tGround < tModel) || tModel < 0.0))
        fragColor.rgb = colorGround(ro + rd*tGround, ro);
    else if (tModel > 0.0 && ((tGround > 0.0 && tModel < tGround) || tGround < 0.0))
        fragColor.rgb = colorModel(ro + rd*tModel, ro);
    fragColor.a = 1.0;
}

max_stars_repo_name: marvrez/fraktal

max_issues_repo_name: marvrez/fraktal

max_forks_repo_name: marvrez/fraktal


text:
c=======================================================================
c
c     subroutine TESTSDP
c
c     Matrix test if sdp (0) or not definite positive (1)
c
c-----------------------------------------------------------------------
      SUBROUTINE TESTSDP ( n, X, iwork, dwork, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c
c     WORKSPACE
c            iwork  : vector (n)                                 integer
c            dwork  : vector ( n*(2*n+7) )                          double
c
c     OUTPUT
c            info   : diagnostic argument                        integer
c                     =0, X is sdp
c                     =1, X is not sdp
c
c     CALL
c            DGEES  : Schur factorization (cf. LAPACK)
c            EVMIN  : minimum value of a vector (utils/utmat.f)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION X(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwk, pdwk, pdwev, pdwmat
      DOUBLE PRECISION minvp, EPS
      PARAMETER (EPS = 1.E-12)
c
c     external subroutines
      EXTERNAL schur, EVMIN
c
c-----------------------------------------------------------------------
c
c     initialisations
      info  = 0
      minvp = 0.0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwk = 1
c     piw   : pointer for SCHUR  who needs (n)
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : dwork
c     ----------------------------------------------------------
      pdwk = 1
c     pdwk   : pointer for SCHUR  so (n*(n + 6)
      pdwev = pdwk + ( n*( n + 6 ) )
c     pdwev  : pointer for eigenvalues (n)
      pdwmat = pdwev + n
c     pdwmat : pointer for matrix (n*n)
c
c     Total size of work array = ( n*(2*n + 7) )
c
c-----------------------------------------------------------------------
c
c     computation of the eigenvalues
      CALL schur ( n, X, iwork(piwk), dwork(pdwk),
     &             dwork(pdwev), dwork(pdwmat), info )
c
c     minimum eigenvalue
      CALL EVMIN ( n, dwork(pdwev), minvp )
c
c     if spec(X) < 0 --> exit
      IF (minvp .LT. EPS) THEN
         info = 1
         RETURN
      ENDIF
c
      RETURN
      END

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


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

module MERubiksCube

    use MERubiksCubeCommon
    use MERubiksCubeSearch

    use MERubiksCubeCube
    use MERubiksCubeRotator

    implicit none
    private

    logical, dimension(NUMBER_OF_CUBICLES), parameter :: DEFAULT_MASK  = .true.

    integer, dimension(NUMBER_OF_CUBICLES), parameter :: DEFAULT_STATE = &
            [R, R, R, R, R, R, R, R, R, W, W, W, W, W, W, W, W, W, &
             B, B, B, B, B, B, B, B, B, Y, Y, Y, Y, Y, Y, Y, Y, Y, &
             G, G, G, G, G, G, G, G, G, O, O, O, O, O, O, O, O, O]

    integer, dimension(12), parameter :: DEFAULT_ROTATIONS = &
               [RED_CW, RED_CCW, WHITE_CW, WHITE_CCW, BLUE_CW, BLUE_CCW, &
               YELLOW_CW, YELLOW_CCW, GREEN_CW, GREEN_CCW, ORANGE_CW, ORANGE_CCW]

    type, public :: TERubiksCube
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present()
        type(TESearch)  search

        integer, dimension(NUMBER_OF_CUBICLES) :: source = &
               [R, R, R, R, R, R, R, R, Y, W, W, W, W, W, W, G, W, W, &
                B, B, Y, B, B, B, B, B, B, Y, Y, O, Y, Y, G, G, O, G, &
                G, G, R, G, G, Y, Y, G, W, O, O, O, O, O, Y, O, O, B]

        !integer, dimension(NUMBER_OF_CUBICLES) :: destination = &
        !       [O, G, R, R, R, B, G, W, G, W, R, Y, Y, W, B, B, O, O, &
        !        O, W, R, Y, B, B, B, Y, G, W, O, Y, Y, Y, B, R, G, B, &
        !        Y, G, Y, G, G, R, R, R, O, W, W, W, O, O, W, G, O, B]
        !integer, dimension(NUMBER_OF_CUBICLES) :: destination = &
        !       [R, R, R, R, R, R, R, R, y, W, W, W, W, W, W, G, W, W, &
        !        B, B, Y, B, B, B, B, B, B, Y, Y, O, Y, Y, G, g, O, g, &
        !        G, G, r, G, G, Y, Y, G, W, O, O, O, O, O, Y, o, O, B]
        integer, dimension(NUMBER_OF_CUBICLES) :: destination = &
               [R, R, R, R, R, R, R, R, Y, W, W, W, W, W, W, G, W, W, &
                B, B, Y, B, B, B, B, B, B, Y, Y, O, Y, Y, y, G, y, G, &
                G, G, R, G, G, g, Y, G, W, O, O, O, O, O, o, O, O, B]

        !logical, dimension(NUMBER_OF_CUBICLES) :: mask = &
        !       [.true., .true., .true., .true., .true., .true., .true., .true., .false., &
        !        .true., .true., .true., .true., .true., .true., .false., .true., .true., &
        !        .true., .true., .false., .true., .true., .true., .true., .true., .true., &
        !        .true., .true., .false., .true., .true., .true., .false., .true., .false., &
        !        .true., .true., .false., .true., .true., .true., .false., .true., .false., &
        !        .true., .true., .false., .true., .true., .true., .true., .true., .false.]
        logical, dimension(NUMBER_OF_CUBICLES) :: mask = &
               [.true., .true., .true., .true., .true., .true., .true., .true., .false., &
                .true., .true., .true., .true., .true., .true., .true., .true., .true., &
                .true., .true., .true., .true., .true., .true., .true., .true., .true., &
                .true., .true., .false., .true., .true., .true., .false., .true., .false., &
                .true., .true., .false., .true., .true., .true., .false., .true., .false., &
                .true., .true., .false., .true., .true., .true., .true., .true., .false.]
        !integer, dimension(12) :: rotations = &
        !       [RED_CW, RED_CCW, WHITE_CW, WHITE_CCW, BLUE_CW, BLUE_CCW, &
        !       YELLOW_CW, YELLOW_CCW, GREEN_CW, GREEN_CCW, ORANGE_CW, ORANGE_CCW]
        !integer, dimension(6) :: rotations = &
        !       [BLUE_CW, BLUE_CCW, GREEN_CW, GREEN_CCW, ORANGE_CW, ORANGE_CCW]
        integer, dimension(6) :: rotations = &
               [YELLOW_CW, YELLOW_CCW, GREEN_CW, GREEN_CCW, ORANGE_CW, ORANGE_CCW]

        integer :: depth  = 8
        logical :: status = .false.

        call presentRotation()

        ! search for desired state
        !status = search%search(source, destination, mask, rotations, depth)
    end subroutine

    subroutine presentRotation()
        type(TECube)    cube
        type(TERotator) rotator

        integer, dimension(NUMBER_OF_CUBICLES) :: source = &
               [R, R, R, R, R, R, R, R, Y, W, W, W, W, W, W, G, W, W, &
                B, B, Y, B, B, B, B, B, B, Y, Y, O, Y, Y, G, G, O, G, &
                G, G, R, G, G, Y, Y, G, W, O, O, O, O, O, Y, O, O, B]

        integer, dimension(8) :: rotations = [Y_CCW, G_CW, G_CW, G_CW, Y_CW, G_CCW, G_CCW, G_CCW]
        integer index

        print '(A)', 'Initial state: '
        call cube%set(source)
        call cube%print()
        print '(X)'

        do index = 1, size(rotations)
            call rotator%rotate(cube, rotations(index))
        end do

        print '(A)', 'Destination state: '
        call cube%print()
        print '(X)'
    end subroutine
end module

max_stars_repo_name: jlokimlin/Algorithms

max_issues_repo_name: jlokimlin/Algorithms

max_forks_repo_name: jlokimlin/Algorithms


text:
# ---- for GNU g77 ----

F77 = g77

FFLAGS = -Wall

OFLAGS = -O2

# ---- for SUN WS f77 ----
#
#F77 = f77
#
#FFLAGS =
#
#OFLAGS = -xO2

all: test4g_f test8g_f testsg_f

test4g_f : testxg_f.o fft4g_f.o
	$(F77) testxg_f.o fft4g_f.o -o test4g_f

test8g_f : testxg_f.o fft8g_f.o
	$(F77) testxg_f.o fft8g_f.o -o test8g_f

testsg_f : testxg_f.o fftsg_f.o
	$(F77) testxg_f.o fftsg_f.o -o testsg_f

testxg_f.o : testxg.f
	$(F77) $(FFLAGS) $(OFLAGS) -c testxg.f -o testxg_f.o

fft4g_f.o : ../fft4g.f
	$(F77) $(FFLAGS) $(OFLAGS) -c ../fft4g.f -o fft4g_f.o

fft8g_f.o : ../fft8g.f
	$(F77) $(FFLAGS) $(OFLAGS) -c ../fft8g.f -o fft8g_f.o

fftsg_f.o : ../fftsg.f
	$(F77) $(FFLAGS) $(OFLAGS) -c ../fftsg.f -o fftsg_f.o

clean:
	rm -f *.o

max_stars_repo_name: RobinSchmidt/RS-MET-Preliminary

max_issues_repo_name: RobinSchmidt/RS-MET-Preliminary

max_forks_repo_name: RobinSchmidt/RS-MET-Preliminary


text:
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

type t
end type

print *, (/t()/)
end

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
c      double precision md,mu,ms,mc,mb,mt
c      common/qmass1/md,mu,ms,mc,mb,mt

c      double precision mel,mmu,mtau
c      common/lmass/mel,mmu,mtau

c      double precision hmass,hwidth
c      common/hmass/hmass,hwidth

c      double precision wmass,wwidth
c      common/wmass/wmass,wwidth

c      double precision zmass,zwidth
c      common/zmass/zmass,zwidth

c      double precision twidth
c      common/twidth/twidth

c      double precision tauwidth
c      common/tauwidth/tauwidth

c      double precision mtausq,mcsq,mbsq
c      common/qmassq/mtausq,mcsq,mbsq

      double precision
     & md,mu,ms,mc,mb,mt,
     & mel,mmu,mtau,
     & hmass,hwidth,
     & wmass,wwidth,
     & zmass,zwidth,
     & twidth,
     & tauwidth,
     & mtausq,mcsq,mbsq
      common/masses/
     & md,mu,ms,mc,mb,mt,
     & mel,mmu,mtau,
     & hmass,hwidth,
     & wmass,wwidth,
     & zmass,zwidth,
     & twidth,
     & tauwidth,
     & mtausq,mcsq,mbsq
!$omp threadprivate(/masses/)

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text: Walter Wood shot William Cronin three times on December 17th 1914 to prevent Cronin from killing Fred Nelson at a hobo camp a mile north of Davis. It was the first case in California that dealt with the issue of armed self defense of another. Wood was 21 at the time of the shooting.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      program type06

C     Goal: check the extension of the semantics analysis to string
C     scalar variables in tests

      character*4 c1

      c1 = "TITI"

      if(c1.eq."TOTO") then
         read *, c1
         print *, c1
      endif

      end


text:
      real x(10), y(10)
      integer i, iunit, bincreate
      do 100 i=1, 10
         x(i) = i
 100     continue
      iunit = bincreate('testbin')
      call binout1(iunit, x, 10)
      call binclose(iunit)

      open(unit=7, file='testbin', status='old', access='sequential',
     & form='unformatted')
      read(7) (y(i), i = 1, 10)
      print *, (y(i), i=1,10)
      close(7)
      end

max_stars_repo_name: xylar/cdat

max_issues_repo_name: xylar/cdat

max_forks_repo_name: CDAT/uvcdat


subroutine ensctl2model_ad(eval,mval,grad)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    ensctl2model
!   prgmmr: kleist
!
! abstract:  Contribution from state space to ensemble control vector
!
! program history log:
!   2011-11-17  kleist - initial code
!   2013-10-28  todling - rename p3d to prse
!   Todling: this routine is simply a PLACE HOLDER for now - not working yet
!
!   input argument list:
!     eval - Ensemble state variable variable
!     grad - Control variable
!
!   output argument list:
!     grad - Control variable
!
!$$$ end documentation block

use kinds, only: r_kind,i_kind
use control_vectors, only: control_vector,cvars3d
use gsi_4dvar, only: ibin_anl
use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,nval_lenz_en,ntlevs_ens,n_ens,q_hyb_ens
use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad
use hybrid_ensemble_isotropic, only: ckgcov_a_en_new_factorization_ad
use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad_dual_res
use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult,sqrt_beta_e_mult
use balmod, only: strong_bk_ad
use gsi_bundlemod, only: gsi_bundlecreate
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_bundlemod, only: gsi_bundlegetvar
use gsi_bundlemod, only: gsi_bundleputvar
use gsi_bundlemod, only: gsi_bundledestroy
use gsi_bundlemod, only: assignment(=)
use gsi_bundlemod, only : self_add
use constants, only: zero,max_varname_length
use mpeu_util, only: getindex
use gsi_metguess_mod, only: gsi_metguess_get
use mod_strong, only: tlnmc_option
use timermod, only: timer_ini,timer_fnl
implicit none

! Declare passed variables
type(control_vector), intent(inout) :: grad
type(gsi_bundle)    , intent(inout) :: mval
type(gsi_bundle)    , intent(in   ) :: eval(ntlevs_ens)

! Declare local variables
character(len=*),parameter::myname='ensctl2state'
character(len=max_varname_length),allocatable,dimension(:) :: clouds
integer(i_kind) :: ii,jj,ic,id,istatus,nclouds,nn

integer(i_kind), parameter :: ncvars = 5
integer(i_kind) :: icps(ncvars)
type(gsi_bundle):: wbundle_c ! work bundle
type(gsi_bundle),allocatable :: ebundle(:)
real(r_kind) :: grade(nval_lenz_en)
character(len=3), parameter :: mycvars(ncvars) = (/  &  ! vars from CV needed here
                               'sf ', 'vp ', 'ps ', 't  ',    &
                               'q  '/)
logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh
real(r_kind),pointer,dimension(:,:)   :: cv_ps
real(r_kind),pointer,dimension(:,:,:) :: cv_sf,cv_vp,cv_rh,cv_tv
! Declare required local state variables
integer(i_kind), parameter :: nsvars = 5
integer(i_kind) :: isps(nsvars)
character(len=4), parameter :: mysvars(nsvars) = (/  &  ! vars from ST needed here
                               'u   ', 'v   ', 'prse', 'q   ', 'tsen' /)
logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen
real(r_kind),pointer,dimension(:,:)   :: rv_ps,rv_sst
real(r_kind),pointer,dimension(:,:,:) :: rv_u,rv_v,rv_prse,rv_q,rv_tsen,rv_tv,rv_oz
real(r_kind),pointer,dimension(:,:,:) :: rv_rank3

logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad
logical :: do_tlnmc,lstrong_bk_vars,do_q_copy

!****************************************************************************

! Initialize timer
call timer_ini(trim(myname))

! Inquire about chemistry
call gsi_metguess_get('clouds::3d',nclouds,istatus)
if (nclouds>0) then
    allocate(clouds(nclouds))
    call gsi_metguess_get('clouds::3d',clouds,istatus)
endif

! Since each internal vector of grad has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus)
lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
lc_t  =icps(4)>0; lc_rh =icps(5)>0

! Since each internal vector of grad has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus)
ls_u  =isps(1)>0; ls_v   =isps(2)>0; ls_prse=isps(3)>0
ls_q  =isps(4)>0; ls_tsen=isps(5)>0

! Define what to do depending on what's in CV and SV
lstrong_bk_vars     =lc_sf.and.lc_vp.and.lc_ps .and.lc_t
do_getuv            =lc_sf.and.lc_vp.and.ls_u  .and.ls_v
do_tv_to_tsen_ad    =lc_t .and.ls_q .and.ls_tsen
do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q.and.(.not.q_hyb_ens)
do_q_copy=.false.
if(.not. do_normal_rh_to_q_ad) then
  do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens
end if
do_getprs_ad        =lc_t .and.lc_ps.and.ls_prse

! Initialize
mval%values=zero

do jj=1,ntlevs_ens

   do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. &
         (jj==ibin_anl .and. tlnmc_option==2) )

   !allocate(grade(nval_lenz_en))
   allocate(ebundle(n_ens))
   do nn=1,n_ens
      call gsi_bundlecreate (ebundle(nn),grad%aens(1,1),'m2c ensemble work',istatus)
      if(istatus/=0) then
         write(6,*) trim(myname), ': trouble creating work ens-bundle'
         call stop2(999)
      endif
   enddo

!  Create a temporary bundle similar to grad, and copy contents of grad into it
   call gsi_bundlecreate ( wbundle_c, grad%step(1), 'stat2ensctl work', istatus )
   if(istatus/=0) then
      write(6,*) trim(myname), ': trouble creating work bundle'
      call stop2(999)
   endif
   wbundle_c%values=zero

   call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'q'  ,cv_rh ,istatus)
   call gsi_bundlegetpointer (wbundle_c,'t'  ,cv_tv, istatus)
   call gsi_bundlegetpointer (wbundle_c,'ps' ,cv_ps ,istatus)

! Get sv pointers here
!  Get pointers to required state variables
   call gsi_bundlegetpointer (eval(jj),'u'   ,rv_u,   istatus)
   call gsi_bundlegetpointer (eval(jj),'v'   ,rv_v,   istatus)
   call gsi_bundlegetpointer (eval(jj),'ps'  ,rv_ps,  istatus)
   call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus)
   call gsi_bundlegetpointer (eval(jj),'tv'  ,rv_tv,  istatus)
   call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus)
   call gsi_bundlegetpointer (eval(jj),'q'   ,rv_q ,  istatus)
   call gsi_bundlegetpointer (eval(jj),'oz'  ,rv_oz , istatus)
   call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus)

!  Adjoint of consistency for sensible temperature, calculate sensible temperature
   if(do_tv_to_tsen_ad) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen)

!  If calling TLNMC, already have u,v (so set last argument to true)
   if(do_tlnmc) then

!     Adjoint to convert ps to 3-d pressure
      if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse)
      rv_prse=zero

!     Adjoint of strong_bk
      call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.)
   end if

   call self_add(mval,eval(jj))

!  Adjoint of control to initial state
   call gsi_bundleputvar ( wbundle_c, 't' ,  rv_tv,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'ps',  rv_ps,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'oz',  rv_oz,  istatus )
   call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus )

!  Since cloud-vars map one-to-one, take care of them together
   do ic=1,nclouds
      id=getindex(cvars3d,clouds(ic))
      if (id>0) then
          call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus)
          call gsi_bundleputvar     (wbundle_c, clouds(ic),rv_rank3,istatus)
      endif
   enddo

!  Convert RHS calculations for u,v to st/vp
   if (do_getuv) then
      if(uv_hyb_ens) then
         call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus )
         call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus )
      else
         call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
      end if
   end if

   if(do_q_copy) then
      call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus )
   else

!     Adjoint of convert input normalized RH to q to add contribution of moisture
!     to t, p , and normalized rh
      if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_tv,rv_prse,rv_q)

!     Adjoint to convert ps to 3-d pressure
      if(do_getprs_ad) call getprs_ad(cv_ps,cv_tv,rv_prse)
   end if

   do nn=1,n_ens
      ebundle(nn)%values=grad%aens(jj,nn)%values
   enddo
   if(dual_res) then
      call ensemble_forward_model_ad_dual_res(wbundle_c,ebundle,jj)
   else
      call ensemble_forward_model_ad(wbundle_c,ebundle,jj)
   end if
   call sqrt_beta_s_mult(wbundle_c)

!  Apply square-root of ensemble error covariance
   call sqrt_beta_e_mult(ebundle)
   call ckgcov_a_en_new_factorization_ad(grade,ebundle)

   call gsi_bundledestroy(wbundle_c,istatus)
   if (istatus/=0) then
      write(6,*) trim(myname),': trouble destroying work bundle'
      call stop2(999)
   endif

   do ii=1,n_ens
      grad%aens(jj,ii)%values=grad%aens(jj,ii)%values + grade
   enddo
!  do ii=1,nval_lenz_en
!     grad%aens(jj,1)%values(ii)=grad%aens(jj,1)%values(ii)+grade(ii)
!  enddo

   do nn=n_ens,1,-1 ! first in; last out
      call gsi_bundledestroy(ebundle(nn),istatus)
      if(istatus/=0) then
         write(6,*) trim(myname), ': trouble destroying work ens bundle', nn, istatus
         call stop2(999)
      endif
   enddo
   deallocate(ebundle)
!  deallocate(grade)

end do

if (nclouds>0) deallocate(clouds)

! Finalize timer
call timer_fnl(trim(myname))

return
end subroutine ensctl2model_ad


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                            !!
!! This module stores all the structures.                                     !!
!!                                                                            !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

MODULE structures_mod
    IMPLICIT NONE
    SAVE

    TYPE REACT
        DOUBLE PRECISION, ALLOCATABLE::avector(:)
        DOUBLE PRECISION, ALLOCATABLE::crossTable(:)
        INTEGER::targnum, prodnum, targindx(3), prodindx(4), totnum
        CHARACTER(10)::source
        LOGICAL::isEc
        TYPE (REACT), POINTER::next
    END TYPE REACT

    TYPE CROSSARR
        DOUBLE PRECISION::crossect
        LOGICAL::isEc, isRepeated
        INTEGER::targnum, prodnum, targindx(3), prodindx(4), totnum
        TYPE (CROSSARR), POINTER::next
    END TYPE CROSSARR

    TYPE SHELL
        DOUBLE PRECISION::temp, rho, mass, radiat, radius, hp, pressure
        DOUBLE PRECISION::velocity
        DOUBLE PRECISION, ALLOCATABLE::dens(:)
    END TYPE SHELL

    TYPE INTERSHELL
        TYPE (INTERSHELL), POINTER::convShell
        DOUBLE PRECISION::temp, rho, rho0, rho1, mass0, mass1, rad0, rad1, hp0
        DOUBLE PRECISION::hp1, pres0, pres1, vel0, vel1, radiat0, radiat1
        DOUBLE PRECISION, ALLOCATABLE::dens(:)
        INTEGER::ii0, ii1
        LOGICAL::isConvective = .FALSE.
    END TYPE INTERSHELL

    TYPE INDICES
        CHARACTER(5)::elem
        INTEGER::posit
    END TYPE INDICES

END MODULE structures_mod

max_stars_repo_name: AndresYague/Snuppat

max_issues_repo_name: AndresYague/Snuppat

max_forks_repo_name: AndresYague/Snuppat


SUBROUTINE StartingMessage
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   StartingMessage
   ! PARENT: Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Display starting messages in the console window.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   CHARACTER(LEN=8)  :: date      ! Date
   CHARACTER(LEN=10) :: time      ! Time
   CHARACTER(LEN=5)  :: zone      ! Zone for the Greenwich mean time
   CHARACTER(LEN=3),DIMENSION(12) :: &
      mon=(/&
         'Jan','Feb','Mar','Apr','May','Jun', &
         'Jul','Aug','Sep','Oct','Nov','Dec'  &
      /)
   CHARACTER(len=2) :: day, hor, min, sec
   INTEGER :: val(8)

   ! Catch the date
   CALL DATE_AND_TIME(date,time,zone,val)

   WRITE(*,'(/,A)')   '======================================================'
   WRITE(*,'(/,A)')   '                   F E R I T A S '
   WRITE(*,'(A,/)')   '                      Ver.1.0'
   WRITE(*,'(A)')     'Welcome to FERITAS!'
   WRITE(*,'(A)')     'FERITAS is a finite element method solver developed by'
   WRITE(*,'(A)')     'Toshiro Matsumoto at Nagoya University.'
   WRITE(*,'(A)')     'Copyright 2009 Toshiro Matsumoto. All rights reserved.'
   WRITE(*,'(A,/)')   '======================================================'

   ! Setting the day in two digits
   IF(val(3)>9) then
      WRITE(day,'(I2)') val(3)
   ELSE
      ! Append '0' in front of the figure of the date when it is in one digit.
      WRITE(day,'(A1,I1)') '0',val(3)
   END IF

   ! Setting the hours in two digits
   IF(val(5)>9) then
      WRITE(hor,'(I2)') val(5)
   ELSE
      WRITE(hor,'(A1,I1)') '0',val(5)
   END IF

   ! Setting the minutes in two digits
   IF(val(6)>9) then
      WRITE(min,'(I2)') val(6)
   ELSE
      WRITE(min,'(A1,I1)') '0',val(6)
   END IF

   ! Setting the seconds in two digits
   IF(val(7)>9) then
      WRITE(sec,'(I2)') val(7)
   ELSE
      WRITE(sec,'(A1,I1)') '0',val(7)
   END IF

   WRITE(*,'(A,A2,"/",A3,"/",I4,1X,A2,A,A2,A,A2,A,1X,A,A)') &
      'Computation started at ', &
      day, mon(val(2)), val(1),  &
      hor,'h:',min,'m:',sec,'s', zone,' GMT.'

   return
END SUBROUTINE StartingMessage


text:
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: r1f2kf.f,v 1.2 2006-11-21 01:10:18 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DR1F2KF(IDO,L1,CC,IN1,CH,IN2,WA1)
      DOUBLE PRECISION CH(IN2,IDO,2,L1),CC(IN1,IDO,L1,2),WA1(IDO)
C
      DO 101 K = 1,L1
          CH(1,1,1,K) = CC(1,1,K,1) + CC(1,1,K,2)
          CH(1,IDO,2,K) = CC(1,1,K,1) - CC(1,1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO + 2
      DO 104 K = 1,L1
          DO 103 I = 3,IDO,2
              IC = IDP2 - I
              CH(1,I,1,K) = CC(1,I,K,1) +
     +                      (WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*
     +                      CC(1,I-1,K,2))
              CH(1,IC,2,K) = (WA1(I-2)*CC(1,I,K,2)-
     +                       WA1(I-1)*CC(1,I-1,K,2)) - CC(1,I,K,1)
              CH(1,I-1,1,K) = CC(1,I-1,K,1) +
     +                        (WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
     +                        CC(1,I,K,2))
              CH(1,IC-1,2,K) = CC(1,I-1,K,1) -
     +                         (WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*
     +                         CC(1,I,K,2))
  103     CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2).EQ.1) RETURN
  105 DO 106 K = 1,L1
          CH(1,1,2,K) = -CC(1,IDO,K,2)
          CH(1,IDO,1,K) = CC(1,IDO,K,1)
  106 CONTINUE
  107 RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
great(h1,ff1).
great(f1,i1).
great(ii1,b1).
great(d1,p1).
great(p1,ll1).
great(q1,dd1).
great(z1,r1).
great(j1,ll1).
great(c1,z1).
great(e1,i1).
great(dd1,t1).
great(jj1,ff1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


! ==============================================================================
! Subroutine: READDATA
!
! Purpose: Reads in the RNA energy data files and sets up some tables.
!
! Method:
!
! Arguments:
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependancies:
!
! Modules - RNAVar
! Functions -
! Subroutines -
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      SUBROUTINE READDATA

        USE RNAVar, ONLY : eau,eaup,iwc

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        !=== VARIABLES ===!

        INTEGER :: i,j,k

        !=== Read Data Files ===!

        !=== Setup Tables ===!

        !=== A=1,C=2,G=3,U=4 ===!

        iwc(:,:) = 0
        iwc(1,4) = 1
        iwc(4,1) = 1
        iwc(2,3) = 1
        iwc(3,2) = 1
        iwc(3,4) = 1
        iwc(4,3) = 1

        eaup(:,:) = 0.0e0
        eaup(1,4) = eau
        eaup(4,1) = eau
        eaup(3,4) = eau
        eaup(4,3) = eau

        RETURN

      END SUBROUTINE READDATA


text:
	SUBROUTINE HQCLRS  ( itype, ncolrs, iret )
C************************************************************************
C* HQCLRS - GIF 							*
C* 									*
C* This subroutine returns the number of colors in a color bank.  	*
C* 									*
C* HQCLRS  ( ITYPE, NCOLRS, IRET )					*
C* 									*
C* Input parameters:							*
C*      ITYPE           INTEGER         Image type                      *
C*                                          1 = satellite               *
C*                                          2 = radar                   *
C*                                          3 = fax                     *
C* Output parameters:							*
C*	NCOLRS		INTEGER		Number of colors		*
C*	IRET		INTEGER		Return code			*
C*					0 = normal			*
C*					-1 = invalid image type		*
C**									*
C* Log:									*
C* J. Nielsen-G/TAMU	 8/98	Created					*
C* T. Lee/GSC		 7/00	Removed unnecessary include files	*
C* R. Tian/SAIC		05/02	Added fax image type			*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'driver.cmn'
C*
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Set the color range
C
	IF  ( itype .EQ. 1 )  THEN
	    ncolrs  = nbwsat
	ELSE IF  ( itype .EQ. 2 )  THEN
	    ncolrs  = nbwrad
	ELSE IF  ( itype .EQ. 3 )  THEN
	    ncolrs  = nbwfax
	ELSE
	    iret = -1
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      INCLUDE 'VICMAIN_FOR'
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
C  REVISION HISTORY
C   4-97  SP  Made portable for UNIX.
c   4-01  lwk removed RECLEN from OPEN, since it gives errors on linux
c	      and is not needed on VMS

	SUBROUTINE MAIN44
C
C	VICAR PROGRAM EZLIST
C
        PARAMETER (MAXNS = 1024)
	INTEGER	WIDTH,SLEN
	REAL	DATA(MAXNS)
        LOGICAL XVPTST, REMOVEDOTS
	CHARACTER*80 FORMAT, FORM
        character*255 OUTNAME
	CHARACTER*20000 STRING

	REMOVEDOTS = XVPTST ('INTEGER')
	IF (XVPTST('W132')) THEN
	    WIDTH = 132
	ELSE
	    WIDTH = 80
	ENDIF

	CALL XVP ('OUT', OUTNAME, ICNTO)
	IF (ICNTO .GT. 0) THEN
           OPEN (UNIT=1,FILE=OUTNAME,STATUS='UNKNOWN',
     1            ERR=999, IOSTAT=J)
	ENDIF

	CALL XVUNIT(inunit,'INP',1,IST,' ')
	CALL XVOPEN(inunit,IST,'U_FORMAT','REAL','OPEN_ACT', 'SA',
     .             'IO_ACT', 'SA' ,' ')

	IF (IST .NE. 1) GO TO 998
	CALL XVGET(inunit,IST,'NL',NL,'NS',NS,' ')
        IF (NS .GT. MAXNS)
     .     CALL MABEND('ERR: Input NS too large. Try COPY of subimage')

	CALL XVPARM ('FORMAT',FORMAT,ICNT,IDEF,1)
	IF (ICNT .EQ. 0) THEN
	   FORMAT = '(F9.2,2X)'
	END IF
        CALL UPRCASE(FORMAT)    ! INSURE IT IS UPPER CASE.

	IF (INDEX(FORMAT(1:),'F') .EQ. 0) GO TO 996

	LENF = INDEX(FORMAT(1:),' ')-1

C-------if format is missing parens, add them
	IF (FORMAT(1:1) .NE. '(' ) THEN
		FORMAT(1:LENF+2) = '('// FORMAT(1:LENF) //')'
		LENF=LENF+2
	END IF
c-------add Repeat factor of NS to 'run-time' format

	FORM = '(xxxx' // FORMAT(1:LENF) // ')'
	WRITE (FORM(2:5), '(I4)') NS
c
	DO K = 1, NL
            CALL XVREAD(INUNIT,DATA,IST,' ')
	    WRITE (STRING, FORM) (DATA(I), I = 1, NS)
	    IF (REMOVEDOTS)  CALL REMOVEPOINTS (STRING)
            LENS = SLEN(STRING)
	    IF (ICNTO .GT. 0)  THEN
		WRITE (1, '(1X, A)', IOSTAT=J,ERR=999)  STRING(1:LENS)
	    ELSE
		CALL XVMESSAGE ( STRING(1: MIN(LENS,WIDTH)) ,' ')
	    ENDIF
	ENDDO
	CALL XVCLOSE (INUNIT,IST,' ')

	IF (ICNTO .GT. 0) THEN
	    CLOSE (UNIT=1)
	ENDIF

	RETURN
996	CALL XVMESSAGE('NO F IN FORMAT PARAMETER',' ')
	CALL ABEND
998	CALL XVMESSAGE('ERROR OPENING INPUT FILE',' ')
	CALL ABEND
999	CALL XVMESSAGE('ERROR WRITING OUTPUT FILE',' ')
	CALL PRNT(4,1,J,'IOSTAT=.')
	CALL ABEND
	END
	SUBROUTINE REMOVEPOINTS (STRING)
	IMPLICIT NONE
	CHARACTER*(*) STRING
	INTEGER	I

	DO I = 1, LEN(STRING)
	    IF (STRING(I:I+1) .EQ. '. ')  STRING(I:I) = ' '
	ENDDO

	RETURN
	END
	INTEGER FUNCTION SLEN (STRING)
	IMPLICIT NONE
	CHARACTER*(*) STRING
	INTEGER	N

	N = LEN(STRING)
	DO WHILE (N .GT. 1 .AND. STRING(N:N) .EQ. ' ')
	    N = N - 1
	ENDDO
	SLEN = N
	RETURN
	END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine calc_iobnum(tMST,tproc,trank,tiobnum,nproc_ob,iparaway_ob)
implicit none
integer :: tMST,tproc,trank,tiobnum
integer :: nproc_ob,iparaway_ob

if(iparaway_ob==1)then
  tiobnum=(trank+1)*tMST/nproc_ob-trank*tMST/nproc_ob
else if(iparaway_ob==2)then
  if(mod(tMST,tproc)==0)then
    tiobnum=tMST/tproc
  else
    if(trank<mod(tMST,tproc))then
      tiobnum=tMST/tproc+1
    else
      tiobnum=tMST/tproc
    end if
  end if
end if

end subroutine calc_iobnum

max_stars_repo_name: shunsuke-sato/SALMON

max_issues_repo_name: shunsuke-sato/SALMON

max_forks_repo_name: shunsuke-sato/SALMON


text:
! This is a bug in gfortran (version 4.1.2) (gfortran asks that the error be reported)
! It however correctly handled in OFP, as I understand it.
!      READ (fmt=1) A

! This fails and does not report the presence of the "*" in OFP
!      READ *

! This is the format option (though no action in OFP makes this detectable, same as above)
!      READ *, A

! This works fine (and it interpreted as unit=*)
!      READ (*) A

! This is the fomat specifier, but is handled properly in OFP.
      READ 1, A

! This is interpeted properly as unit specifier.
!      READ (1) A

    ! This a comment even though not starting in column 1
      WRITE (*,1) A

! This is a print
      PRINT 1, A

 1    FORMAT ()
      END


text:
C
C $Id: semess.f,v 1.6 2008-07-27 00:17:31 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
      FUNCTION SEMESS (ITRIM)
C
        CHARACTER*113 SEMESS
C
C The value of this function is some portion of the current error
C message (blanks if there is no current error).  If the value of
C ITRIM is less than or equal to zero, the entire error message is
C returned.  If the value of ITRIM is equal to 1, prepended routine
C names and associated slashes are removed.  If the value of ITRIM
C is 2 or greater, all routine names are removed, along with the
C following hyphen and the blanks around the hyphen.  For example,
C if the current error message is
C
C   'CPCLAM/AREDAM - AREA-MAP ARRAY OVERFLOW'
C
C then
C
C   SEMESS(0)='CPCLAM/AREDAM - AREA-MAP ARRAY OVERFLOW'
C   SEMESS(1)='AREDAM - AREA-MAP ARRAY OVERFLOW'
C   SEMESS(2)='AREA-MAP ARRAY OVERFLOW'
C
C The common blocks SECOMI and SECOMC are used to hold shared variables
C of types INTEGER and CHARACTER, respectively, for the routine SETER
C and associated routines.  For descriptions of these variables and for
C default values of them, see the block data routine SEBLDAX.
C
        COMMON /SECOMI/ IERRU,IERRF,IRECF,LOMSG
        SAVE   /SECOMI/
C
        COMMON /SECOMC/ ERMSG
          CHARACTER*256 ERMSG
        SAVE   /SECOMC/
C
C Return either blanks or the requested portion of the current message.
C
        IF (IERRF.EQ.0) THEN
          SEMESS=' '
        ELSE IF (ITRIM.LE.0) THEN
          SEMESS=ERMSG(1:LOMSG)
        ELSE
          IBEG=1
          IF (ITRIM.EQ.1) THEN
            DO 101 I=1,LOMSG
              IF (ERMSG(I:I).EQ.'/') IBEG=I+1
              IF (ERMSG(I:I).EQ.'-') GO TO 103
  101       CONTINUE
          ELSE
            DO 102 I=1,LOMSG
              IF (ERMSG(I:I).EQ.'-') THEN
                IBEG=I+2
                GO TO 103
              END IF
  102       CONTINUE
          END IF
  103     IF (IBEG.GT.LOMSG) IBEG=1
          SEMESS=ERMSG(IBEG:LOMSG)
        END IF
C
C Done.
C
        RETURN
C
      END


text:
! Generated by cart. DO NOT EDIT
program main
    implicit none

    if (.not.run()) stop 1
contains
    function run() result(passed)
        use drop_then_test, only: &
                drop_then_drop_then => &
                    test_drop_then
        use either_test, only: &
                either_either => &
                    test_either
        use many1_test, only: &
                many1_many1 => &
                    test_many1
        use many1_with_separator_test, only: &
                many1_with_separator_many1_with_separator => &
                    test_many1_with_separator
        use many_test, only: &
                many_many => &
                    test_many
        use many_with_separator_test, only: &
                many_with_separator_many_with_separator => &
                    test_many_with_separator
        use optionally_test, only: &
                optionally_optionally => &
                    test_optionally
        use parse_character_test, only: &
                parse_character_parse_character => &
                    test_parse_character
        use parse_digit_test, only: &
                parse_digit_parse_digit => &
                    test_parse_digit
        use parse_end_of_input_test, only: &
                parse_end_of_input_parse_end_of_input => &
                    test_parse_end_of_input
        use parse_integer_test, only: &
                parse_integer_parse_integer => &
                    test_parse_integer
        use parse_rational_test, only: &
                parse_rational_parse_rational => &
                    test_parse_rational
        use parse_string_test, only: &
                parse_string_parse_string => &
                    test_parse_string
        use parse_whitespace_test, only: &
                parse_whitespace_parse_whitespace => &
                    test_parse_whitespace
        use parse_with_test, only: &
                parse_with_parse_with => &
                    test_parse_with
        use position_test, only: &
                position_position => &
                    test_position
        use repeat_test, only: &
                repeat_repeat => &
                    test_repeat
        use sequence_test, only: &
                sequence_sequence => &
                    test_sequence
        use then_drop_test, only: &
                then_drop_then_drop => &
                    test_then_drop
        use veggies, only: test_item_t, test_that, run_tests

        logical :: passed

        type(test_item_t) :: tests
        type(test_item_t) :: individual_tests(19)

        individual_tests(1) = drop_then_drop_then()
        individual_tests(2) = either_either()
        individual_tests(3) = many1_many1()
        individual_tests(4) = many1_with_separator_many1_with_separator()
        individual_tests(5) = many_many()
        individual_tests(6) = many_with_separator_many_with_separator()
        individual_tests(7) = optionally_optionally()
        individual_tests(8) = parse_character_parse_character()
        individual_tests(9) = parse_digit_parse_digit()
        individual_tests(10) = parse_end_of_input_parse_end_of_input()
        individual_tests(11) = parse_integer_parse_integer()
        individual_tests(12) = parse_rational_parse_rational()
        individual_tests(13) = parse_string_parse_string()
        individual_tests(14) = parse_whitespace_parse_whitespace()
        individual_tests(15) = parse_with_parse_with()
        individual_tests(16) = position_position()
        individual_tests(17) = repeat_repeat()
        individual_tests(18) = sequence_sequence()
        individual_tests(19) = then_drop_then_drop()
        tests = test_that(individual_tests)

        passed = run_tests(tests)

    end function
end program

max_stars_repo_name: everythingfunctional/parff

max_issues_repo_name: everythingfunctional/parff

max_forks_repo_name: everythingfunctional/parff