text:
SUBROUTINE check(iexit)

!-------------------------------------------------------------
!
! Check the read input that includes the problem size,
!  the angular quadrature, the boundary conditions,
!  the iteration controls, the material map, and
!  the spatial moments
!
!-------------------------------------------------------------

USE invar
USE totvar
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: iexit
INTEGER :: n
REAL*8, DIMENSION(apo) :: leng

! Before starting IF constructs, set up ordinate lengths to make sure they're 1 or less
DO n = 1, apo
   leng(n) = SQRT(ang(n,1)*ang(n,1) + ang(n,2)*ang(n,2))
END DO

! Spatial moment order
IF (lambda < 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: illegal entry for lambda. Must be zero or greater."
   iexit = iexit + 1

! Method of solution
ELSE IF (meth /= 0 .AND. meth /= 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Method value 'meth' must be 0 or 1."
   iexit = iexit + 1

! Cell number of cells, groups, materials
ELSE IF (nxt < 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal number of x cells. Must be positive."
   iexit = iexit + 1
ELSE IF (nyt < 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal number of y cells. Must be positive."
   iexit = iexit + 1
ELSE IF (npx*npy /= isize) THEN
   WRITE(8,'(/,3X,A)') "ERROR: Illegal number of P_i x P_j sub-domains."
   iexit = iexit + 1
ELSE IF (ng < 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal number of energy groups. Must be positive."
   iexit = iexit + 1
ELSE IF (nm < 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal number of materials. Must be positive."
   iexit = iexit + 1

! Cell sizes
ELSE IF (MINVAL(dxt) <= 0.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal x cell dimension, dx. Must be positive."
   iexit = iexit + 1
ELSE IF (MINVAL(dyt) <= 0.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal y cell dimension, dy. Must be positive."
   iexit = iexit + 1

! Material map
ELSE IF (MINVAL(matt) < 1 .OR. MAXVAL(matt) > nm) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value in material map. Must be in [1, #materials]."
   iexit = iexit + 1

! BCs
ELSE IF (q1bc /= 0 .AND. q1bc /= 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal Q1 BC. Must be 0-Vac or 1-Input."
   iexit = iexit + 1
ELSE IF (q2bc /= 0 .AND. q2bc /= 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal Q2 BC. Must be 0-Vac or 1-Input."
   iexit = iexit + 1
ELSE IF (q3bc /= 0 .AND. q3bc /= 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal Q3 BC. Must be 0-Vac or 1-Input."
   iexit = iexit + 1
ELSE IF (q4bc /= 0 .AND. q4bc /= 1) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal Q4 BC. Must be 0-Vac or 1-Input."
   iexit = iexit + 1

! Iteration control parameters
ELSE IF (err <= 0.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal convergence criterion. Must be positive."
   iexit = iexit + 1
ELSE IF (bitmx <= 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal max PBJ iterations, bitmx. Must be positive."
   iexit = iexit + 1
ELSE IF (itmx <= 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal max inner iterations, itmx. Must be positive."
   iexit = iexit + 1
ELSE IF (tolr <= 0.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal tolerance setting, tolr. Must be positive."
   iexit = iexit + 1
ELSE IF (iall < 0 .OR. iall > lambda) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for moments to converge, iall. Must be in [0, lambda]."
   iexit = iexit + 1

! Checks on the solution
ELSE IF (ichk < 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for solution check flag, iall."
   WRITE(8,'(/,3x,A)') "iall is 0 (skip check) or positive integer"
   iexit = iexit + 1
ELSE IF (tchk < 0.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for solution check tolerance, tchk. Must be positive."
   iexit = iexit + 1

! Checks on the angular quadrature
ELSE IF (MINVAL(ang) <= 0. .OR. MAXVAL(ang) >= 1.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for direction cosine. Must be entered positive, less than 1."
   iexit = iexit + 1
ELSE IF (MINVAL(w) <= 0. .OR. MAXVAL(w) > 0.25) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for weight. Must be entered positive, less than 0.25."
   iexit = iexit + 1
ELSE IF (MAXVAL(leng) >= 1.) THEN
   WRITE(8,'(/,3x,A)') "ERROR: a discrete ordinate has length >= 1 based on mu, eta values."
   iexit = iexit + 1

! Checks on the editing input
ELSE IF (momp < 0 .OR. momp > lambda) THEN
   WRITE(8,'(/,3X,A)') "ERROR: Illegal value for max moment to print, momp. Must be between 0 and lambda."
   iexit = iexit + 1
ELSE IF (pmoaf /= 0 .AND. pmoaf /= 1 .AND. pmoaf /= 2) THEN
   WRITE(8,'(/,3X,A)') "ERROR: Illegal value for flag for printing outward angular flux at boundaries."
   WRITE(8,'(/,3X,A)') "       Must be 0/1/2 = none/zero moment only/all moments"
   iexit = iexit + 1

! Or there is nothing wrong, report that and continue
ELSE
   WRITE(8,'(/,3X,A,//)') "No input errors have been detected."

END IF

RETURN
END SUBROUTINE check

max_stars_repo_name: lanl/pidots

max_issues_repo_name: lanl/pidots

max_forks_repo_name: lanl/pidots


text:
Master Rick knows Hapkido.  Enough said.

He is the instructor of the Experimental Colleges Hapkido class.  The following is care of the Experimental College:

Rick Schubert has been training martial arts for over thirty years and has been teaching Hapkido for over twenty years, including five years as head instructor of Hapkido at the University of Connecticut and ten years . . at the Experimental College.

He actually gets to attack his students.  I know profs who would love that.  Below are some choice quotes of or related to Master Rick Schubert.

Master Rick is a titan among men.  Jonathan Slakey

Studies have shown people that do not breathe report low quality of life.  Master Rick

Contrary to popular belief, you do not need to be a pregnant chicken in order to practice Hapkido.  Master Rick

The five tenets of Hapkido are:

 Courtesy
 Integrity
 Perserverence
 Self Control
 Indomitable Spirit

Does he also teach Philosophy philosophy during summer sessions? Users/AmeliaCarlson aec

Yes, Master Rick is also a professor of Philosophy philosophy. Users/HaleyKo

I was in his phi east and west class.  Hes... an... interesting person, with...interesting exampes... Users/MarieHuynh
  I also took his east vs west class (back in... uuh... 1995?).  He was very rigorous, and helpful in office hours.  It was interesting watching him try to work Harley motorcycles into every example. Users/AlexPomeranz

The best martial arts instructor Ive ever had. Users/BlancheNonken

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
*+ graphic_device_select

       subroutine graphic_device_select( idev, s )
C      -------------------------------------------
C
C Select one of the standard Graphic devices
C
C Given:
C  selected device
      integer    idev
C
C Updated:
C  error status
      integer    s
C
C The specified device is selected.  If the device is currently open then
C subsequent plotting commands are directed to this device, if the device is
C not currently open then the device is still selected but will not be physically
C opened, an output-device command can then be used to change the device
C specification for this standard device.
C-

       include '../include/plt_basic_defn.inc'
       include '../include/plt_error_defn.inc'

C local variables
       integer  n

       if (s.ne.0) return

C enable default selection
       if (idev.eq.0) then
         n = plot_list_default
       else
         n = idev
       endif

C perform selection
       if (n.le.0 .or. n.gt.plot_list_max) then
          s = ill_grdev
       else
          plot_list_open(plot_list_selected) = plot_open
          plot_list_device(plot_list_selected) = plot_device
          plot_list_aspect(plot_list_selected) = plot_aspect
          plot_list_size(plot_list_selected) = plot_size
          if (n.ne.plot_list_selected) then
             plot_list_selected = n
             plot_open = plot_list_open(plot_list_selected)
             plot_device = plot_list_device(plot_list_selected)
             if (plot_open) then
               plot_size = plot_list_size(plot_list_selected)
               plot_aspect = plot_list_aspect(plot_list_selected)
               call pgselect(plot_list_id(plot_list_selected))
               call pgpap(plot_size,plot_aspect)
             endif
          endif
       endif

       call cmd_err(s,'graphic_device_select',' ')
       end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
SUBROUTINE gammas

!-------------------------------------------------------------
!
! Construct the gamma sub-matrices from gmat
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER :: i, j

! Now make the submatrices from gmat
! gaa
DO j = 1, ordsq
   DO i = 1, ordsq
      gaa(i,j) = gmat(i,j)
   END DO
END DO
! gax & gay
DO j = 1, order
   DO i = 1, ordsq
      gax(i,j) = gmat(i,(ordsq+j))
      gay(i,j) = gmat(i,(ordsq+order+j))
   END DO
END DO

! gxa & gya
DO j = 1, ordsq
   DO i = 1, order
      gxa(i,j) = gmat((ordsq+i),j)
      gya(i,j) = gmat((ordsq+order+i),j)
   END DO
END DO

! gxx, gxy, gyx, & gyy
DO j = 1, order
   DO i = 1, order
      gxx(i,j) = gmat((ordsq+i),(ordsq+j))
      gxy(i,j) = gmat((ordsq+i),(ordsq+order+j))
      gyx(i,j) = gmat((ordsq+order+i),(ordsq+j))
      gyy(i,j) = gmat((ordsq+order+i),(ordsq+order+j))
   END DO
END DO

RETURN
END SUBROUTINE gammas


text:
      LOGICAL FUNCTION SB02MV( REIG, IEIG )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To select the stable eigenvalues for solving the continuous-time
C     algebraic Riccati equation.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     REIG    (input) DOUBLE PRECISION
C             The real part of the current eigenvalue considered.
C
C     IEIG    (input) DOUBLE PRECISION
C             The imaginary part of the current eigenvalue considered.
C
C     METHOD
C
C     The function value SB02MV is set to .TRUE. for a stable eigenvalue
C     and to .FALSE., otherwise.
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  IEIG, REIG
C     .. Executable Statements ..
C
      SB02MV = REIG.LT.ZERO
C
      RETURN
C *** Last line of SB02MV ***
      END

max_stars_repo_name: bgin/MissileSimulation

max_issues_repo_name: bgin/MissileSimulation

max_forks_repo_name: bgin/MissileSimulation


SUBROUTINE CleanSparseMatrixCOO(SM)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (SparseArray_CSR) :: tmpSM
TYPE (SparseArray_COO) :: SM
INTEGER :: nnz, ierr, nrow, job
INTEGER, DIMENSION(:), ALLOCATABLE :: iwk, indu

! Convert to CSR format and back to COO format to remove duplicate entries
nrow       = SM%nrow
tmpSM%nrow = nrow
nnz        = SM%nnz
tmpSM%nnz  = nnz

ALLOCATE( tmpSM%val(tmpSM%nnz)        )
ALLOCATE( tmpSM%col_ind(tmpSM%nnz)    )
ALLOCATE( tmpSM%row_ptr(tmpSM%nrow+1) )

CALL coocsr(nrow,nnz,SM%val,SM%row_ptr,SM%col_ind,tmpSM%val,tmpSM%col_ind,tmpSM%row_ptr)
!print * ,'precond matrix converted from COO to CSR format.'
!print * ,'nnz = ', tmpsM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1)

! Clean duplicates

ALLOCATE( iwk(tmpSM%nrow+1) )
ALLOCATE( indu(tmpSM%nrow)  )

CALL clncsr(1,1,tmpSM%nrow,tmpSM%val,tmpSM%col_ind,tmpSM%row_ptr,indu,iwk)

!print * ,'precond matrix cleaned for duplicates.'
!print * ,'nnz = ', tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1)

! Convert back to COO format
DEALLOCATE( SM%val, SM%row_ptr, SM%col_ind)
SM%nnz = tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1)

ALLOCATE( SM%val(SM%nnz) )
ALLOCATE( SM%col_ind(SM%nnz) )
ALLOCATE( SM%row_ptr(SM%nnz) )

! FIXME: job=3 used here, but can be made more efficient, by only redirecting pointers?
job = 3
CALL csrcoo(tmpSM%nrow,job,tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1),&
			tmpSM%val,tmpSM%col_ind,tmpSM%row_ptr,&
			tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1),&
			SM%val,SM%row_ptr,SM%col_ind,ierr)

!print * ,'precond matrix converted from CSR to COO format.'

!filename = "SparseMatrix.bin"
!CALL StoreSparseMatrix(FineGrid%PreconditioningMatrix,filename,formattype)
!WRITE(*,'(A)') 'Sparse matrix stored.'
DEALLOCATE(iwk, indu)
DEALLOCATE(tmpSM%val, tmpSM%row_ptr, tmpSM%col_ind)

END SUBROUTINE CleanSparseMatrixCOO


text:
The East Area Water Tank is a fourmillion gallon water tank recently completed at 44085 County Road 32A by the City of Davis. It is visible from Ikedas and Mace Boulevard. The East Area Tank is similar in materials and dimensions to the West Area Water Tank north of Sutter Hospital. It is a concrete reservoir approximately 135 feet in diameter, about 32 feet high (with an additional 10 feet buried). The site also has a separate structure that houses the pumps and electrical system.  The purpose of the tank is to help with water pressure on the south and east sides of the city, as well as to help provide water during emergencies (fire, power loss, etc.).  During regular use, the tank will be left halffull.  Or, halfempty, depending on how you look at it.

Artist team Sofia Lacin and Hennessy Christophel of http://www.lcmuralanddesign.com/ LC Mural and Design were selected by the City of Davis to execute their design for the 4 million gallon water tank. They made a mural on the side of the tank, and grillwork around the top of the tank that casts shadows onto the side of the tank.  http://www.davisenterprise.com/localnews/city/daviswatertankart%E2%80%98shinesuponusall%E2%80%99/ According to the Davis Enterprise, the monument was named Public Works Project of the Year by the Sacramento Chapter of the American Public Works Association.

At the right time of year, around Summer Solstice, the white letters on the side of the tank combine with shadows from the grillwork on top to spell sol omnibus lucet, or as translated in smaller letters below, the sun shines upon us all.  Lacin and Christophel called the work Same Sun.  (See also the http://www.davistank.blogspot.com Water Tank Blog for other details.)

Bob Dunning has repeatedly alleged over the course of two years that the mural is a waste of money, but also recently stated, Ive been willing to wait until the solstice arrives before pronouncing final judgment...  Since the 2012 summer solstice, Dunning has said almost nothing about the water tank.

20110811 14:46:44 nbsp Am I the only one who thinks the water tank is ugly? I hope that the paint theyre putting on is just a base coat for a mural and its not staying this way... Users/jsbmeb

20110811 14:49:50 nbsp  Yes, agreed.  Badly in need of a paint job. Users/OldDavis73

20110811 15:22:25 nbsp Doh. Looks like this is and will be the mural. I should have read more in the description.  Users/jsbmeb
  Its not clear to me whether the job is done or not.  Dunning has suggested that it might be.  I am not sure.   Users/CovertProfessor

20111116 16:59:39 nbsp $75,000? Really!? well spent Davis! ...Or not. Thanks for the eyesore! Was this REALLY the best proposal given?
My son described the colors as a bloody body dragged through baby poop and I honestly think that sums it up PERFECTLY! Users/Antoinette

20120111 17:49:43 nbsp At certain times of the year the stickingoutbits at the top of the tank will throw shadows of letters that complete the wording on the tank.  Users/AnneHance

20120111 17:57:43 nbsp $75,000 for art? Great. Lacin and Christobel have public art all over Sacramento, from the Shady Lady Murals to East Sacramento Hardware and many more. I hope they evolve to challenge viewers more. A tightrope to walk for any artist, taking money and challenging viewers at the same time, but they have solid representational talent that does look ready to evolve in different directions. Users/ChristopherHitchens

20120112 11:47:57 nbsp So the mural is, well, a Davis mural.  And thats ok.  But the sculptural elements around the top just look like so much leftover construction trash. Users/JimStewart

20120112 14:30:57 nbsp I am clearly in a minority (so far) of wiki viewers in that I think the water tank art is a fine achievement. It could have been a commonorgarden painted sign but instead it is colorful and rather unique as a sort of sundial.  Perhaps if Lacin and Christobel had painted the sculptural elements too in some colorful way they would be seen as part of the overall effect. Users/AnneHance

20120117 16:41:01 nbsp Ive tried to suck it up and keep my mouth shut, but I cant.  The thing is ugly.  The sculptural elements look like so much construction trash.  I have a suggestion.  Next time the city has a need to paint concrete to greet people as they enter Davis, think Sunflowers.  Big, pretty sunflowers.  If I want art to challenge me, Ill go over to the Natsoulas Art Gallery and wander around confused.  I have enough on my mind driving 70 on Interstate 80. Users/JimStewart

20120303 20:04:20 nbsp I agree with what Users/AnneHance wrote...I think the mural is great!  Whenever I drive by on the freeway, it often looks as if its commingling with the sky and landscape.  I find the phrase they chose (Sol omnibus lucet/The sun shines on us all) uplifting whenever I see the mural or think of it.  I appreciate the amount of thought, care and effort the artists put into it, and Im glad they did something extraordinary. Users/DukeMcAdow

20120520 08:37:55 nbsp People snub artists payment for their work all the time. Honestly, if you thought you could do better and would do so for less you should have applied. Users/KBathory
 I did apply, I just dont think my Idea was creative enough in how I was going to waste the lions share of 100kDaubert

20120625 09:58:36 nbsp My opinion now aligns with Users/AnneHance: I think this is a fine achievement artistically. Users/DougWalter

20120625 10:03:28 nbsp While I can, and do, appreciate the piece, I also feel there were much better ways for the city to spend the funds. Users/WesP

20120830 13:37:05 nbsp Now that the artwork is finished, the water tank is another wonderful Davis icon.  Congratulations to the artists for doing a great job. Users/GregKuperberg


text:
      SUBROUTINE RESTIN2
C
C CHANGE RECORD
C **  SUBROUTINE RESTINP READS A RESTART FILE FOR (KC/2) LAYERS AND
C **  AND INITIALIZES FOR KC LAYERS
C
      USE GLOBAL

      PRINT *,'READING RESTIN2 FILE: RESTART.INP'
      OPEN(1,FILE='RESTART.INP',STATUS='UNKNOWN')
      READ(1,908,ERR=1000)NREST
      DO L=2,LA
        READ(1,*,ERR=1000)HP(L),H1P(L),HWQ(L),H2WQ(L)
        READ(1,*,ERR=1000)UHDYE(L),UHDY1E(L),VHDXE(L),VHDX1E(L)
        READ(1,*,ERR=1000)(U(L,K),K=2,KC,2)
        READ(1,*,ERR=1000)(U1(L,K),K=2,KC,2)
        READ(1,*,ERR=1000)(V(L,K),K=2,KC,2)
        READ(1,*,ERR=1000)(V1(L,K),K=2,KC,2)
        READ(1,*,ERR=1000)(QQ(L,K),K=0,KC,2)
        READ(1,*,ERR=1000)(QQ1(L,K),K=0,KC,2)
        READ(1,*,ERR=1000)(QQL(L,K),K=0,KC,2)
        READ(1,*,ERR=1000)(QQL1(L,K),K=0,KC,2)
        READ(1,*,ERR=1000)(DML(L,K),K=0,KC,2)
        DO K=1,KS,2
          U(L,K)=U(L,K+1)
          U1(L,K)=U1(L,K+1)
          V(L,K)=V(L,K+1)
          V1(L,K)=V1(L,K+1)
          QQ(L,K)=0.5*(QQ(L,K-1)+QQ(L,K+1))
          QQSQR(L,K)=SQRT(QQ(L,K))  ! *** DSLLC
          QQ1(L,K)=0.5*(QQ1(L,K-1)+QQ1(L,K+1))
          QQL(L,K)=0.5*(QQL(L,K-1)+QQL(L,K+1))
          QQL1(L,K)=0.5*(QQL1(L,K-1)+QQL1(L,K+1))
          DML(L,K)=0.5*(DML(L,K-1)+DML(L,K+1))
        ENDDO
        IF(ISCI(1).EQ.1)THEN
          READ(1,*,ERR=1000)(SAL(L,K),K=2,KC,2)
          READ(1,*,ERR=1000)(SAL1(L,K),K=2,KC,2)
          DO K=1,KS,2
            SAL(L,K)=SAL(L,K+1)
            SAL1(L,K)=SAL1(L,K+1)
          ENDDO
        ENDIF
        IF(ISCI(2).EQ.1)THEN
          READ(1,*,ERR=1000)(TEM(L,K),K=2,KC,2)
          READ(1,*,ERR=1000)(TEM1(L,K),K=2,KC,2)
          DO K=1,KS,2
            TEM(L,K)=TEM(L,K+1)
            TEM1(L,K)=TEM1(L,K+1)
          ENDDO
        ENDIF
        IF(ISCI(3).EQ.1)THEN
          READ(1,*,ERR=1000)(DYE(L,K),K=2,KC,2)
          READ(1,*,ERR=1000)(DYE1(L,K),K=2,KC,2)
          DO K=1,KS,2
            DYE(L,K)=DYE(L,K+1)
            DYE1(L,K)=DYE1(L,K+1)
          ENDDO
        ENDIF
        IF(ISCI(4).EQ.1)THEN
          READ(1,*,ERR=1000)SEDB(L,1,1),(SED(L,K,1),K=2,KC,2)
          READ(1,*,ERR=1000)SEDB1(L,1,1),(SED1(L,K,1),K=2,KC,2)
          DO K=1,KS,2
            SED(L,K,1)=SED(L,K+1,1)
            SED1(L,K,1)=SED1(L,K+1,1)
          ENDDO
        ENDIF
        IF(ISCI(5).EQ.1)THEN
          READ(1,*,ERR=1000)(SFL(L,K),K=2,KC,2)
          READ(1,*,ERR=1000)(SFL2(L,K),K=2,KC,2)
          DO K=1,KS,2
            SFL(L,K)=SFL(L,K+1)
            SFL2(L,K)=SFL2(L,K+1)
          ENDDO
        ENDIF
      ENDDO
      DO M=1,5
        IF(ISCI(M).EQ.1)THEN
          DO LL=1,NCBS
            READ(1,*,ERR=1000)(NLOS(LL,K,M),K=2,KC,2)
            READ(1,*,ERR=1000)(CLOS(LL,K,M),K=2,KC,2)
          ENDDO
          DO LL=1,NCBW
            READ(1,*,ERR=1000)(NLOW(LL,K,M),K=2,KC,2)
            READ(1,*,ERR=1000)(CLOW(LL,K,M),K=2,KC,2)
          ENDDO
          DO LL=1,NCBE
            READ(1,*,ERR=1000)(NLOE(LL,K,M),K=2,KC,2)
            READ(1,*,ERR=1000)(CLOE(LL,K,M),K=2,KC,2)
          ENDDO
          DO LL=1,NCBN
            READ(1,*,ERR=1000)(NLON(LL,K,M),K=2,KC,2)
            READ(1,*,ERR=1000)(CLON(LL,K,M),K=2,KC,2)
          ENDDO
        ENDIF
      ENDDO
      DO M=1,5
        DO K=1,KS,2
          DO LL=1,NCBS
            NLOS(LL,K,M)=NLOS(LL,K+1,M)
            CLOS(LL,K,M)=CLOS(LL,K+1,M)
          ENDDO
          DO LL=1,NCBW
            NLOW(LL,K,M)=NLOW(LL,K+1,M)
            CLOW(LL,K,M)=CLOW(LL,K+1,M)
          ENDDO
          DO LL=1,NCBE
            NLOE(LL,K,M)=NLOE(LL,K+1,M)
            CLOE(LL,K,M)=CLOE(LL,K+1,M)
          ENDDO
          DO LL=1,NCBN
            NLON(LL,K,M)=NLON(LL,K+1,M)
            CLON(LL,K,M)=CLON(LL,K+1,M)
          ENDDO
        ENDDO
      ENDDO
      CLOSE(1)
      DO K=1,KC
        SAL(1,K)=0.
        TEM(1,K)=0.
        DYE(1,K)=0.
        SED(1,K,1)=0.
        SFL(1,K)=0.
        CWQ(1,K)=0.
        VHDX(1,K)=0.
        UHDY(1,K)=0.
        SAL1(1,K)=0.
        TEM1(1,K)=0.
        DYE1(1,K)=0.
        SED1(1,K,1)=0.
        SFL2(1,K)=0.
        CWQ2(1,K)=0.
        VHDX1(1,K)=0.
        UHDY1(1,K)=0.
        VHDXWQ(1,K)=0.
        UHDYWQ(1,K)=0.
        SAL(LC,K)=0.
        TEM(LC,K)=0.
        DYE(LC,K)=0.
        SED(LC,K,1)=0.
        SFL(LC,K)=0.
        CWQ(LC,K)=0.
        VHDX(LC,K)=0.
        UHDY(LC,K)=0.
        SAL1(LC,K)=0.
        TEM1(LC,K)=0.
        DYE1(LC,K)=0.
        SED1(LC,K,1)=0.
        SFL2(LC,K)=0.
        CWQ2(LC,K)=0.
        VHDX1(LC,K)=0.
        UHDY1(LC,K)=0.
        VHDXWQ(LC,K)=0.
        UHDYWQ(LC,K)=0.
      ENDDO
      DO L=2,LA
        LS=LSC(L)
        H1U(L)=0.5*(H1P(L)+H1P(LWEST(L)))
        H1V(L)=0.5*(H1P(L)+H1P(LS))
        P1(L)=G*(H1P(L)+BELV(L))
        HU(L)=0.5*(HP(L)+HP(LWEST(L)))
        HV(L)=0.5*(HP(L)+HP(LS))
        P(L)=G*(HP(L)+BELV(L))
        HPI(L)=1./HP(L)
        HUI(L)=1./HU(L)
        HVI(L)=1./HV(L)
        H1UI(L)=1./H1U(L)
        H1VI(L)=1./H1V(L)
      ENDDO
      DO K=1,KC
        DO L=2,LA
          UHDY1(L,K)=DYU(L)*H1U(L)*U1(L,K)
          VHDX1(L,K)=DXV(L)*H1V(L)*V1(L,K)
          UHDY(L,K)=DYU(L)*HU(L)*U(L,K)
          VHDX(L,K)=DXV(L)*HV(L)*V(L,K)
          SAL(L,K)=MAX(SAL(L,K),0.)
          SAL1(L,K)=MAX(SAL1(L,K),0.)
        ENDDO
      ENDDO
      N=0
      CALL CALQVS (2)
      DO K=1,KS
        RDZC=DZC(K)
        DO L=2,LA
          LN=LNC(L)
          W(L,K)=SWB(L)*(W(L,K-1)
     &        -RDZC*(UHDY(LEAST(L),K)-UHDY(L,K)-UHDYE(LEAST(L))+UHDYE(L)
     &        +VHDX(LN,K)-VHDX(L,K)-VHDXE(LN)+VHDXE(L))*DXYIP(L))
     &        +SWB(L)*( QSUM(L,K)-RDZC*QSUME(L) )*DXYIP(L)
          W1(L,K)=SWB(L)*(W1(L,K-1)
     &        -RDZC*(UHDY1(LEAST(L),K)-UHDY1(L,K)-UHDY1E(LEAST(L))+UHDY1E(L)
     &        +VHDX1(LN,K)-VHDX1(L,K)-VHDX1E(LN)+VHDX1E(L))*DXYIP(L))
     &        +SWB(L)*( QSUM(L,K)-RDZC*QSUME(L) )*DXYIP(L)
        ENDDO
      ENDDO
C
C **  WRITE READ ERRORS ON RESTART
C
      GOTO 1002
 1000 WRITE(6,1001)
 1001 FORMAT('  READ ERROR ON FILE RESTART.INP ')
      STOP
 1002 CONTINUE
  906 FORMAT(4E15.7)
  907 FORMAT(12E12.4)
  908 FORMAT(12I10)
      RETURN
      END

max_stars_repo_name: fearghalodonncha/DeepCurrent

max_issues_repo_name: fearghalodonncha/DeepCurrent

max_forks_repo_name: fearghalodonncha/DeepCurrent


text:
      PROGRAM FM710                                                     00010710
C                                                                       00020710
C     THIS ROUTINE TESTS SUBSCRIPT EXPRESSIONS AND          ANS REF.    00030710
C     CHARACTER SUBSTRINGS.                                 5.4.2, 5.4.300040710
C                                                           5.7.1, 5.7.200050710
C                                                                       00060710
C     THIS ROUTINE ASSUMES THE INTRINSIC FUNCTIONS                      00070710
C                              INT AND IABS ARE WORKING.                00080710
C                                                                       00090710
CBB** ********************** BBCCOMNT **********************************00100710
C****                                                                   00110710
C****            1978 FORTRAN COMPILER VALIDATION SYSTEM                00120710
C****                          VERSION 2.1                              00130710
C****                                                                   00140710
C****                                                                   00150710
C****           SUGGESTIONS AND COMMENTS SHOULD BE FORWARDED TO         00160710
C****          NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY           00170710
C****               SOFTWARE STANDARDS VALIDATION GROUP                 00180710
C****                      BUILDING 225  RM A266                        00190710
C****                     GAITHERSBURG, MD  20899                       00200710
C****                                                                   00210710
C****                                                                   00220710
C****                                                                   00230710
CBE** ********************** BBCCOMNT **********************************00240710
           IMPLICIT DOUBLE PRECISION (D), COMPLEX (Z), LOGICAL (L)      00250710
           IMPLICIT CHARACTER*27 (C)                                    00260710
CBB** ********************** BBCINITA **********************************00270710
C**** SPECIFICATION STATEMENTS                                          00280710
C****                                                                   00290710
      CHARACTER ZVERS*13, ZVERSD*17, ZDATE*17, ZPROG*5, ZCOMPL*20,      00300710
     1          ZNAME*20, ZTAPE*10, ZPROJ*13, REMRKS*31, ZTAPED*13      00310710
CBE** ********************** BBCINITA **********************************00320710
C                                                                       00330710
      DIMENSION I2N001(2,3), I2N002(3,5), I1N003(-1:8), I2N004(10,4)    00340710
      CHARACTER*10 CVCOMP, CVCORR, CVN001, C2N001(2,4)                  00350710
      DATA I2N001 /1,2,3,4,5,6/                                         00360710
      DATA I2N002 /11,21,31,12,22,32,13,23,33,14,24,34,15,25,35/        00370710
      DATA I1N003 /1,2,3,4,5,6,7,8,9,10/                                00380710
      DATA I2N004 / 10, 9, 8, 7, 6, 5, 4, 3, 2, 1,                      00390710
     1               4,-2, 6,-3, 8,-4,10,-5, 2,-1,                      00400710
     2               1, 3, 5, 7, 9, 2, 4, 6, 8, 10,                     00410710
     3             -10,-9,-8,-7,-6,-5,-4,-3,-2,-1 /                     00420710
      DATA C2N001 /'11FIRSTELE','21SECONDXX','12THIRDXYZ','22FOURTHWW', 00430710
     1             '13FIFTHABC','23SIXTHIJK','14SEVENTHH','24EIGHTHUV'/ 00440710
C                                                                       00450710
C                                                                       00460710
CBB** ********************** BBCINITB **********************************00470710
C**** INITIALIZE SECTION                                                00480710
      DATA  ZVERS,                  ZVERSD,             ZDATE           00490710
     1      /'VERSION 2.1  ',  '93/10/21*21.02.00',  '*NO DATE*TIME'/   00500710
      DATA       ZCOMPL,             ZNAME,             ZTAPE           00510710
     1      /'*NONE SPECIFIED*', '*NO COMPANY NAME*', '*NO TAPE*'/      00520710
      DATA       ZPROJ,           ZTAPED,         ZPROG                 00530710
     1      /'*NO PROJECT*',   '*NO TAPE DATE',  'XXXXX'/               00540710
      DATA   REMRKS /'                               '/                 00550710
C**** THE FOLLOWING 9 COMMENT LINES (CZ01, CZ02, ...) CAN BE REPLACED   00560710
C**** FOR IDENTIFYING THE TEST ENVIRONMENT                              00570710
C****                                                                   00580710
CZ01  ZVERS  = 'VERSION OF THE COMPILER VALIDATION SYSTEM'              00590710
CZ02  ZVERSD = 'CREATION DATE/TIME OF THE COMPILER VALIDATION SYSTEM'   00600710
CZ03  ZPROG  = 'PROGRAM NAME'                                           00610710
CZ04  ZDATE  = 'DATE OF TEST'                                           00620710
CZ05  ZCOMPL = 'COMPILER IDENTIFICATION'                                00630710
CZ06  ZPROJ  = 'PROJECT NUMBER/IDENTIFICATION'                          00640710
CZ07  ZNAME  = 'NAME OF USER'                                           00650710
CZ08  ZTAPE  = 'TAPE OWNER/ID'                                          00660710
CZ09  ZTAPED = 'DATE TAPE COPIED'                                       00670710
C                                                                       00680710
      IVPASS = 0                                                        00690710
      IVFAIL = 0                                                        00700710
      IVDELE = 0                                                        00710710
      IVINSP = 0                                                        00720710
      IVTOTL = 0                                                        00730710
      IVTOTN = 0                                                        00740710
      ICZERO = 0                                                        00750710
C                                                                       00760710
C     I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER.         00770710
      I01 = 05                                                          00780710
C     I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER.             00790710
      I02 = 06                                                          00800710
C                                                                       00810710
CX010   REPLACED BY FEXEC X-010 CONTROL CARD (CARD-READER UNIT NUMBER). 00820710
C     THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5      00830710
CX011   REPLACED BY FEXEC X-011 CONTROL CARD.  CX011 IS FOR SYSTEMS     00840710
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX010.  00850710
C                                                                       00860710
CX020   REPLACED BY FEXEC X-020 CONTROL CARD (PRINTER UNIT NUMBER).     00870710
C     THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02= 6       00880710
CX021   REPLACED BY FEXEC X-021 CONTROL CARD.  CX021 IS FOR SYSTEMS     00890710
C     REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX020.  00900710
C                                                                       00910710
CBE** ********************** BBCINITB **********************************00920710
           ZPROG='FM710'                                                00930710
           IVTOTL =  19                                                 00940710
CBB** ********************** BBCHED0A **********************************00950710
C****                                                                   00960710
C**** WRITE REPORT TITLE                                                00970710
C****                                                                   00980710
      WRITE (I02, 90002)                                                00990710
      WRITE (I02, 90006)                                                01000710
      WRITE (I02, 90007)                                                01010710
      WRITE (I02, 90008)  ZVERS, ZVERSD                                 01020710
      WRITE (I02, 90009)  ZPROG, ZPROG                                  01030710
      WRITE (I02, 90010)  ZDATE, ZCOMPL                                 01040710
CBE** ********************** BBCHED0A **********************************01050710
CBB** ********************** BBCHED0B **********************************01060710
C**** WRITE DETAIL REPORT HEADERS                                       01070710
C****                                                                   01080710
      WRITE (I02,90004)                                                 01090710
      WRITE (I02,90004)                                                 01100710
      WRITE (I02,90013)                                                 01110710
      WRITE (I02,90014)                                                 01120710
      WRITE (I02,90015) IVTOTL                                          01130710
CBE** ********************** BBCHED0B **********************************01140710
C                                                                       01150710
C     TESTS 1-2 - SUBSCRIPT EXPRESSION TO IDENTIFY VARIOUS              01160710
C                 ARRAY ELEMENTS                                        01170710
C                                                                       01180710
C                                                                       01190710
CT001*  TEST 001   ****  FCVS PROGRAM 710  ****                         01200710
C                                                                       01210710
C     TEST 001 ARRAY ELEMENT REFERENCE                                  01220710
C                                                                       01230710
           IVTNUM =   1                                                 01240710
           IVCOMP = 0                                                   01250710
           IVCORR = 34                                                  01260710
      IVCOMP = I2N002(I2N001(1,2),I2N001(2,3)/2 + 1)                    01270710
40010      IF (IVCOMP - 34) 20010, 10010, 20010                         01280710
10010      IVPASS = IVPASS + 1                                          01290710
           WRITE (I02,80002) IVTNUM                                     01300710
           GO TO 0011                                                   01310710
20010      IVFAIL = IVFAIL + 1                                          01320710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     01330710
 0011      CONTINUE                                                     01340710
C                                                                       01350710
CT002*  TEST 002   ****  FCVS PROGRAM 710  ****                         01360710
C                                                                       01370710
C     TEST 002 FUNCTION REFERENCE                                       01380710
C                                                                       01390710
           IVTNUM =   2                                                 01400710
           RVD001 = 2.64                                                01410710
           IVCOMP = 0                                                   01420710
           IVCORR = 25                                                  01430710
      IVCOMP = I2N002(INT(RVD001), 19 - IABS(-7)*2)                     01440710
40020      IF (IVCOMP - 25) 20020, 10020, 20020                         01450710
10020      IVPASS = IVPASS + 1                                          01460710
           WRITE (I02,80002) IVTNUM                                     01470710
           GO TO 0021                                                   01480710
20020      IVFAIL = IVFAIL + 1                                          01490710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     01500710
 0021      CONTINUE                                                     01510710
C                                                                       01520710
C     TESTS 3-7 - TEST SUBSCRIPT VALUE IN IDENTIFYING                   01530710
C                 ARRAY ELEMENTS                                        01540710
C                                                                       01550710
CT003*  TEST 003   ****  FCVS PROGRAM 710  ****                         01560710
C                                                                       01570710
C     TEST 003 RANGE                                                    01580710
C                                                                       01590710
           IVTNUM = 3                                                   01600710
           WRITE (I02, 80004) IVTNUM                                    01610710
           WRITE (I02, 80020)                                           01620710
      WRITE (I02, 70030) (I1N003(IVN001), IVN001=5,8)                   01630710
70030 FORMAT (" ",26X,4I4)                                              01640710
           IVINSP = IVINSP + 1                                          01650710
           WRITE (I02, 80022)                                           01660710
           WRITE (I02, 70031)                                           01670710
70031      FORMAT (" ",26X,"   7   8   9  10" )                         01680710
C                                                                       01690710
CT004*  TEST 004   ****  FCVS PROGRAM 710  ****                         01700710
C                                                                       01710710
C     TEST 004 SINGLE ELEMENT                                           01720710
C                                                                       01730710
           IVTNUM =   4                                                 01740710
           IVCOMP = 0                                                   01750710
           IVCORR = 4                                                   01760710
      IVCOMP = I1N003(2)                                                01770710
40040      IF (IVCOMP - 4) 20040, 10040, 20040                          01780710
10040      IVPASS = IVPASS + 1                                          01790710
           WRITE (I02,80002) IVTNUM                                     01800710
           GO TO 0041                                                   01810710
20040      IVFAIL = IVFAIL + 1                                          01820710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     01830710
 0041      CONTINUE                                                     01840710
C                                                                       01850710
CT005*  TEST 005   ****  FCVS PROGRAM 710  ****                         01860710
C                                                                       01870710
C     TEST 005 EXPRESSION                                               01880710
C                                                                       01890710
           IVTNUM =   5                                                 01900710
           IVN001 = -3                                                  01910710
           IVCOMP = 0                                                   01920710
           IVCORR = 1                                                   01930710
      IVCOMP = I1N003((IVN001+5)*3 - 7)                                 01940710
40050      IF (IVCOMP - 1) 20050, 10050, 20050                          01950710
10050      IVPASS = IVPASS + 1                                          01960710
           WRITE (I02,80002) IVTNUM                                     01970710
           GO TO 0051                                                   01980710
20050      IVFAIL = IVFAIL + 1                                          01990710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     02000710
 0051      CONTINUE                                                     02010710
C                                                                       02020710
CT006*  TEST 006   ****  FCVS PROGRAM 710  ****                         02030710
C                                                                       02040710
C     TEST 006 31ST ELEMENT IN 2 DIMENSIONAL, 40 ELEMENT ARRAY          02050710
C                                                                       02060710
           IVTNUM =   6                                                 02070710
           IVCOMP = 0                                                   02080710
           IVCORR = -10                                                 02090710
      IVCOMP = I2N004(1,4)                                              02100710
40060      IF (IVCOMP + 10) 20060, 10060, 20060                         02110710
10060      IVPASS = IVPASS + 1                                          02120710
           WRITE (I02,80002) IVTNUM                                     02130710
           GO TO 0061                                                   02140710
20060      IVFAIL = IVFAIL + 1                                          02150710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     02160710
 0061      CONTINUE                                                     02170710
C                                                                       02180710
CT007*  TEST 007   ****  FCVS PROGRAM 710  ****                         02190710
C                                                                       02200710
C     TEST 007 4TH ELEMENT OF FIRST ARRAY EQUAL TO                      02210710
C              11TH ELEMENT OF SECOND ARRAY                             02220710
C                                                                       02230710
           IVTNUM =   7                                                 02240710
           IVCOMP = 0                                                   02250710
           IVCORR = 1                                                   02260710
           IF (I1N003(2).EQ.I2N004(1,2)) IVCOMP = 1                     02270710
40070      IF (IVCOMP - 1) 20070, 10070, 20070                          02280710
10070      IVPASS = IVPASS + 1                                          02290710
           WRITE (I02,80002) IVTNUM                                     02300710
           GO TO 0071                                                   02310710
20070      IVFAIL = IVFAIL + 1                                          02320710
           WRITE (I02,80010) IVTNUM, IVCOMP, IVCORR                     02330710
 0071      CONTINUE                                                     02340710
C                                                                       02350710
C     TESTS 8-15 - CHARACTER SUBSTRING NAME                             02360710
C                                                                       02370710
C                                                                       02380710
CT008*  TEST 008   ****  FCVS PROGRAM 710  ****                         02390710
C                                                                       02400710
C     TEST 008 USING LEFT AND RIGHT POSITION OF SUBSTRING               02410710
C                                                                       02420710
           IVTNUM =   8                                                 02430710
           CVCOMP = ' '                                                 02440710
           IVCOMP = 0                                                   02450710
           CVN001 = 'THIS IS IT'                                        02460710
           CVCORR = 'HIS       '                                        02470710
      CVCOMP = CVN001(2:4)                                              02480710
           IF (CVCOMP .EQ. 'HIS       ') IVCOMP = 1                     02490710
           IF (IVCOMP - 1) 20080, 10080, 20080                          02500710
10080      IVPASS = IVPASS + 1                                          02510710
           WRITE (I02,80002) IVTNUM                                     02520710
           GO TO 0081                                                   02530710
20080      IVFAIL = IVFAIL + 1                                          02540710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     02550710
 0081      CONTINUE                                                     02560710
C                                                                       02570710
CT009*  TEST 009   ****  FCVS PROGRAM 710  ****                         02580710
C                                                                       02590710
C     TEST 009 LEFT POSITION OMITTED, VALUE OF 1 ASSUMED                02600710
C                                                                       02610710
           IVTNUM =   9                                                 02620710
           CVCOMP = ' '                                                 02630710
           IVCOMP = 0                                                   02640710
           CVCORR = 'THIS      '                                        02650710
      CVCOMP = CVN001(:4)                                               02660710
           IF (CVCOMP .EQ. 'THIS      ') IVCOMP = 1                     02670710
           IF (IVCOMP - 1) 20090, 10090, 20090                          02680710
10090      IVPASS = IVPASS + 1                                          02690710
           WRITE (I02,80002) IVTNUM                                     02700710
           GO TO 0091                                                   02710710
20090      IVFAIL = IVFAIL + 1                                          02720710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     02730710
 0091      CONTINUE                                                     02740710
C                                                                       02750710
CT010*  TEST 010   ****  FCVS PROGRAM 710  ****                         02760710
C                                                                       02770710
C     TEST 010 RIGHT POSITION OMITTED, RIGHT-HAND END OF STRING ASSUMED 02780710
C                                                                       02790710
           IVTNUM =  10                                                 02800710
           CVCOMP = ' '                                                 02810710
           IVCOMP = 0                                                   02820710
           CVCORR = 'S IS IT   '                                        02830710
      CVCOMP = CVN001(4:)                                               02840710
           IF (CVCOMP .EQ. 'S IS IT   ') IVCOMP = 1                     02850710
           IF (IVCOMP - 1) 20100, 10100, 20100                          02860710
10100      IVPASS = IVPASS + 1                                          02870710
           WRITE (I02,80002) IVTNUM                                     02880710
           GO TO 0101                                                   02890710
20100      IVFAIL = IVFAIL + 1                                          02900710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     02910710
 0101      CONTINUE                                                     02920710
C                                                                       02930710
CT011*  TEST 011   ****  FCVS PROGRAM 710  ****                         02940710
C                                                                       02950710
C     TEST 011 EXTRACT SUBSTRING FROM ARRAY                             02960710
C                                                                       02970710
           IVTNUM =  11                                                 02980710
           CVCOMP = ' '                                                 02990710
           IVCOMP = 0                                                   03000710
           CVCORR = '12THIR    '                                        03010710
      CVCOMP = C2N001(1,2)(1:6)                                         03020710
           IF (CVCOMP .EQ. '12THIR    ') IVCOMP = 1                     03030710
           IF (IVCOMP - 1) 20110, 10110, 20110                          03040710
10110      IVPASS = IVPASS + 1                                          03050710
           WRITE (I02,80002) IVTNUM                                     03060710
           GO TO 0111                                                   03070710
20110      IVFAIL = IVFAIL + 1                                          03080710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     03090710
 0111      CONTINUE                                                     03100710
C                                                                       03110710
CT012*  TEST 012   ****  FCVS PROGRAM 710  ****                         03120710
C                                                                       03130710
C     TEST 012 ENTIRE SUBSTRING                                         03140710
C                                                                       03150710
           IVTNUM =  12                                                 03160710
           CVCOMP = ' '                                                 03170710
           IVCOMP = 0                                                   03180710
           CVCORR = 'THIS IS IT'                                        03190710
      CVCOMP = CVN001(:)                                                03200710
           IF (CVCOMP .EQ. 'THIS IS IT') IVCOMP = 1                     03210710
           IF (IVCOMP - 1) 20120, 10120, 20120                          03220710
10120      IVPASS = IVPASS + 1                                          03230710
           WRITE (I02,80002) IVTNUM                                     03240710
           GO TO 0121                                                   03250710
20120      IVFAIL = IVFAIL + 1                                          03260710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     03270710
 0121      CONTINUE                                                     03280710
C                                                                       03290710
CT013*  TEST 013   ****  FCVS PROGRAM 710  ****                         03300710
C                                                                       03310710
C     TEST 013 ENTIRE SUBSTRING FROM ARRAY                              03320710
C                                                                       03330710
           IVTNUM =  13                                                 03340710
           CVCOMP = ' '                                                 03350710
           IVCOMP = 0                                                   03360710
           CVCORR = '23SIXTHIJK'                                        03370710
      CVCOMP = C2N001(2,3)(:)                                           03380710
           IF (CVCOMP .EQ. '23SIXTHIJK') IVCOMP = 1                     03390710
           IF (IVCOMP - 1) 20130, 10130, 20130                          03400710
10130      IVPASS = IVPASS + 1                                          03410710
           WRITE (I02,80002) IVTNUM                                     03420710
           GO TO 0131                                                   03430710
20130      IVFAIL = IVFAIL + 1                                          03440710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     03450710
 0131      CONTINUE                                                     03460710
C                                                                       03470710
CT014*  TEST 014   ****  FCVS PROGRAM 710  ****                         03480710
C                                                                       03490710
C     RIGHT POSITION OMITTED USING ARRAY                                03500710
C                                                                       03510710
           IVTNUM =  14                                                 03520710
           CVCOMP = ' '                                                 03530710
           IVCOMP = 0                                                   03540710
           CVCORR = 'EVENTHH   '                                        03550710
      CVCOMP = C2N001(1,4)(4:)                                          03560710
           IF (CVCOMP .EQ. 'EVENTHH   ') IVCOMP = 1                     03570710
           IF (IVCOMP - 1) 20140, 10140, 20140                          03580710
10140      IVPASS = IVPASS + 1                                          03590710
           WRITE (I02,80002) IVTNUM                                     03600710
           GO TO 0141                                                   03610710
20140      IVFAIL = IVFAIL + 1                                          03620710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     03630710
 0141      CONTINUE                                                     03640710
C                                                                       03650710
CT015*  TEST 015   ****  FCVS PROGRAM 710  ****                         03660710
C                                                                       03670710
C     LEFT POSITION OMITTED                                             03680710
C                                                                       03690710
           IVTNUM =  15                                                 03700710
           CVCOMP = ' '                                                 03710710
           IVCOMP = 0                                                   03720710
           CVCORR = '24EI      '                                        03730710
      CVCOMP = C2N001(2,4)(:4)                                          03740710
           IF (CVCOMP .EQ. '24EI      ') IVCOMP = 1                     03750710
           IF (IVCOMP - 1) 20150, 10150, 20150                          03760710
10150      IVPASS = IVPASS + 1                                          03770710
           WRITE (I02,80002) IVTNUM                                     03780710
           GO TO 0151                                                   03790710
20150      IVFAIL = IVFAIL + 1                                          03800710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     03810710
 0151      CONTINUE                                                     03820710
C                                                                       03830710
C     TESTS 16-19 - SUBSTRING EXPRESSION                                03840710
C                                                                       03850710
C                                                                       03860710
CT016*  TEST 016   ****  FCVS PROGRAM 710  ****                         03870710
C                                                                       03880710
C     TEST 016 ARITHMETIC EXPRESSION                                    03890710
C                                                                       03900710
           IVTNUM =  16                                                 03910710
           CVCOMP = ' '                                                 03920710
           IVCOMP = 0                                                   03930710
           CVCORR = 'HIS IS IT '                                        03940710
      CVCOMP = CVN001(2:5*2)                                            03950710
           IF (CVCOMP .EQ. 'HIS IS IT ') IVCOMP = 1                     03960710
           IF (IVCOMP - 1) 20160, 10160, 20160                          03970710
10160      IVPASS = IVPASS + 1                                          03980710
           WRITE (I02,80002) IVTNUM                                     03990710
           GO TO 0161                                                   04000710
20160      IVFAIL = IVFAIL + 1                                          04010710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     04020710
 0161      CONTINUE                                                     04030710
C                                                                       04040710
CT017*  TEST 017   ****  FCVS PROGRAM 710  ****                         04050710
C                                                                       04060710
C     TEST 017 SUBSTRING EXPRESSION IN AN ASSIGNMENT STATEMENT          04070710
C                                                                       04080710
           IVTNUM =  17                                                 04090710
           IVN001 = 5                                                   04100710
           IVN002 = 8                                                   04110710
           CVCOMP = ' '                                                 04120710
           IVCOMP = 0                                                   04130710
           CVCORR = 'THISLIKEIT'                                        04140710
      CVN001(IVN001:IVN002) = 'LIKE'                                    04150710
           CVCOMP = CVN001                                              04160710
           IF (CVCOMP .EQ. 'THISLIKEIT') IVCOMP = 1                     04170710
           IF (IVCOMP - 1) 20170, 10170, 20170                          04180710
10170      IVPASS = IVPASS + 1                                          04190710
           WRITE (I02,80002) IVTNUM                                     04200710
           GO TO 0171                                                   04210710
20170      IVFAIL = IVFAIL + 1                                          04220710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     04230710
 0171      CONTINUE                                                     04240710
C                                                                       04250710
CT018*  TEST 018   ****  FCVS PROGRAM 710  ****                         04260710
C                                                                       04270710
C     TEST 018 SUBSTRING EXPRESSION CONTAINING ARRAY ELEMENT REFERENCE  04280710
C                                                                       04290710
           IVTNUM =  18                                                 04300710
           CVCOMP = ' '                                                 04310710
           IVCOMP = 0                                                   04320710
           CVCORR = 'HISLIKE   '                                        04330710
      CVCOMP = CVN001(I2N001(2,1):I2N002(3,5)-27)                       04340710
           IF (CVCOMP .EQ. 'HISLIKE   ') IVCOMP = 1                     04350710
           IF (IVCOMP - 1) 20180, 10180, 20180                          04360710
10180      IVPASS = IVPASS + 1                                          04370710
           WRITE (I02,80002) IVTNUM                                     04380710
           GO TO 0181                                                   04390710
20180      IVFAIL = IVFAIL + 1                                          04400710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     04410710
 0181      CONTINUE                                                     04420710
C                                                                       04430710
CT019*  TEST 019   ****  FCVS PROGRAM 710  ****                         04440710
C                                                                       04450710
C     TEST 019 SUBSTRING EXPRESSION CONTAINING FUNCTION REFERENCES      04460710
C                                                                       04470710
           IVTNUM =  19                                                 04480710
           RVD001 = 1.475                                               04490710
           IVN001 = 1                                                   04500710
           CVCOMP = ' '                                                 04510710
           IVCOMP = 0                                                   04520710
           CVCORR = 'IFTHABC   '                                        04530710
      CVCOMP = C2N001(1,3)(INT(RVD001)+3 : (IVN001*5 + 7)/IABS(-6) + 8) 04540710
           IF (CVCOMP .EQ. 'IFTHABC   ') IVCOMP = 1                     04550710
           IF (IVCOMP - 1) 20190, 10190, 20190                          04560710
10190      IVPASS = IVPASS + 1                                          04570710
           WRITE (I02,80002) IVTNUM                                     04580710
           GO TO 0191                                                   04590710
20190      IVFAIL = IVFAIL + 1                                          04600710
           WRITE (I02,80018) IVTNUM, CVCOMP, CVCORR                     04610710
 0191      CONTINUE                                                     04620710
C                                                                       04630710
CBB** ********************** BBCSUM0  **********************************04640710
C**** WRITE OUT TEST SUMMARY                                            04650710
C****                                                                   04660710
      IVTOTN = IVPASS + IVFAIL + IVDELE + IVINSP                        04670710
      WRITE (I02, 90004)                                                04680710
      WRITE (I02, 90014)                                                04690710
      WRITE (I02, 90004)                                                04700710
      WRITE (I02, 90020) IVPASS                                         04710710
      WRITE (I02, 90022) IVFAIL                                         04720710
      WRITE (I02, 90024) IVDELE                                         04730710
      WRITE (I02, 90026) IVINSP                                         04740710
      WRITE (I02, 90028) IVTOTN, IVTOTL                                 04750710
CBE** ********************** BBCSUM0  **********************************04760710
CBB** ********************** BBCFOOT0 **********************************04770710
C**** WRITE OUT REPORT FOOTINGS                                         04780710
C****                                                                   04790710
      WRITE (I02,90016) ZPROG, ZPROG                                    04800710
      WRITE (I02,90018) ZPROJ, ZNAME, ZTAPE, ZTAPED                     04810710
      WRITE (I02,90019)                                                 04820710
CBE** ********************** BBCFOOT0 **********************************04830710
90001 FORMAT (" ",56X,"FM710")                                          04840710
90000 FORMAT (" ",50X,"END OF PROGRAM FM710" )                          04850710
CBB** ********************** BBCFMT0A **********************************04860710
C**** FORMATS FOR TEST DETAIL LINES                                     04870710
C****                                                                   04880710
80000 FORMAT (" ",2X,I3,4X,"DELETED",32X,A31)                           04890710
80002 FORMAT (" ",2X,I3,4X," PASS  ",32X,A31)                           04900710
80004 FORMAT (" ",2X,I3,4X,"INSPECT",32X,A31)                           04910710
80008 FORMAT (" ",2X,I3,4X," FAIL  ",32X,A31)                           04920710
80010 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",15X,"COMPUTED= " ,           04930710
     1I6,/," ",15X,"CORRECT=  " ,I6)                                    04940710
80012 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           04950710
     1E12.5,/," ",16X,"CORRECT=  " ,E12.5)                              04960710
80018 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           04970710
     1A21,/," ",16X,"CORRECT=  " ,A21)                                  04980710
80020 FORMAT (" ",16X,"COMPUTED= " ,A21,1X,A31)                         04990710
80022 FORMAT (" ",16X,"CORRECT=  " ,A21,1X,A31)                         05000710
80024 FORMAT (" ",16X,"COMPUTED= " ,I6,16X,A31)                         05010710
80026 FORMAT (" ",16X,"CORRECT=  " ,I6,16X,A31)                         05020710
80028 FORMAT (" ",16X,"COMPUTED= " ,E12.5,10X,A31)                      05030710
80030 FORMAT (" ",16X,"CORRECT=  " ,E12.5,10X,A31)                      05040710
80050 FORMAT (" ",48X,A31)                                              05050710
CBE** ********************** BBCFMT0A **********************************05060710
CBB** ********************** BBCFMAT1 **********************************05070710
C**** FORMATS FOR TEST DETAIL LINES - FULL LANGUAGE                     05080710
C****                                                                   05090710
80031 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05100710
     1D17.10,/," ",16X,"CORRECT=  " ,D17.10)                            05110710
80033 FORMAT (" ",16X,"COMPUTED= " ,D17.10,10X,A31)                     05120710
80035 FORMAT (" ",16X,"CORRECT=  " ,D17.10,10X,A31)                     05130710
80037 FORMAT (" ",16X,"COMPUTED= " ,"(",E12.5,", ",E12.5,")",6X,A31)    05140710
80039 FORMAT (" ",16X,"CORRECT=  " ,"(",E12.5,", ",E12.5,")",6X,A31)    05150710
80041 FORMAT (" ",16X,"COMPUTED= " ,"(",F12.5,", ",F12.5,")",6X,A31)    05160710
80043 FORMAT (" ",16X,"CORRECT=  " ,"(",F12.5,", ",F12.5,")",6X,A31)    05170710
80045 FORMAT (" ",2X,I3,4X," FAIL  ",/," ",16X,"COMPUTED= " ,           05180710
     1"(",F12.5,", ",F12.5,")"/," ",16X,"CORRECT=  " ,                  05190710
     2"(",F12.5,", ",F12.5,")")                                         05200710
CBE** ********************** BBCFMAT1 **********************************05210710
CBB** ********************** BBCFMT0B **********************************05220710
C**** FORMAT STATEMENTS FOR PAGE HEADERS                                05230710
C****                                                                   05240710
90002 FORMAT ("1")                                                      05250710
90004 FORMAT (" ")                                                      05260710
90006 FORMAT (" ",20X,"NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY" )05270710
90007 FORMAT (" ",19X,"FORTRAN COMPILER VALIDATION SYSTEM" )            05280710
90008 FORMAT (" ",21X,A13,A17)                                          05290710
90009 FORMAT (" ",/," *",A5,"BEGIN*",12X,"TEST RESULTS - " ,A5,/)       05300710
90010 FORMAT (" ",8X,"TEST DATE*TIME= " ,A17,"  -  COMPILER= " ,A20)    05310710
90013 FORMAT (" "," TEST   ","PASS/FAIL " ,6X,"DISPLAYED RESULTS" ,     05320710
     1       7X,"REMARKS",24X)                                          05330710
90014 FORMAT (" ","----------------------------------------------" ,    05340710
     1        "---------------------------------" )                     05350710
90015 FORMAT (" ",48X,"THIS PROGRAM HAS " ,I3," TESTS",/)               05360710
C****                                                                   05370710
C**** FORMAT STATEMENTS FOR REPORT FOOTINGS                             05380710
C****                                                                   05390710
90016 FORMAT (" ",/," *",A5,"END*",14X,"END OF TEST - " ,A5,/)          05400710
90018 FORMAT (" ",A13,13X,A20,"   *   ",A10,"/",                        05410710
     1        A13)                                                      05420710
90019 FORMAT (" ","FOR OFFICIAL USE ONLY     " ,35X,"COPYRIGHT  1982" ) 05430710
C****                                                                   05440710
C**** FORMAT STATEMENTS FOR RUN SUMMARY                                 05450710
C****                                                                   05460710
90020 FORMAT (" ",21X,I5," TESTS PASSED" )                              05470710
90022 FORMAT (" ",21X,I5," TESTS FAILED" )                              05480710
90024 FORMAT (" ",21X,I5," TESTS DELETED" )                             05490710
90026 FORMAT (" ",21X,I5," TESTS REQUIRE INSPECTION" )                  05500710
90028 FORMAT (" ",21X,I5," OF ",I3," TESTS EXECUTED" )                  05510710
CBE** ********************** BBCFMT0B **********************************05520710
           END                                                          05530710

max_stars_repo_name: MrSidims/llvm-test-suite

max_issues_repo_name: MrSidims/llvm-test-suite

max_forks_repo_name: MrSidims/llvm-test-suite


text:
decrement/stimulus.cpp
decrement/display.cpp
decrement/decrement.cpp
decrement/main.cpp


text:
! Demo of a Fortran function. Intent(in) arguments
! cannot be changed. Function arguments should be intent(in).
! Pure means the function has no side-effects.

program func
implicit none
print*,area(3.,4.) ! 12
contains
real pure function area(length,width)
real, intent(in) :: length,width
area = length*width
end function area
end program func

max_stars_repo_name: awvwgk/FortranTip

max_issues_repo_name: awvwgk/FortranTip

max_forks_repo_name: awvwgk/FortranTip


text:
      subroutine  diskwrite
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 To write information from disk file for restart purposes.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.22
!D2 Initial implementation: 15-JAN-04,  Programmer: Z. Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/diskwrite.f_a  $
!D2
!***********************************************************************
!D3
!D3  REQUIREMENTS TRACEABILITY
!D3
!D3 2.6 Provide Input/Output Data Files
!D3 3.0 INPUT AND OUTPUT REQUIREMENTS
!D3 2.7 Provide Restart Capability
!D3
!***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************
!D6
!D6 GLOBAL OBJECTS
!D6
!D6 Global Constants
!D6
!D6   None
!D6
!D6 Global Types
!D6
!D6   None
!D6
!D6 Global Variables
!D6
!D6 isave, jdate, jtime, nmfil, verno, wdd, days, ico2, iccen, istrs,
!D6 idpdp, idualp, to, s, pho, pcio, iread, wdd1, neq, t, phi, pci,
!D6 ieos, so
!D6
!D6 Global Subprograms
!D6
!D6 Identifier    Type     Description
!D6
!D6 dated         N/A      Determines current date and time
!D6 concen        N/A      Called to read or write concentration data
!D6 stress        N/A      Called to read or write stress data
!D6
!***********************************************************************
!D7
!D7 LOCAL IDENTIFIERS
!D7
!D7 Local Constants
!D7
!D7   None
!D7
!D7 Local Types
!D7
!D7 Local variables
!D7
!D7   Identifier      Type     Description
!D7
!D7   mi              INT      Index for writing array values
!D7   ncount          INT      Index for writing array values
!D7   nc              INT      Number of node sets in current run
!D7   nc1             INT      Index used for setting initial values
!D7   nc2             INT      Index used for setting initial values
!D7   nc3             INT      Index used for setting initial values
!D7   nd1             INT      Index used for setting initial values
!D7   nd2             INT      Index used for setting initial values
!D7   nd3             INT      Index used for setting initial values
!D7   j               INT      Do loop index
!D7   nx              INT      Index used for setting initial values
!D7   ny              INT      Index used for setting initial values
!D7   ny              INT      Index used for setting initial values
!D7   ii              INT      Do loop index
!D7   i               INT      Index used for setting initial values
!D7
!D7 Local Subprograms
!D7
!D7   None
!D7
!***********************************************************************
!PS
!PS PSEUDOCODE
!PS
!PS BEGIN diskwrite
!PS
!PS   IF the run specifies a restart file to be written
!PS     Rewind tape
!PS     Write FEHM version number and current date and time
!PS     Write time of simulation
!PS     Write flags to identify options used in this run
!PS
!PS     IF this is a noncondensible gas run with heat
!PS       Write temperature, saturation, total pressure, and ...
!PS       ... gas pressure values
!PS     ELSEIF this is a water/water vapor run with heat
!PS       Write temperature, saturation, total pressure, pressure values
!PS     ELSEIF this is an isothermal air/water run
!PS       Write saturation and pressure values
!PS     ENDIF
!PS
!PS     concen - write concentration values to the file
!PS     stress - write stress information to the file
!PS
!PS   ENDIF
!PS
!PS END diskwrite
!PS
!***********************************************************************

      use comai
      use combi
      use comco2
      use comdi
      use comdti
      use comfi
      use comflow
      use comii
      use commeth
      use compart
      use comriv
      use comxi
      use davidi
      implicit none

      real*8 dummyreal,tolw,sat_dum
      character*11 file_format
      parameter(tolw=1.d-99,sat_dum= 1.d00)
      integer jx,mi,ncount,nc,nc1,nc2,nc3,nd1,nd2,nd3,j,nx,ny,ii,i
      logical log_flag

      if (header_flag .eq. 'new' .and. iriver .eq. 0) then
c Force old style output if wellbore macro is invoked for now
         call diskwrite_new
         return
      else
c Look at rstw array to determine if initial pressures and temperatures
c should be output. All original variables will be output for 'old'
         if (iriver .ne. 0) then
            header_flag = 'old'
            write (ierr, 10)
            if (iout .ne. 0) write(iout, 10)
            if (iptty .ne. 0) write(iptty, 10)
         end if
         if (.not. allocated(rstw)) rstw_num = 0
         do i = 1, rstw_num
            if (rstw(i) .eq. 'pini') then
               ipini = 1
               exit
            end if
         end do
      end if
 10   format (/, 'WARNING: New format restart output not supported for ',
     &     'models using well / river macro', /)

      call dated (jdate,jtime)
      inquire (isave, opened = ex)
      if (ex) close (isave)
      open (isave,file=nmfil(7),status=cstats(7),form=cform(7))

      rewind  isave
      if(ice.ne.0) then
         write(isave, 6000)  verno, jdate, jtime, wdd
         write(isave ,*)  days
         call icectr (-20,0)
         return
      endif

cc
c if necessary, correct for head increment before saving
c only converted here for 'write' density not denfined on
c read portion
c correction now defined only once in input 16-Aug-06
c
c      if(ihead.ne.0.and.head0.gt.0) then
c         phi_inc = head0*crl(1,1)*(-grav)
c      endif

! For compatibility with previous versions
! Liquid fluxes should be written to restart file
      if (abs(prnt_rst) .eq. 2) flux_flag = 'liquid flux'

! Determine size of flux arrays
      if (numflux .ne. 0. .and. .not. compute_flow) then
! Use value of numflux that was read in
      else if (idpdp .ne. 0) then
         numflux = 2*ldna + neq
      else
         numflux = ldna
      end if

      if (cform(7) .eq. 'formatted') then
c Formatted output
         write(isave, 6000)  verno, jdate, jtime, wdd
 6000    format(a30, 3x, a11, 3x, a8, /, a80)
         write(isave ,*)  days
c     write descriptors
         if (iriver .ne. 0) then
            if (icarb .eq. 1) then
                write(isave,'(a4)') 'wcar'
            else
               if (ico2.gt.0) write(isave,'(a4)') 'wnga'
               if (ico2.lt.0) write(isave,'(a4)') 'wair'
               if (ico2.eq.0) write(isave,'(a4)') 'wh20'
            end if
         else
            if (icarb .eq. 1) then
               write(isave,'(a4)') 'carb'
            else
               if (ico2.gt.0) write(isave,'(a4)') 'ngas'
               if (ico2.lt.0) write(isave,'(a4)') 'air '
               if (ico2.eq.0) write(isave,'(a4)') 'h20 '
            end if
         end if
         if ((iccen.eq.0).and..not.ptrak) write(isave,'(a4)') 'ntra'
         if (iccen.ne.0) write(isave,'(a4)') 'trac'
         if (ptrak) write(isave,'(a4)') 'ptrk'
         if (istrs.eq.0) write(isave,'(a4)') 'nstr'
         if (istrs.ne.0) write(isave,'(a4)') 'strs'
         if (idpdp.eq.0) write(isave,'(a4)') 'ndpd'
         if (idpdp.ne.0) write(isave,'(a4)') 'dpdp'
         if (idualp.eq.0) write(isave,'(a4)') 'ndua'
         if (idualp.ne.0) write(isave,'(a4)') 'dual'
         if (ico2.gt.0) then
            write(isave ,6002)  (max(to(mi),tolw),   mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave ,6002)  (max(s(mi),tolw),    mi=1,n )
            else
               write(isave ,6002)  (sat_dum,    mi=1,n )
            endif
            write(isave ,6002)  (max(pho(mi),tolw),  mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave ,6002)  (max(pcio(mi),tolw), mi=1,n )
            else
               write(isave ,6002)  (max(pho(mi),tolw),  mi=1,n )
            endif
         else if(ico2.eq.0 .or. icarb .eq. 1) then
            write(isave ,6002)  (max(to(mi),tolw),   mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave ,6002)  (max(s(mi),tolw),    mi=1,n )
            else
               write(isave ,6002)  (sat_dum,    mi=1,n )
            endif
            write(isave ,6002)  (max(pho(mi),tolw),  mi=1,n )
            if (icarb .eq. 1) then
               write(isave ,6002)  (max(toco2(mi),tolw),   mi=1,n )
               write(isave ,6002)  (max(phoco2(mi),tolw),  mi=1,n )
               write(isave ,6002)  (max(fow(mi),tolw),    mi=1,n )
               write(isave ,6002)  (max(fog(mi),tolw),    mi=1,n )
               write(isave ,6002)  (max(fol(mi),tolw),    mi=1,n )
               write(isave ,6003)  (ieoso(mi),    mi=1,n )
               write(isave ,6003)  (iceso(mi),    mi=1,n )
            end if
         else if(ico2.lt.0) then
            if(ihead.ne.0 .or. (irdof .eq. 13 .and.
     &           abs(ifree) .ne. 1)) then
               write(isave ,6002)  (sat_dum,    mi=1,n )
            else
               write(isave ,6002)  (max(s(mi),tolw),    mi=1,n )
            endif
            write(isave ,6002) (pho(mi)-phi_inc,  mi=1,n )
c     write(isave ,6002) (max(pho(mi)-phi_inc,tolw),  mi=1,n )
         endif

         if (flux_flag(1:2) .eq. 'no') then
            write (isave, '(a11)') flux_flag
         else
            if (idoff .lt. 0) then
               flux_flag = 'no fluxes  '
               write (isave, '(a11)') 'no fluxes  '
               if (iout .ne. 0) then
                  write (iout, *) 'WARNING: Heat conduction only ',
     &                 'problem'
                  write (iout, *) 'fluxes can not be written to ',
     &                 'restart file'
               end if
            else
               if (flux_flag(1:3) .eq. 'all') then
                  if (irdof .ne. 13) then
                     write (isave, '(a11)') flux_flag
                     write (isave, *) numflux
                     write(isave, 6002) (a_axy(i), i = 1,numflux)
                     if(jswitch.eq.0) then
                      write(isave, 6002) (a_vxy(i), i = 1,numflux)
                     else
                      write(isave, 6002) (0.0d0, i = 1,numflux)
                     endif
                  else
                     flux_flag = 'liquid flux'
                     write (isave, '(a11)') flux_flag
                     write (isave, *) numflux
                     write (isave, 6002) (a_axy(i), i = 1,numflux)
                     if (iout .ne. 0) then
                        write(iout, *) 'WARNING: Liquid only problem,',
     &                    ' vapor flux'
                        write(iout, *) 'can not be written to restart',
     &                       ' file'
                     end if
                  end if
               else if (flux_flag(1:3) .eq. 'liq') then
                  write (isave, '(a11)') flux_flag
                  write (isave, *) numflux
                  write(isave, 6002) (a_axy(i), i = 1,numflux)
               else if (flux_flag(1:3) .eq. 'vap') then
                  if (irdof .ne. 13) then
                     write (isave, '(a11)') flux_flag
                     write (isave, *) numflux
                     if(jswitch.eq.0) then
                      write(isave, 6002) (a_vxy(i), i = 1,numflux)
                     else
                      write(isave, 6002) (0.0d0, i = 1,numflux)
                     endif
                  else
                     flux_flag = 'no fluxes  '
                     write (isave, '(a11)') flux_flag
                     if (iout .ne. 0) then
                        write(iout, *) 'WARNING: Liquid only problem,',
     &                    ' vapor flux'
                        write(iout, *) 'can not be written to restart',
     &                       ' file'
                     end if
                  end if
               end if
            end if
         end if

 6002    format(4g25.16)
 6003    format(30i3)

      else
c Unformatted output
         write(isave)  verno, jdate, jtime, wdd
         write(isave)  days
c     write descriptors
         if (iriver .ne. 0) then
            if (icarb .eq. 1) then
               write(isave) 'wcar'
            else
               if (ico2.gt.0) write(isave) 'wnga'
               if (ico2.lt.0) write(isave) 'wair'
               if (ico2.eq.0) write(isave) 'wh20'
            end if
         else
            if (icarb .eq. 1) then
               write(isave) 'carb'
            else
               if (ico2.gt.0) write(isave) 'ngas'
               if (ico2.lt.0) write(isave) 'air '
               if (ico2.eq.0) write(isave) 'h20 '
            end if
         end if
         if ((iccen.eq.0).and..not.ptrak) write(isave) 'ntra'
         if (iccen.ne.0) write(isave) 'trac'
         if (ptrak) write(isave) 'ptrk'
         if (istrs.eq.0) write(isave) 'nstr'
         if (istrs.ne.0) write(isave) 'strs'
         if (idpdp.eq.0) write(isave) 'ndpd'
         if (idpdp.ne.0) write(isave) 'dpdp'
         if (idualp.eq.0) write(isave) 'ndua'
         if (idualp.ne.0) write(isave) 'dual'
         if (ico2.gt.0) then
            write(isave)  (max(to(mi),tolw),   mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave)  (max(s(mi),tolw),    mi=1,n )
            else
               write(isave)  (sat_dum,    mi=1,n )
            endif
            write(isave)  (max(pho(mi),tolw),  mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave)  (max(pcio(mi),tolw), mi=1,n )
            else
               write(isave)  (max(pho(mi),tolw),  mi=1,n )
            endif
         else if(ico2.eq.0 .or. icarb .eq. 1) then
            write(isave)  (max(to(mi),tolw),   mi=1,n )
            if (irdof .ne. 13 .or. ifree .ne. 0) then
               write(isave)  (max(s(mi),tolw),    mi=1,n )
            else
               write(isave)  (sat_dum,    mi=1,n )
            endif
            write(isave)  (max(pho(mi),tolw),  mi=1,n )
            if (icarb .eq. 1) then
               write(isave)  (max(toco2(mi),tolw),   mi=1,n )
               write(isave)  (max(phoco2(mi),tolw),  mi=1,n )
               write(isave)  (max(fow(mi),tolw),    mi=1,n )
               write(isave)  (max(fog(mi),tolw),    mi=1,n )
               write(isave)  (max(fol(mi),tolw),    mi=1,n )
               write(isave)  (ieoso(mi),    mi=1,n )
               write(isave)  (iceso(mi),    mi=1,n )
            end if
         else if(ico2.lt.0) then
            if(ihead.ne.0 .or. (irdof .eq. 13 .and.
     &           abs(ifree) .ne. 1)) then
               write(isave)  (sat_dum,    mi=1,n )
            else
               write(isave)  (max(s(mi),tolw),    mi=1,n )
            endif
            write(isave) (pho(mi)-phi_inc,  mi=1,n )
c     write(isave) (max(pho(mi)-phi_inc,tolw),  mi=1,n )
         endif
         if (flux_flag(1:2) .eq. 'no') then
            write (isave) flux_flag
         else
            if (idoff .lt. 0) then
               flux_flag = 'no fluxes  '
               write (isave) 'no fluxes  '
               if (iout .ne. 0) then
                  write (iout, *)
     &                 'WARNING: Heat conduction only problem'
                  write (iout, *)
     &                 'fluxes can not be written to restart file'
               end if
            else
               if (flux_flag(1:3) .eq. 'all') then
                  if (irdof .ne. 13) then
                     write (isave) flux_flag
                     write (isave) numflux
                     write (isave) (a_axy(i), i = 1,numflux)
                     if(jswitch.eq.0) then
                      write(isave, 6002) (a_vxy(i), i = 1,numflux)
                     else
                      write(isave, 6002) (0.0d0, i = 1,numflux)
                     endif
                  else
                     flux_flag = 'liquid flux'
                     write (isave) flux_flag
                     write (isave) numflux
                     write (isave) (a_axy(i), i = 1,numflux)
                     if (iout .ne. 0) then
                        write(iout,*) 'WARNING: Liquid only problem, ',
     &                       'vapor flux'
                        write(iout,*) 'can not be written to restart ',
     &                       'file'
                     end if
                  end if
               else if (flux_flag(1:3) .eq. 'liq') then
                  write (isave) flux_flag
                  write (isave) numflux
                  write (isave) (a_axy(i), i = 1,numflux)
               else if (flux_flag(1:3) .eq. 'vap') then
                  if (irdof .ne. 13) then
                     write (isave) flux_flag
                     write (isave) numflux
                     if(jswitch.eq.0) then
                      write(isave) (a_vxy(i), i = 1,numflux)
                     else
                      write(isave) (0.0d0, i = 1,numflux)
                     endif
                  else
                     flux_flag = 'no fluxes  '
                     write (isave, '(a11)') flux_flag
                     if (iout .ne. 0) then
                        write(iout, *) 'WARNING: Liquid only problem,',
     &                       ' vapor flux'
                        write(iout, *) 'can not be written to restart',
     &                       ' file'
                     end if
                  end if
               end if
            end if
         end if
      endif

      nsave  =  1

      log_flag = .TRUE.
      if (iccen.eq.1) call diskc(log_flag)
      if (ptrak) call diskp(log_flag)

c     if (istrs.ne.0) call  stressctr  (16,0 )
c write initial pressures and temperatures if enabled via restart macro
      if(ipini .ne. 0) then
         if (cform(7) .eq. 'formatted') then
            write(isave,*)  ( tini (mi) , mi=1,n )
            write(isave,*)  ( phini (mi) , mi=1,n )
         else
            write(isave)  ( tini (mi) , mi=1,n )
            write(isave)  ( phini (mi) , mi=1,n )
         endif
      endif
      close  ( isave )

      return
      end

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM


text:
      subroutine slant(p,zstat,zzero,vzero,time,dist)
c---------------------------------------------------------------------
c     slant calculates simple slant path travel time and distance
c  corrections for stations with nonzero elevations.
c
c  arguments-(input)
c
c     p-ray parameter
c     zstat-station depth (note positive station elevations are
c           negative depths so zstat is almost always negative
c     zzero-depth to correct travel time and distance to
c     vzero-stripping velocity for upper layer (assumed constant)
c
c  arguments-(output)
c
c     time-travel time correction
c     dist-distance correction
c
c---------------------------------------------------------------------
      if(zzero.eq.zstat) then
            time = 0.0
            dist = 0.0
      else
            dz = zzero - zstat
            rad = sqrt(1. - (p*vzero)**2)
            time = dz/(vzero*rad)
            dist = p*vzero*dz/rad
      endif
      return
      end

c $Id$


text:
!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis
!dis

MODULE vinterp_utils

  ! Module that contains arrays and routines for linear and logarithmic
  ! interpolation

  IMPLICIT NONE

CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   SUBROUTINE compute_lin_weights(p_mid_mb,p_lower_mb,p_upper_mb, &
                                  weight_bot, weight_top)

    ! Computes the weighting coefficient for the top bounding level
    ! of two pressure levels to interpolate to a level in-between using
    ! linear interpolation.

    IMPLICIT NONE
    REAL, INTENT(IN)             :: p_mid_mb  ! Desired pressure level
    REAL, INTENT(IN)             :: p_lower_mb ! Lower bounding pressure
    REAL, INTENT(IN)             :: p_upper_mb ! Upper bounding pressure
    REAL, INTENT(OUT)            :: weight_bot ! Weight given to bottom level
    REAL, INTENT(OUT)            :: weight_top ! Weight given to top level

    weight_bot = (p_mid_mb - p_upper_mb) / (p_lower_mb - p_upper_mb)
    weight_top = 1.0 - weight_bot

  END SUBROUTINE compute_lin_weights
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE compute_log_weights(p_mid_mb,p_lower_mb,p_upper_mb, &
                                 weight_bot, weight_top)

    ! Computes weighting coefficient for upper pressure level that bounds
    ! a desired pressure level for logarithmic interpolation.

    ! NOTE: Pressures must be in mb!!!

    IMPLICIT NONE
    REAL, INTENT(IN)             :: p_mid_mb  ! Desired pressure level
    REAL, INTENT(IN)             :: p_lower_mb ! Lower bounding pressure
    REAL, INTENT(IN)             :: p_upper_mb ! Upper bounding pressure
    REAL, INTENT(OUT)            :: weight_bot ! Weight given to bottom level
    REAL, INTENT(OUT)            :: weight_top ! Weight given to top level

    weight_bot = ( ALOG(p_mid_mb) - ALOG(p_upper_mb) ) / &
                 ( ALOG(p_lower_mb) - ALOG(p_upper_mb) )
    weight_top = 1.0 - weight_bot

  END SUBROUTINE compute_log_weights
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE vinterp_3d(var_in, trap_bot_ind, trap_top_ind, &
                        weight_top, below_ground_value, var_out, &
                        nx, ny, nzin, nzout)

    ! Interpolates var_in to var_out using array of trapping indices
    ! and top weight values.  Allows the user to set a default
    ! 2d array to use for "below ground" values

    IMPLICIT NONE
    INTEGER, INTENT(IN)            :: nx
    INTEGER, INTENT(IN)            :: ny
    INTEGER, INTENT(IN)            :: nzin
    INTEGER, INTENT(IN)            :: nzout
    REAL, INTENT(IN)               :: var_in (nx,ny,nzin)
    INTEGER, INTENT(IN)            :: trap_bot_ind(nx,ny,nzout)
    INTEGER, INTENT(IN)            :: trap_top_ind(nx,ny,nzout)
    REAL, INTENT(IN)               :: weight_top(nx,ny,nzout)
    REAL, INTENT(IN)               :: below_ground_value(nx,ny)
    REAL, INTENT(OUT)              :: var_out(nx,ny,nzout)
    INTEGER                        :: i,j,k

    DO j = 1,ny
      DO i = 1,nx
        DO k= 1,nzout

          ! Is level below ground?  If so, zero it out
          IF (trap_bot_ind(i,j,k).LT. 1) THEN
            var_out(i,j,k) = below_ground_value(i,j)

          ! Is it above model top? If so, replicate top value
          ELSE IF (trap_bot_ind(i,j,k).EQ.nzin) THEN
            var_out(i,j,k) = var_in(i,j,nzin)

          ELSE
            var_out(i,j,k) = weight_top(i,j,k) * &
                             var_in(i,j,trap_top_ind(i,j,k)) + &
                             (1.-weight_top(i,j,k)) * &
                             var_in(i,j,trap_bot_ind(i,j,k))
          ENDIF
        ENDDO
      ENDDO
    ENDDO

    RETURN
  END SUBROUTINE vinterp_3d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE vinterp_utils

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense