SUBROUTINE p101(input_file,output_file)
!-------------------------------------------------------------------------
! Program 10.1 Eigenvalue analysis of elastic beams using 2-node
!              beam elements. Lumped mass.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,idiag,iel,ifail,j,k,nband,ndof=4,nels,neq,nlen,nmodes,nn,     &
   nod=2,nodof=2,nprops=2,np_types,nr
 REAL(iwp)::d12=12.0_iwp,one=1.0_iwp,pt5=0.5_iwp,penalty=1.e20_iwp,       &
   etol=1.0e-30_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::diag(:),ell(:),kh(:),km(:,:),ku(:,:),kv(:),       &
   mm(:,:),prop(:,:),rrmass(:),udiag(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 nn=nels+1
 ALLOCATE(nf(nodof,nn),km(ndof,ndof),num(nod),g(ndof),mm(ndof,ndof),      &
   ell(nels),etype(nels),g_g(ndof,nels),prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(diag(0:neq),udiag(0:neq),kdiag(neq),rrmass(0:neq))
!-----------------------loop the elements to find global array sizes------
 nband=0
 kdiag=0
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   IF(nband<bandwidth(g))nband=bandwidth(g)
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 WRITE(11,'(A,I5,A,/,A,I5,/,A,I5)')" There are",neq," equations",         &
   " The half-bandwidth (including diagonal) is",nband+1,                 &
   " The skyline storage is",kdiag(neq)
!-----------------------global stiffness and mass matrix assembly---------
 ALLOCATE(ku(neq,nband+1),kv(kdiag(neq)),kh(kdiag(neq)))
 diag=zero
 ku=zero
 elements_2: DO iel=1,nels
   g=g_g(:,iel)
   mm=zero
   mm(1,1)=pt5*prop(2,etype(iel))*ell(iel)
   mm(3,3)=mm(1,1)
   mm(2,2)=mm(1,1)*ell(iel)**2/d12
   mm(4,4)=mm(2,2)
   CALL formlump(diag,mm,g)
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   CALL formku(ku,km,g)
 END DO elements_2
!-----------------------reduce to standard eigenvalue problem-------------
 rrmass(1:)=one/SQRT(diag(1:))
 DO i=1,neq
 IF(i<=neq-nband)THEN
   k=nband+1
 ELSE
   k=neq-i+1
 END IF
   DO j=1,k
     ku(i,j)=ku(i,j)*rrmass(i)*rrmass(i+j-1)
   END DO
 END DO
!-----------------------convert to skyline form---------------------------
 kh(1)=ku(1,1)
 k=1
 DO i=2,neq
   idiag=kdiag(i)-kdiag(i-1)
   DO j=1,idiag
   k=k+1
   kh(k)=ku(i+j-idiag,1-j+idiag)
   END DO
 END DO
!-----------------------extract the eigenvalues---------------------------
 CALL bandred(ku,diag,udiag)
 ifail=1
 CALL bisect(diag,udiag,etol,ifail)
 WRITE(11,'(/A)')" The eigenvalues are:"
 WRITE(11,'(6E12.4)')diag(1:)
!-----------------------extract the eigenvectors--------------------------
 READ(10,*)nmodes
 DO i=1,nmodes
   kv=kh;kv(kdiag)=kv(kdiag)-diag(i)
   kv(1)=kv(1)+penalty
   udiag=zero
   udiag(1)=kv(1)
   CALL sparin_gauss(kv,kdiag)
   CALL spabac_gauss(kv,udiag,kdiag)
   udiag=rrmass*udiag
   WRITE(11,'(A,I3,A)')" Eigenvector number",i," is:"
   WRITE(11,'(6E12.4)')udiag(1:)/MAXVAL(ABS(udiag(1:)))
 END DO
END SUBROUTINE p101


text:
        SUBROUTINE  LS_RELH  ( lsfrpt, ipt, iret )
C************************************************************************
C* LS_RELH                                                              *
C*                                                                      *
C* This subroutine decodes the relative humidity group 29UUU, where UUU *
C* is the relative humidity of the air in percentage.                   *
C*                                                                      *
C* LS_RELH  ( LSFRPT, IPT, IRET ) 	                                *
C*                                                                      *
C* Input parameters:                                                    *
C*      LSFRPT          CHAR*           Report array                    *
C*                                                                      *
C* Input and Output parameters:                                         *
C*      IPT             INTEGER         On input, points to first U in  *
C*					29UUU group; on output, points  *
C*					to last U			*
C*					                                *
C* Output parameters:                                                   *
C*      RIVALS(IRRELH)  REAL            Relative humidity in percent    *
C*	IRET            INTEGER         Return code                     *
C*				   	  0 = normal return 	        *
C*                                        1 = problems                  *
C*                                                                      *
C**								        *
C* Log:							                *
C* R. Hollern/NCEP      6/96                                            *
C* D. Kidwell/NCEP      4/97	Removed inteface calls, reorganized     *
C*                              header and comments                     *
C* R. Hollern/NCEP      1/98	Changes based on MA_RELH                *
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
	INCLUDE		'lscmn.cmn'
C*
        CHARACTER*(*)   lsfrpt
C*
        CHARACTER   	fld3*3
C------------------------------------------------------------------------
        iret = 0
C
        fld3 = lsfrpt (ipt:ipt+2)
        CALL  ST_CRNM ( fld3, rval, ier )
        ipt = ipt + 2
        IF ( ier .eq. 0 ) rivals ( irrelh ) = rval
C*
        RETURN
        END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
C    Copyright(C) 2008 Sandia Corporation.  Under the terms of Contract
C    DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C    certain rights in this software
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of Sandia Corporation nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
C=======================================================================
      SUBROUTINE DBIELB (NDB, OPTION, NELBS, NELBE, IDELB, NUMELB,
     &           NUMLNK, NUMATR, BLKTYP, A, IELNK, IEATR, IOERR)
C=======================================================================

C   --*** DBIELB *** (EXOLIB) Read database element blocks
C   --   Written by Amy Gilkey - revised 10/14/87
C   --   Modified to Read EXODUSIIV2
C   --
C   --DBIELB reads the element block information from the database.
C   --An error message is displayed if the end of file is read.
C   --
C   --The dynamic memory arrays LINK and ATRIB must be reserved
C   --if the connectivity and attributes are to be stored.  These arrays
C   --will be expanded by this routine to hold the new data.
C   --
C   --Parameters:
C   --   NDB    - IN  - the database file
C   --   OPTION - IN  - ' ' to not store, '*' to store all, else store options:
C   --                  Element block ID's are always read in
C   --                  'H' to store all header information
C   --                  'C' to store connectivity (+ NUMLNK + NUMELB)
C   --                  'A' to store attributes (+ NUMATR + NUMELB)
C   --   NELBS  - IN  - the number of the first element block to read
C   --   NELBE  - IN  - the number of the last element block to read
C   --   IDELB  - OUT - the element block IDs for each block
C   --   NUMELB - OUT - the number of elements in each block (if OPTION)
C   --   NUMLNK - OUT - the number of nodes per element in each block
C   --                  (if OPTION)
C   --   NUMATR - OUT - the number of attributes in each block (if OPTION)
C   --   BLKTYP - OUT - the type of elements in the each block
C   --   A      - I/O - the dynamic memory base array
C   --   IELNK  - OUT - the size of the connectivity array
C   --   IEATR  - OUT - the size of the attribute array
C   --   IOERR  - OUT - error flag
C   --

      include 'exodusII.inc'

      INTEGER NDB
      CHARACTER*(*) OPTION
      INTEGER NELBS, NELBE
      INTEGER IDELB(*)
      INTEGER NUMELB(*)
      INTEGER NUMLNK(*)
      INTEGER NUMATR(*)
      DIMENSION A(1)
      INTEGER KLINK, KATRIB
      CHARACTER*(MXSTLN) BLKTYP(*)
      INTEGER IELNK, IEATR
      INTEGER IOERR
      LOGICAL ALL, HOPT, COPT, AOPT

      IOERR = 0
      IELNK = 0
      IEATR = 0

C     Set option flags
      ALL  = (OPTION .EQ. '*')
      HOPT = ALL .OR. (INDEX (OPTION, 'H') .GT. 0)
      COPT = ALL .OR. (INDEX (OPTION, 'C') .GT. 0)
      AOPT = ALL .OR. (INDEX (OPTION, 'A') .GT. 0)
C     No need to check if option = 'I' because the element block
C     IDs are always read in this subroutine.  The header, connectivity
C     and attribute arrays need the element block IDs.

C     Read the element block ID's
      CALL EXGEBI (NDB, IDELB, IERR)

      IF (ALL .OR. HOPT) THEN
         DO 100 IELB = NELBS, NELBE
C           Read element block parameters - returns:
C           1. element block ID's
C           2. element type in the element block
C           3. number of elements in the element block
C           4. number of nodes per element in the element block
C           5. number of attributes per element in the element block
C           6. error id
            call exgelb(ndb, idelb(ielb), blktyp(ielb), numelb(ielb),
     &                  numlnk(ielb), numatr(ielb), ierr)
            call exupcs(blktyp(ielb))
            call pckstr(1, blktyp(ielb))
  100    CONTINUE
      END IF

      IF (ALL .OR. COPT) THEN
C        Assumption: space has been reserverd for 'LINK'
C        call MxFIND(array_name, ret_index, array_size)
         CALL MDFIND ('LINK', KLINK, IELNK)
         CALL MDSTAT (NERR, MEM)
         IF (NERR .GT. 0) then
            CALL MEMERR
            IOERR = 1
            RETURN
         END IF
         DO 110 IELB = NELBS, NELBE
C           number of elments in a block
            NEL  = NUMELB(IELB)
C           number of nodes per element in the element block
            NLNK = NUMLNK(IELB)
            ISLNK = IELNK + 1
            IELNK = IELNK + NLNK * NEL
            CALL MDLONG ('LINK', KLINK, IELNK)
            CALL EXGELC(NDB, IDELB(IELB), A(KLINK+ISLNK-1), IERR)
  110    CONTINUE
         CALL MDSTAT (NERR, MEM)
         IF (NERR .GT. 0) then
            CALL MEMERR
            IOERR = 1
            RETURN
         END IF
      END IF

      IF (ALL .OR. AOPT) THEN
C        Assumption: space has been reserverd for 'ATRIB'
C        call MxFIND(array_name, ret_index, array_size)
         CALL MDFIND ('ATRIB', KATRIB, IEATR)
         CALL MDSTAT (NERR, MEM)
         IF (NERR .GT. 0) then
            CALL MEMERR
            IOERR = 1
            RETURN
         END IF
         DO 120 IELB = NELBS, NELBE
C           number of elments in a block
            NEL  = NUMELB(IELB)
C           number of attributes in this block
            NATR = NUMATR(IELB)
            IF (NATR .GT. 0) THEN
               ISATR = IEATR + 1
               IEATR = IEATR + NATR * NEL
               CALL MDLONG ('ATRIB', KATRIB, IEATR)
               CALL EXGEAT(NDB, IDELB(IELB), A(KATRIB+ISATR-1), IERR)
            END IF
  120    CONTINUE
         CALL MDSTAT (NERR, MEM)
         IF (NERR .GT. 0) then
            CALL MEMERR
            IOERR = 1
         END IF
      END IF

      RETURN
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


     SUBROUTINE similarity(xx,yy,simfx)!! similarity function calculation. Can be used to estimate periodicity of the signal
                                       !! by providing the same signal as the xx,yy input.
     implicit none
     real(kind=8), intent(in):: xx(niter),yy(niter)
     real(kind=8), intent(out):: simfx(imaxlag)
     real(kind=8):: simsum, sqm1,sqm2
     integer:: i,j

     simfx=0.d0

     do i=1,imaxlag
       simsum=0.d0; sqm1=0.d0; sqm2=0.d0
       do j=1,niter-i
        simsum=simsum+(xx(j)-yy(j+i))**2
        sqm1=sqm1+xx(j)**2/dfloat(niter-i)
        sqm2=sqm2+yy(j)**2/dfloat(niter-i)
       enddo
      simfx(i)=(simsum/dfloat(niter-i))/sqrt(sqm1*sqm2)
     enddo

     RETURN
     end SUBROUTINE similarity


text: The A. G. Brinley Special Merit Award for service to the Davis Community was established in 1969 by John W. Brinley in memory of his father, A. G. Brinley Aley (Al) Green Brinley (15 August 188523 June 1961). The plaque that honors recipients is housed in City Hall.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      SUBROUTINE SINT (N,X,WSAVE)
      IMPLICIT NONE
      INTEGER :: N, IW1, IW2, IW3, NP1
      REAL :: X(*), WSAVE(*)
      NP1 = N+1
      IW1 = N/2+1
      IW2 = IW1+NP1
      IW3 = IW2+NP1
      CALL SINT1(N,X,WSAVE,WSAVE(IW1),WSAVE(IW2),WSAVE(IW3))
      RETURN
      END

max_stars_repo_name: cielavenir/scipy

max_issues_repo_name: cielavenir/scipy

max_forks_repo_name: cielavenir/scipy


text:
# SoC integration file

file example_soc.v

# CPU + debug components

list $HDL/hazard3.f
list $HDL/debug/dtm/hazard3_jtag_dtm.f
list $HDL/debug/dm/hazard3_dm.f

list $HDL/peri/hazard3_riscv_timer.f

# Generic SoC components from libfpga

file ../libfpga/common/reset_sync.v

list ../libfpga/peris/uart/uart.f
list ../libfpga/peris/spi_03h_xip/spi_03h_xip.f
list ../libfpga/mem/ahb_cache.f
list ../libfpga/mem/ahb_sync_sram.f

list ../libfpga/busfabric/ahbl_crossbar.f
file ../libfpga/busfabric/ahbl_to_apb.v
file ../libfpga/busfabric/apb_splitter.v


text:
      SUBROUTINE WQ3D(ISTL_,IS2TL_)
C
C  CONTROL SUBROUTINE FOR WATER QUALITY MODEL
C  ORGINALLY CODED BY K.-Y. PARK
C  OPTIMIZED AND MODIFIED BY J. M. HAMRICK
C CHANGE RECORD
C
C     Merged SNL and DS-INTL
      USE GLOBAL
#ifdef key_ncdf
      USE IOM
#endif
      REAL,SAVE :: DAYNEXT
      REAL,SAVE :: SUNDAY1, SUNDAY2, SUNSOL1, SUNSOL2
      REAL,SAVE :: SUNFRC1, SUNFRC2
      INTEGER*4,SAVE :: M

      DATA IWQTAGR,IWQTSTL/2*0/
      DATA ISMTICI/0/
      IF(ETIMEDAY.LE.(DTWQ+1.E-8))THEN
        DAYNEXT=FLOAT(INT(TIMEDAY))+1.
      ENDIF

      ! *** PMC - NEW IMPLEMENTATION TO USE DAILY (FROM HOURLY) SOLAR RADIATION FOR ALGAL GROWTH
      IF(ITNWQ.EQ.0.AND.IWQSUN.GT.1.AND.NASER.GT.0)THEN
        ! *** BUILD THE DAILY AVERAGE SOLAR RADIATION FROM THE ASER DATA
        SUNDAY1 = TIMEDAY+0.5
        SUNDAY2 = DAYNEXT+0.5

        ! *** FIND 1ST POINT
        M = 1
        DO WHILE (TASER(M,1).LT.SUNDAY1-0.5)
          M = M+1
        END DO

        ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION
        M1 = 0
        M2 = 0
        SUNSOL1 = 0.0
        DO WHILE (TASER(M,1).LT.SUNDAY1+0.5)
          M1 = M1+1
          IF(SOLSWR(M,1).GT.0.)THEN
            M2 = M2+1
            SUNSOL1=SUNSOL1+SOLSWR(M,1)
          ENDIF
          M = M+1
        END DO
        IF(M1.GT.0)THEN
          SUNFRC1=FLOAT(M2)/FLOAT(M1)
          SUNSOL1=SUNSOL1/FLOAT(M1)
        ELSE
          SUNFRC1=1.0
        ENDIF

        ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION
        M1 = 0
        M2 = 0
        SUNSOL2 = 0.
        DO WHILE (TASER(M,1).LT.SUNDAY2+0.5)
          M1 = M1+1
          IF(SOLSWR(M,1).GT.0.)THEN
            M2 = M2+1
            SUNSOL2=SUNSOL2+SOLSWR(M,1)
          ENDIF
          M = M+1
        END DO
        IF(M1.GT.0)THEN
          SUNFRC2=FLOAT(M2)/FLOAT(M1)
          SUNSOL2=SUNSOL2/FLOAT(M1)
        ELSE
          SUNFRC2=1.
        ENDIF
      ENDIF
C
C **  READ INITIAL CONDITIONS
C
      IF(IWQICI.EQ.1) CALL RWQICI
C
C **  READ TIME/SPACE VARYING ALGAE PARAMETERS
C
      IF(IWQAGR.EQ.1 .AND. ITNWQ.EQ.IWQTAGR) CALL RWQAGR(IWQTAGR)
C
C **  READ TIME/SPACE VARYING SETTLING VELOCITIES
C
      IF(IWQSTL.EQ.1 .AND. ITNWQ.EQ.IWQTSTL) CALL RWQSTL(IWQTSTL)
C
C *** READ BENTHIC FLUX IF REQUIRED
C *** CALL SPATIALLY AND TIME VARYING BENTHIC FLUX HERE.  ONLY CALL RWQBEN2
C *** IF SIMULATION TIME IS >= THE NEXT TIME IN THE BENTHIC FILE.
C
      IF(IWQBEN .EQ. 2)THEN
        IF(ISDYNSTP.EQ.0)THEN
          TIMTMP=(DT*FLOAT(N)+TCON*TBEGIN)/86400.
        ELSE
          TIMTMP=TIMESEC/86400.
        ENDIF
        IF(TIMTMP .GE. BENDAY)THEN
          CALL RWQBEN2(TIMTMP)
        ENDIF
      ENDIF
C
C **  UPDATE POINT SOURCE LOADINGS
C
      IF(IWQPSL.EQ.1)THEN
        CALL RWQPSL
      ELSEIF(IWQPSL.GE.2) THEN !GR modified to be G.E.2 for option IWQPSL.EQ.3
        CALL CALCSER(ISTL_)
      ENDIF
C
      CALL RWQATM
C
C **  READ SEDIMENT MODEL INITIAL CONDITION
C
      IF(IWQBEN.EQ.1)THEN
        IF(ISMICI.EQ.1 .AND. ITNWQ.EQ.ISMTICI) CALL RSMICI(ISMTICI)
      ENDIF
C
C **  UPDATE OLD CONCENTRATIONS
C   FOLLOWING THE CALL TO CALWQC MINUS OLD D.O. BEFORE THE CALL).
C   FIRST SUBTRACT THE OLD D.O. HERE:
C
      IF(ISMTSB.LT.ISMTSE)THEN
        DO K=1,KC
          DO L=2,LA
            XMRM = WQV(L,K,19)*DTWQ*DZC(K)*HP(L)
            XDOTRN(L,K) = XDOTRN(L,K) - XMRM
            XDOALL(L,K) = XDOALL(L,K) - XMRM
          ENDDO
        ENDDO
      ENDIF
C
C **  CALCULATE PHYSICAL TRANSPORT
C **  WQV(L,K,NW) SENT TO PHYSICAL TRANSPORT AND TRANSPORTED
C **  VALUE RETURNED IN WQV(L,K,NW)
C
      CALL CALWQC(ISTL_,IS2TL_) !transports (advects/disperses) WQV
C
C   FOLLOWING THE CALL TO CALWQC MINUS OLD D.O. BEFORE THE CALL).
C   NOW ADD THE NEW D.O. HERE:
C
      IF(ISMTSB.LT.ISMTSE)THEN
        DO K=1,KC
          DO L=2,LA
            XMRM = WQV(L,K,19)*DTWQ*DZC(K)*HP(L)
            XDOTRN(L,K) = XDOTRN(L,K) + XMRM
            XDOALL(L,K) = XDOALL(L,K) + XMRM
          ENDDO
        ENDDO
      ENDIF
C
C **  UPDATE WATER COLUMN KINETICS AND SEDIMENT MODEL
C **  OVER LONGER TIME INTERVALS THAN PHYSICAL TRANSPORT
C **  IF NWQKDPT .GT. 1
C
      NWQKCNT=NWQKCNT+1
      IF(ITNWQ.EQ.0.OR.NWQKCNT.EQ.NWQKDPT)THEN
        !IF(ITNWQ.NE.0)NWQKCNT=0   PMC
        NWQKCNT=0
        ! **  UPDATE SOLAR RADIATION INTENSITY
        !   WQI1 = SOLAR RADIATION ON PREVIOUS DAY
        !   WQI2 = SOLAR RADIATION TWO DAYS AGO
        !   WQI3 = SOLAR RADIATION THREE DAYS AGO
        ! ***  UPDATE OCCURS ONLY WHEN THE SIMULATION DAY CHANGES.
        IF(TIMEDAY.GT.DAYNEXT)THEN  ! *** DSLLC: FORCE A SOLAR DAY UPDATE
          WQI3 = WQI2
          WQI2 = WQI1
          WQI1 = WQI0OPT
          IF(IWQSUN.GT.0)WQI0OPT = 0.0
          DAYNEXT=DAYNEXT+1.
        ENDIF

        IF(IWQSUN.GT.1)THEN
          IF(TIMEDAY.GT.SUNDAY2)THEN
            ! *** BUILD THE DAILY AVERAGE SOLAR RADIATION FROM THE ASER DATA
            SUNDAY1 = SUNDAY2
            SUNSOL1 = SUNSOL2
            SUNFRC1 = SUNFRC2
          ! *** FIND 1ST POINT
            !IF(M==0)M = 1 !If NASER = 0, the first time through M=0 so TASER(0,1) is not defined (this means there is an error in the INP files)
            ! *** BUILD THE AVERAGE DAILY SOLAR RADIATION
            M1 = 0
            M2 = 0
            SUNSOL2 = 0.
            SUNDAY2 = SUNDAY2+1.
            DO WHILE (TASER(M,1).LT.SUNDAY2+0.5)
              M1 = M1+1
              IF(SOLSWR(M,1).GT.0.)THEN
                M2 = M2+1
                SUNSOL2=SUNSOL2+SOLSWR(M,1)
              ENDIF
              M = M+1
            END DO
            IF(M1.GT.0)THEN
              SUNFRC2=FLOAT(M2)/FLOAT(M1)
              SUNSOL2=SUNSOL2/FLOAT(M1)
            ELSE
              SUNFRC2=1.
            ENDIF

          ENDIF
        ENDIF

        ! **  READ SOLAR RADIATION INTENSITY AND DAYLIGHT LENGTH
        ! NOTE: IWQSUN=1 CALLS SUBROUTINE RWQSUN WHICH READS THE DAILY
        !                SOLAR RADIATION DATA FROM FILE SUNDAY.INP WHICH
        !                ARE IN UNITS OF LANGLEYS/DAY.
        !       IWQSUN=2 USES THE HOURLY SOLAR RADIATION DATA FROM ASER.INP
        !                COUPLED WITH THE COMPUTED OPTIMAL DAILY LIGHT TO
        !                LIMIT ALGAL GROWTH.
        !       IWQSUN=3 USES THE DAILY AVERAGE SOLAR RADIATION DATA COMPUTED
        !                FROM THE HOURLY ASER.INP AND THE COMPUTED OPTIMAL DAILY
        !                LIGHT TO LIMIT ALGAL GROWTH.
        !       IWQSUN>1 USES THE DAILY AVERAGE SOLAR RADIATION DATA COMPUTED
        !                FROM THE HOURLY ASER.INP DATA.  CONVERTS WATTS/M**2 TO
        !                LANGLEYS/DAY USING 2.065.  COMPUTES THE FRACTION OF
        !                DAYLIGHT AND ADJUSTS FOR PHOTOSYNTHETIC ACTIVE RADIATION BY
        !                PARADJ (~0.43)
        !
        IF(IWQSUN.EQ.0)THEN
          WQI0OPT = WQI0
        ELSEIF(IWQSUN.EQ.1)THEN
          CALL RWQSUN
          WQI0=SOLSRDT
          WQFD=SOLFRDT
          ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED
          WQI0OPT = MAX(WQI0OPT, WQI0)
        ELSEIF(IWQSUN.GT.1)THEN
          RATIO = (TIMEDAY-SUNDAY1)
          SOLARAVG = RATIO*(SUNSOL2-SUNSOL1)+SUNSOL1
          WQFD=RATIO*(SUNFRC2-SUNFRC1)+SUNFRC1

          ! *** SOLAR RADIATION IN LANGLEYS/DAY
          WQI0 = PARADJ*2.065*SOLARAVG

          IF(IWQSUN.EQ.2)THEN
            ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED
            WQI0OPT = MAX(WQI0OPT, WQI0*0.85)

            IF(NASER.GT.1.OR.USESHADE)THEN
              SOLARAVG=0.
              DO L=2,LA
                SOLARAVG=SOLARAVG+SOLSWRT(L)
              ENDDO
              SOLARAVG=SOLARAVG/FLOAT(LA-1)
            ELSE
              ! *** Spatially Constant Atmospheric Parameters
              SOLARAVG=SOLSWRT(2)
            ENDIF
            ! *** SOLAR RADIATION IN LANGLEYS/DAY
            WQI0 = PARADJ*2.065*SOLARAVG
            WQFD=1.
          ELSE
            ! *** OPTIMAL SOLAR RADIATION IS ALWAYS UPDATED BASED ON DAY AVERAGED
            WQI0OPT = MAX(WQI0OPT, WQI0)
          ENDIF
        ENDIF
C
C **  LOAD WQV INTO WQVO FOR REACTION CALCULATION
C
        NMALG=0
        IF(IDNOTRVA.GT.0) NMALG=1
        DO NW=1,NWQV+NMALG
          IF(ISTRWQ(NW).NE.0)THEN
!            DO K=1,KC
!              DO L=2,LA
!                WQVO(L,K,NW)=WQV(L,K,NW)
!              ENDDO
!            ENDDO
            WQVO(2:LA,1:KC,NW)=WQV(2:LA,1:KC,NW)
          ENDIF
        ENDDO
C
C **    CALCULATE KINETIC SOURCES AND SINKS
C
        TTMP=SECNDS(SECNDS_ZERO)
        IF(ISWQLVL.EQ.0) CALL WQSKE0
        IF(ISWQLVL.EQ.1) CALL WQSKE1
        IF(ISWQLVL.EQ.2) CALL WQSKE2
        IF(ISWQLVL.EQ.3) CALL WQSKE3
        IF(ISWQLVL.EQ.4) CALL WQSKE4
        TWQKIN=TWQKIN+SECNDS(TTMP)
C
C **    DIAGNOSE NEGATIVE CONCENTRATIONS
C
        IF(IWQNC.EQ.1)CALL WWQNC
C
C **    WRITE TIME SERIES
C
C *** Write of WQ spatial maps depends on netCDF library. If this is not
C *** available then it will not write spatial maps.  A user-defined function
C *** could be temporarily introduced that dumps WQ variables to ASCII file
C *** to investigate further, have a look at WQ_NC_WRITE in netcdf_iom.F90 file
        IF(ITNWQ.GT.0 .AND. MOD(ITNWQ,IWQTSDT).EQ.0 .AND. ISVPH.EQ.1)THEN
#ifdef key_ncdf
          CALL WQ_NC_WRITE
#endif
        ENDIF
        IF(ITNWQ.GE.IWQTSB .AND. ITNWQ.LE.IWQTSE.AND.IWQTSE.GT.0)THEN
          IF(MOD(ITNWQ,IWQTSDT).EQ.0) CALL WWQTS
C
          CALL WWQTSBIN
C
        ENDIF
C
C **    CALL SEDIMENT DIAGENSIS MODEL
C
        IF(IWQBEN.EQ.1)THEN
          TTMP=SECNDS(SECNDS_ZERO)
          CALL SMMBE
          TWQSED=TWQSED+SECNDS(TTMP)
          IF(ISMTS.GE.1)THEN
C
C **      WRITE SEDIMENT MODEL TIME SERIES
C
            IF(ITNWQ.GE.ISMTSB .AND. ITNWQ.LE.ISMTSE)THEN
              IF(MOD(ITNWQ,ISMTSDT).EQ.0) CALL WSMTS
            ENDIF
          ENDIF
C
C **      WRITE SEDIMENT MODEL FLUXES TO BINARY FILE:
C
          IF(ITNWQ.GE.ISMTSB .AND. ITNWQ.LE.ISMTSE)THEN
            CALL WSMTSBIN
          ENDIF
        ENDIF
      ENDIF
C
C **  UPDATE TIME IN DAYS
C
      ITNWQ = ITNWQ + 2  !Integer time number in days
C
C **  ENDIF ON KINETIC AND SEDIMENT UPDATE
C **  INSERT TIME CALL
C **  WRITE RESTART FILES
C
      RETURN
      END


text:
      PROGRAM    TRACER
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          TRACER           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     PROGRAM :
C*          TRACER
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS PROGRAM INSERTS CODE INTO A FORTRAN PROGRAM
C*            TO CALCULATE TRACE, CPU TIME, AND DEBUG SUBCHK
C*            INFORMATION.
C*          IT IS PROGRAM 2 OF THE BUGOUT SERIES.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          MISC, SWITCH
C*
C*     FILE REFERENCES :
C*          5 - INPUT ORIGINAL SOURCE CODE
C*          7 - OUTPUT OF INSTRUMENTED CODE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          INDEX, OPTION, GETCRD, XRETUR, XEND,  SUBPRO, XSTOP,
C*          ASSURE, FASSUR
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          CALLS TO THE SYSTEM-SPECIFIC CPU TIME ROUTINES,SETIME AND
C*          TIMEX, ARE INSERTED INTO THE SOURCE CODE.
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION II.3     JULY 30 1985
C*
C*     CHANGE HISTORY :
C*          07/30/85     BUG FIXED IN MAIN, FILENAME ADDED TO PRINTOUT
C*          04/22/85     STATEMENT CLASSIFICATION MADE MORE FOOLPROOF
C*          06/15/84     MINOR BUG FIX AND PRINTOUT REFORMATTED
C*          01/27/84     VAX VERSION
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      LOGICAL VERIFY, LTIME, LTRACE, LINDEX, MAIN, PUTSTP, PUTRET
      LOGICAL ASSURE, FASSUR
      CHARACTER *80 CARD
      CHARACTER *1 COLUMN(80)
      CHARACTER *7 RETUR1
      CHARACTER *6 SPEC(17), FORM, RETRN, ND, SUBR, FUNC, ENTR, STP
      CHARACTER *6 STP1
      EQUIVALENCE (COLUMN(1),CARD)
      DATA SPEC/
     $ 'COMMON', 'DIMENS', 'INTEGE', ' REAL ', ' REAL*', 'CHARAC',
     $ ' DATA ', 'LOGICA', 'DOUBLE', 'EQUIVA', 'EXTERN', 'IMPLIC',
     $ 'NAMELI', 'COMPLE', 'DEFINE', 'PARAME', 'PROGRA' /
      DATA FORM/'FORMAT'/,  RETRN/'RETURN'/,  SUBR/'SUBROU'/,
     $     FUNC/'FUNCTI'/,  ENTR /' ENTRY'/,  STP /' STOP '/
      DATA STP1 /')STOP '/, RETUR1/')RETURN'/
C
      OPEN ( UNIT=7, STATUS='NEW', CARRIAGECONTROL='LIST', ERR=100 )
      NSPEC= 17
      MAIN = .FALSE.
      CALL OPTION
      IF ((.NOT. LTIME) .AND. (.NOT. LTRACE) .AND.
     $ (.NOT. LINDEX)) THEN
C
C --- NO OPTIONS CHOSEN, COPY INPUT AND EXIT
C
10       READ ( 5, 900, END=20 )CARD
         WRITE ( 7, 900 )CARD
         GO TO 10
20       STOP
      ENDIF
C
C --- DO WHILE END-OF-FILE ON SOURCE NOT REACHED
C
30    CALL GETCRD
35    IF (INDEX(CARD,FORM) .NE. 0) THEN
40       WRITE ( 7, 900 )CARD
         CALL GETCRD
         IF (COLUMN(6) .EQ. ' ')GO TO 35
         GO TO 40
      ENDIF
C
C --- CHECK THIS CARD TO SEE IF CODE INSERTION IS REQUIRED
C
C --- RETURN STATEMENT
C
      IF (INDEX(CARD,RETRN) .NE. 0) THEN
         IF (ASSURE('RETURN')) THEN
            CALL XRETUR
         ELSE
            WRITE(7,900) CARD
         ENDIF
C
C --- CONDITIONAL RETURN
C
      ELSEIF (INDEX(CARD,RETUR1) .NE. 0) THEN
         CALL XRETUR
C
C --- SUBROUTINE STATEMENT
C
      ELSEIF (INDEX(CARD,SUBR) .NE. 0) THEN
         IF (ASSURE('SUBROU')) THEN
            CALL SUBPRO ( 1, SPEC, NSPEC )
         ELSE
            WRITE(7,900) CARD
         ENDIF
C
C --- FUNCTION STATEMENT
C
      ELSEIF (INDEX(CARD,FUNC) .NE. 0) THEN
         IF (FASSUR('FUNCTI')) THEN
            CALL SUBPRO ( 2, SPEC, NSPEC )
         ELSE
            WRITE(7,900) CARD
         ENDIF
C
C --- ENTRY STATEMENT
C
      ELSEIF (INDEX(CARD,ENTR) .NE. 0) THEN
         IF (ASSURE('ENTRY')) THEN
            CALL SUBPRO ( 3, SPEC, NSPEC )
         ELSE
            WRITE(7,900) CARD
         ENDIF
C
C --- STOP STATEMENT
C
      ELSEIF (INDEX(CARD,STP) .NE. 0) THEN
         IF (ASSURE('STOP')) THEN
            CALL XSTOP
         ELSE
            WRITE(7,900) CARD
         ENDIF
C
C --- CONDITIONAL STOP STATEMENT
C
      ELSEIF (INDEX(CARD,STP1) .NE. 0) THEN
         CALL XSTOP
C
C --- END STATEMENT
C
      ELSEIF (VERIFY(CARD(6:72),'END ')) THEN
         CALL XEND
C
C --- ALL OTHER STATEMENTS
C
      ELSE
         IF (.NOT. MAIN)THEN
C
C -------- CHECK TO SEE IF IT IS NON-EXECUTABLE
C
            DO 50 I = 1,NSPEC
               IF (INDEX(CARD,SPEC(I)) .NE. 0) THEN
55                WRITE ( 7, 900 )CARD
                  CALL GETCRD
                  IF ( COLUMN(6) .EQ. ' ') GO TO 35
                  GO TO 55
               ENDIF
50             CONTINUE
C
C--- AN EXECUTABLE STATEMENT HAS BEEN FOUND
C
            MAIN = .TRUE.
            WRITE ( 7, 910 )
         ENDIF
         WRITE ( 7, 900 )CARD
      ENDIF
      GO TO 30
100   WRITE ( 6, 920 )
      STOP
900   FORMAT ( A80 )
910   FORMAT ( '      CALL QQINIT' )
920   FORMAT ( ' ****** ERROR... UNABLE TO OPEN OUTPUT FILE.')
      END
C
C---END MAIN(TRACER)
C
      SUBROUTINE OPTION
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          OPTION           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          GET OPTIONS
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM EXTRACTS THE RUN-TIME OPTIONS
C*          FROM THE FIRST CARD OF THE PROGRAM FILE.
C*          IF NO OPTIONS ARE THERE, THE DEFAULTS ARE USED.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          4 - OPTIONS INPUT
C*          6 - OPTIONS PROMPT AND ECHO
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION II.1     05/15/84
C*
C*     CHANGE HISTORY :
C*          05/15/84     NUM INITIALIZED
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *1 DIGIT
      CHARACTER *80 PARM, CARD
      LOGICAL LTIME, LTRACE, LINDEX
C
      LTIME  = .TRUE.
      LTRACE = .FALSE.
      LINDEX = .FALSE.
      NUNIT  = 6
      NUM    = 1
      OPEN (4,STATUS='OLD')
      READ (4,900,END=1000)PARM
      IF (INDEX(PARM,'TIME') .NE. 0) THEN
         IF (INDEX(PARM,'NOTIME') .NE. 0) LTIME = .FALSE.
      ENDIF
      IF (INDEX(PARM,'TRACE') .NE. 0) THEN
         IF (INDEX(PARM,'NOTRACE') .EQ. 0) LTRACE = .TRUE.
      ENDIF
C
C --- INDEX IS ALWAYS .FALSE. IN THE VAX VERSION
C
C      IF (INDEX(PARM,'INDEX') .NE. 0) THEN
C         IF (INDEX(PARM,'NOINDEX') .EQ. 0) LINDEX = .TRUE.
C      ENDIF
C
      IU = INDEX(PARM,'UNIT=')
      IF (IU .NE. 0) THEN
         IU = IU + 5
         DIGIT = PARM(IU:IU)
         IU = ICHAR(DIGIT) - ICHAR('0')
         IF ((IU .GT. 0) .AND. (IU .LT. 10)) NUNIT = IU
      ENDIF
1000  RETURN
900   FORMAT( A80 )
      END
C
C---END OPTION
C
      SUBROUTINE SUBPRO ( ITYPE, SPEC, NSPEC )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          SUBPRO           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          SUBPROGRAM
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM DOES THE PROCESSING REQUIRED
C*          WHEN A NEW SUBPROGRAM IS ENCOUNTERED IN THE
C*          FORTRAN CODE.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          ITYP -  =1 FOR SUBROUTINE
C*                  =2 FOR FUNCTION
C*                  =3 FOR ENTRY
C*          SPEC  - LIST OF FORTRAN SPECIFICATION KEYWORDS
C*          NSPEC - NUMBER OF ENTRIES IN 'SPEC'
C*
C*     OUTPUT ARGUMENTS :
C*         NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          7 - INSTRUMENTED SOURCE CODE OUTPUT
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NAMEX, MATCHR, GETCRD,INDEX
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD
      CHARACTER *6 SPEC(NSPEC)
      CHARACTER *1 COLUMN(80)
      CHARACTER *6 NAME
      LOGICAL LTIME, LTRACE, LINDEX, PUTRET, PUTSTP
      EQUIVALENCE (COLUMN(1),CARD)
C
      IF (ITYPE .NE. 3) CALL NAMEX(ITYPE,NAME)
C
C --- ENTRIES ARE ADDED TO THE SUBPROGRAM STATISTICS...
C
      CALL MATCHR ( NAME )
      IF (ITYPE .EQ. 3) THEN
         WRITE ( 7, 900 )
         WRITE ( 7, 910 )CARD
         WRITE ( 7, 920 ) NUM
         RETURN
      ENDIF
      PUTSTP = .FALSE.
      PUTRET = .FALSE.
10    WRITE ( 7, 910 )CARD
      CALL GETCRD
C
C --- CHECK FOR CONTINUATION OF SUBPROGRAM CARD
C
      IF (COLUMN(6) .NE. ' ') GO TO 10
C
C --- SKIP SPECIFICATION CARDS
C
30    DO 60 I = 1, NSPEC
         IF (INDEX(CARD,SPEC(I)) .NE. 0) THEN
40          WRITE ( 7, 910 )CARD
            CALL GETCRD
            IF (COLUMN(6) .EQ. ' ') GO TO 30
            GO TO 40
         ENDIF
60    CONTINUE
C
C --- FIRST EXECUTABLE STATEMENT OF SUBPROGRAM FOUND
C
      WRITE ( 7, 920 ) NUM
      WRITE ( 7, 910 ) CARD
      RETURN
900   FORMAT ('      GO TO 99997' )
910   FORMAT ( A80 )
920   FORMAT ( '      CALL QQIN (',I3,')' )
      END
C
C---END SUBPRO
C
      SUBROUTINE XSTOP
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          XSTOP            **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          STOP STATEMENT
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM DOES THE PROCESSING REQUIRED
C*          WHEN A STOP STATEMENT IS ENCOUNTERED IN THE
C*          FORTRAN CODE.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          7 - INSTRUMENTED SOURCE CODE OUTPUT
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*         INDEX
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD, CARD1
      LOGICAL LTIME, LTRACE, LINDEX, PUTSTP, PUTRET
C
      CARD1 = ' '
      I = INDEX(CARD,'STOP ')
      IF (I .GT. 61) THEN
         CARD1(1:I-1) = CARD(1:I-1)
         WRITE(7,900)CARD1
         WRITE(7,910)
      ELSE
         CARD1(1:I+10) = CARD(1:I-1)//'GO TO 99999'
         WRITE(7,900)CARD1
      ENDIF
C
C --- SIGNAL 'XEND' THAT A STOP STATEMENT WAS REPLACED
C
      PUTSTP = .TRUE.
      RETURN
900   FORMAT(A80)
910   FORMAT('     $ GO TO 99999')
      END
C
C---END XSTOP
C
      SUBROUTINE XRETUR
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          XRETUR           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          RETURN STATEMENT
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM DOES THE PROCESSING REQUIRED
C*          WHEN A RETURN STATEMENT IS ENCOUNTERED IN THE
C*          FORTRAN CODE.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          7 - INSTRUMENTED SOURCE CODE OUTPUT
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*         INDEX
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD, CARD1
      LOGICAL LTIME, LTRACE, LINDEX, PUTRET, PUTSTP
C
      CARD1 = ' '
      I = INDEX(CARD,'RETURN')
      IF (I .GT. 61) THEN
         CARD1(1:I-1) = CARD(1:I-1)
         WRITE(7,900)CARD1
         WRITE(7,910)
      ELSE
         CARD1(1:I+10) = CARD(1:I-1)//'GO TO 99998'
         WRITE(7,900)CARD1
      ENDIF
C
C --- SIGNAL 'XEND' THAT A RETURN STATEMENT WAS REPLACED
C
      PUTRET = .TRUE.
      RETURN
900   FORMAT(A80)
910   FORMAT('     $ GO TO 99998')
      END
C
C---END XRETUR
C
      SUBROUTINE XEND
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          XEND             **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          END STATEMENT
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM DOES THE PROCESSING REQUIRED
C*          WHEN AN END STATEMENT IS ENCOUNTERED IN THE
C*          FORTRAN CODE.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*         NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          7 - INSTRUMENTED SOURCE CODE OUTPUT
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION II.0     01/27/84
C*
C*     CHANGE HISTORY :
C*          01/27/84     VAX VERSION
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD
      LOGICAL LTIME, LTRACE, LINDEX, PUTSTP, PUTRET
C
      IF ( PUTSTP ) THEN
         IF ( NUM .EQ. 1 ) THEN
            WRITE(7,900)
         ELSE
            WRITE(7,905) NUM
         ENDIF
      ENDIF
      IF ( PUTRET ) WRITE(7,910) NUM
      WRITE(7,930)CARD
      PUTSTP = .FALSE.
      PUTRET = .FALSE.
      RETURN
900   FORMAT ('99999 CALL QQSUM',/,
     $        '      STOP')
905   FORMAT ('99999 CALL QQOUT(',I3,')',/,
     $        '      CALL QQSUM',/,
     $        '      STOP')
910   FORMAT ('99998 CALL QQOUT(',I3,')',/,
     $        '      RETURN' )
C920   FORMAT ('      DEBUG SUBCHK')
930   FORMAT ( A80 )
      END
C
C---END XEND
C
      SUBROUTINE NAMEX ( ITYPE, NAME )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          NAMEX            **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          NAME EXTRACTOR
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM EXTRACTS THE NAME OF THE SUBPROGRAM
C*          IN THE FORTRAN CODE.
C*
C*     METHODOLOGY :
C*          SEARCH FOR THE FIRST NON-BLANK CHARACTER AFTER
C*          THE SUBPROGRAM DEFINITION STATEMENT. THE NAME ENDS
C*          AFTER 6 CHARACTERS OR A LEFT-PARENTHESIS.
C*
C*     INPUT ARGUMENTS :
C*          ITYPE -  =1 FOR SUBROUTINE
C*                   =2 FOR FUNCTION
C*                   =3 FOR ENTRY
C*
C*     OUTPUT ARGUMENTS :
C*          NAME - THE SUBPROGRAM NAME
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC
C*
C*     FILE REFERENCES :
C*          NONE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*         INDEX
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD
      CHARACTER *6 NAME
      CHARACTER *1 COLUMN(80)
      LOGICAL LTIME, LTRACE, LINDEX, PUTSTP, PUTRET
      EQUIVALENCE (COLUMN(1),CARD)
C
      IF (ITYPE .EQ. 1) THEN
         N = INDEX(CARD,'SUBROU') + 10
      ELSE
         N = INDEX(CARD,'FUNCTI') + 9
      ENDIF
C
C --- SKIP LEADING BLANKS
C
10    IF (COLUMN(N) .EQ. ' ') THEN
         N = N + 1
         IF (N .GT. 72) THEN
            WRITE(7,900)CARD
            CALL GETCRD
            IF (COLUMN(6) .NE. ' ')THEN
               WRITE(6,910)
               NAME = '      '
               RETURN
            ENDIF
            N = 7
            GO TO 10
         ENDIF
      ENDIF
C
C --- THE NAME ENDS AFTER 6 CHARACTERS OR A LEFT PARENTHESIS
C
      DO 20 I = 1,6
         NI = N+I
         IF ((COLUMN(NI) .EQ. ' ') .OR. (COLUMN(NI) .EQ. '('))GO TO 30
20       CONTINUE
30    NAME = CARD(N:NI-1)
      RETURN
900   FORMAT ( A80 )
910   FORMAT ('0 **** ERROR, END-OF-STATEMENT UNEXPECTEDLY ENCOUNTERED')
      END
C
C---END NAMEX
C
      SUBROUTINE MATCHR ( NAME )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          MATCHR           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          MATCH NAMES
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM ADDS THE SUBROUTINE NAME TO THE LIST.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NAME - THE NAME OF THE SUBPROGRAM
C*
C*     OUTPUT ARGUMENTS :
C*         NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          SWITCH, MISC, MATCH
C*
C*     FILE REFERENCES :
C*          NONE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      COMMON / MATCH  / NAMES(500), NNAMES
      CHARACTER *6 NAMES, NAME
      CHARACTER *80 CARD
      LOGICAL LTIME, LTRACE, LINDEX, PUTRET, PUTSTP
C
      IF (NNAMES .EQ. 500) THEN
         WRITE(6,900)
         RETURN
      ENDIF
      NNAMES = NNAMES + 1
      NAMES(NNAMES) = NAME
      NUM = NNAMES
      RETURN
900   FORMAT('0 ***** ERROR, NUMBER OF SUBPROGRAMS EXCEEDED')
      END
C
C---END MATCHR
C
      SUBROUTINE FOROUT
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          FOROUT           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          FORTRAN OUTPUT
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          THIS SUBPROGRAM OUTPUTS THE APPROPRIATE FORTRAN
C*          CODE IN LIGHT OF THE OPTIONS CHOSEN.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          NONE
C*
C*     FILE REFERENCES :
C*          7 - OUTPUT OF RUN-TIME ROUTINES
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     10/04/83
C*
C*     CHANGE HISTORY :
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      COMMON / MATCH  / NAMES(500), NNAMES
      CHARACTER *80 CARD
      CHARACTER *72 LINE
      CHARACTER *1 LIN(72)
      CHARACTER *6 NAMES
      LOGICAL LTIME, LTRACE, LINDEX, PUTRET, PUTSTP
      EQUIVALENCE (LIN(1),LINE)
C
      IF ( NUM .EQ. 0 )NUM = 1
      WRITE ( 7, 900 )NUM, NUM, NUM, NUNIT
      IF ( LTIME ) WRITE ( 7, 910 )
      WRITE ( 7, 920 )NUM, NUM, NUM
      IF ( LTIME ) WRITE ( 7, 930 )
      IF ( LTRACE ) WRITE ( 7, 940 )
      WRITE ( 7, 950 )NUM, NUM, NUM
      IF ( LTIME ) WRITE ( 7, 960 )
      WRITE ( 7, 970 )
      IF ( LTRACE ) WRITE ( 7, 980 )
      WRITE ( 7, 990 )NUM, NUM, NUM
      IF ( LTIME ) WRITE ( 7, 9000 )
      WRITE ( 7, 9010 )
      IF ( LTIME ) WRITE ( 7, 9020 )NUM, NUM
      WRITE ( 7, 9030 )NUM, NUM, NUM, NUM
C
C --- BUILD DATA STATEMENT FOR NAMES
C
      NPART = MOD(NNAMES,7)
      NFULL = (NNAMES - NPART)/7
      NCOUNT = 1
      IF (NFULL .GE. 1) THEN
         DO 100 I = 1, NFULL
            LINE = '$
     $              '
            K = 3
            DO 50 J = 1,7
               LINE(K:K+9) = ''''//NAMES(NCOUNT)//''','
               K = K + 9
               NCOUNT = NCOUNT + 1
50             CONTINUE
            IF ((I .EQ. NFULL) .AND. (NPART .EQ. 0))LINE(K-1:K-1) = '/'
            WRITE(7,9040)LINE
100         CONTINUE
      ENDIF
C
C --- CONSTRUCT PARTIAL LINE
C
      IF (NPART .GT. 0) THEN
         LINE = '$
     $              '
         K = 3
         DO 200 I = 1, NPART
            LINE(K:K+9) = ',''' // NAMES(NCOUNT) // ''''
            K = K + 9
            NCOUNT = NCOUNT + 1
200         CONTINUE
         LIN(3) = ' '
         LINE(K:K) = '/'
         WRITE(7,9040)LINE
      ENDIF
      WRITE(7,9050)
      RETURN
900   FORMAT ('      SUBROUTINE QQINIT',/,
     $        '      COMMON / QQCOM / NAMES(',I3,'), TIMES(',I3,'),',/,
     $ '     $ NCALLS(',I3,'),TIME(40),TRACE(40),NNUM(40),NT,NPRINT',/,
     $        '      CHARACTER *6 NAMES, TRACE',/,
     $        '      NPRINT = ',I1,/,
     $        '      NT     = 1' )
910   FORMAT ('      STATUS = LIB$INIT_TIMER()',/,
     $        '      STATUS = LIB$STAT_TIMER(2,ITIME,)',/,
     $        '      TIME(1) = FLOAT(ITIME)',/,
     $        '      NNUM(1) = 1')
920   FORMAT ('      RETURN',/,
     $        '      END',/,
     $        '      SUBROUTINE QQIN(N)',/,
     $        '      COMMON / QQCOM / NAMES(',I3,'), TIMES(',I3,'),',/,
     $ '     $ NCALLS(',I3,'),TIME(40),TRACE(40),NNUM(40),NT,NPRINT',/,
     $        '      CHARACTER *6 NAMES, TRACE',/,
     $        '      NT=NT + 1' )
930   FORMAT ('      STATUS = LIB$STAT_TIMER(2,ITIME,)',/,
     $        '      TIME(NT) = FLOAT(ITIME)',/,
     $        '      NCALLS(N) = NCALLS(N) + 1',/,
     $        '      NNUM(NT) = N',/,
     $ '      TIMES(NNUM(NT-1))=TIMES(NNUM(NT-1))+TIME(NT)-TIME(NT-1)')
940   FORMAT ('      TRACE(NT) = NAMES(N)',/,
     $        '      WRITE(NPRINT,900)(TRACE(I),I=1,NT)',/,
     $        '900   FORMAT(''0---- TRACEBACK ----'',',/,
     $        '     $  4(/,5X,10(A6,3X)))' )
950   FORMAT ('      RETURN',/,
     $        '      END',/,
     $        '      SUBROUTINE QQOUT(N)',/,
     $        '      COMMON / QQCOM / NAMES(',I3,'), TIMES(',I3,'),',/,
     $ '     $ NCALLS(',I3,'),TIME(40),TRACE(40),NNUM(40),NT,NPRINT',/,
     $        '      CHARACTER *6 NAMES, TRACE' )
960   FORMAT ('      STATUS = LIB$STAT_TIMER(2,ITIME,)',/,
     $        '      TOTAL = FLOAT(ITIME)',/,
     $        '      TIMES(N) = TIMES(N)+TOTAL-TIME(NT)')
970   FORMAT ('      NT = NT - 1',/,
     $        '      IF(NT.GT.0)TIME(NT)=TOTAL')
980   FORMAT ('      WRITE (NPRINT,900)(TRACE(I),I=1,NT)',/,
     $        '900   FORMAT ('' -----  TRACEBACK  ----'',/,',/,
     $        '     $ 4(/,5X,10(A6,3X)))')
990   FORMAT ('      RETURN',/,
     $        '      END',/,
     $        '      SUBROUTINE QQSUM',/,
     $        '      COMMON / QQCOM / NAMES(',I3,'), TIMES(',I3,'),',/,
     $ '     $ NCALLS(',I3,'),TIME(40),TRACE(40),NNUM(40),NT,NPRINT',/,
     $        '      CHARACTER *6 NAMES, TRACE',/,
     $        '      CHARACTER *1 STAR',/,
     $        '      DATA STAR/''*''/' )
9000  FORMAT ('      STATUS = LIB$STAT_TIMER(2,ITIME,)',/,
     $        '      TOTAL = FLOAT(ITIME)',/,
     $        '      TIMES(1) = TIMES(1) + TOTAL - TIME(1)' )
9010  FORMAT ('      WRITE(NPRINT,900)',/,
     $        '900   FORMAT(''1'',10X,',/,
     $        '     $ ''******** PROCESSING ENDED AT STOP *******'' ',
     $        ',/////)' )
9020  FORMAT ('      WRITE(NPRINT,930)',/,
     $        '930   FORMAT('' SUBPROGRAM '',1X,''NO. OF'',2X,',/,
     $        '     $ ''CPU TIME'',10X,''PERCENT OF'',/,',/,
     $        '     $ '' NAME'',8X,''CALLS'',3X,''(SEC)'',13X,',/,
     $        '     $ ''TOTAL'' ,/)',/,
     $        '      TOTAL = 0.0',/,
     $        '      DO 5 I = 1,',I3,/,
     $        '         TIMES(I) = TIMES(I)/100.0',/,
     $        '         TOTAL = TOTAL + TIMES(I)',/,
     $        '5        CONTINUE',/,
     $        '      DO 10 I = 1,',I3,/,
     $        '         NUMB = 100*(TIMES(I)/TOTAL)',/,
     $        '         WRITE(NPRINT,940)NAMES(I),NCALLS(I),TIMES(I)',
     $                  ',(STAR,J=1,NUMB)',/,
     $        '940      FORMAT(1X,A6,3X,I6,3X,F10.4,2X,100A1)',/,
     $        '10       CONTINUE',/,
     $        '      WRITE(NPRINT,945)TOTAL',/,
     $        '945   FORMAT(/,'' TOTAL '',12X,F10.4)')
9030  FORMAT ('      RETURN',/,
     $        '      END',/,
     $        '      BLOCK DATA',/,
     $        '      COMMON / QQCOM / NAMES(',I3,'), TIMES(',I3,'),',/,
     $ '     $ NCALLS(',I3,'),TIME(40),TRACE(40),NNUM(40),NT,NPRINT',/,
     $        '      CHARACTER *6 NAMES, TRACE',/,
     $        '      DATA TIME/40*0.0/, TIMES/',I3,'*0.0/',/,
     $        '      DATA TRACE(1)/''MAIN  ''/',/,
     $        '      DATA NAMES/' )
9040  FORMAT (5X,A72)
9050  FORMAT ('      END')
      END
C
C---END FOROUT
C
      SUBROUTINE GETCRD
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          GETCRD           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          GET CARD
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415)965-5578
C*
C*     PURPOSE :
C*          READ THE NEXT CARD FROM THE INPUT FILE.
C*          DO PROGRAM FINALIZATION ON END-OF-FILE.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          NONE
C*
C*     OUTPUT ARGUMENTS :
C*          NONE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          MISC
C*
C*     FILE REFERENCES :
C*          2 - DIRECTORY OF SOURCE CODE
C*          5 - ORIGINAL SOURCE CODE INPUT
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION II.2     30 JULY 1985
C*
C*     CHANGE HISTORY :
C*          07/30/85     FILENAME ADDED TO PRINTOUT
C*          05/15/84     TIME AND DATE ADDED TO PRINTOUT
C*          10/04/83     INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / SWITCH / LTIME, LTRACE, LINDEX
      COMMON / MISC   / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *97 DIREC
      CHARACTER *80 CARD
      CHARACTER *40 OPS
      CHARACTER *9 CDATE
      CHARACTER *8 CTIME
      CHARACTER *1 COLUMN(80)
      LOGICAL PUTSTP, PUTRET, LTIME, LTRACE, LINDEX
      EQUIVALENCE (COLUMN(1),CARD)
C
10    READ ( 5, 900, END=1000 )CARD
      IF ((COLUMN(1) .EQ. 'C') .OR. (COLUMN(1) .EQ. '*')) GO TO 10
      RETURN
C
C --- PUT IN THE MONITORING ROUTINES
C
1000  CALL FOROUT
C
C --- TRACER PRINTOUT
C
      DIREC = ' '
      DO 1015 I=1,4
         READ(2,920,END=1010,ERR=1010) DIREC
1015     CONTINUE
      CALL CENTER ( DIREC )
1010  CALL DATE(CDATE)
      CALL TIME(CTIME)
      OPS = 'NOTIME, NOTRACE, UNIT=6'
      IF ( LTIME ) OPS(1:2) = '  '
      IF ( LTRACE ) OPS(9:10) = '  '
      IF (NUNIT .NE. 6) OPS(23:23) = CHAR(ICHAR('0')+NUNIT)
      WRITE(6,905)DIREC,CTIME(1:5),CDATE,OPS
      WRITE(6,910)
      STOP
900   FORMAT(A80)
905   FORMAT(//,
     $ ' ',99('*'),/,
     $ ' *',T100,'*',/,
     $ ' *      ------  TRACER',T60,
     $ 'VERSION II.1    15 JUNE 1984  ------    *',/,
     $ 2(' *',T100,'*',/),
     $ ' *',A97,'*',/,
     $ ' *                   ------  PROGRAM INSTRUMENTED AT ',A5,
     $ ' ',A9,'  ------',T100,'*',/,
     $ 2(' *',T100,'*',/),
     $ ' *                             OPTIONS = ',A40,T100,'*',/,
     $ ' *',T100,'*',/,' ',99('*'),////)
910   FORMAT(///,T30,' *****                                *****',/,
     $           T30,' *****  AN INSTRUMENTED PROGRAM HAS   *****',/,
     $           T30,' *****  BEEN CREATED AS "BUGOUT.FOR"  *****',/,
     $           T30,' *****  AND COMPILED TO "BUGOUT.OBJ". *****',/,
     $           T30,' *****  YOU MUST LINK AND RUN IT TO   *****',/,
     $           T30,' *****  GET YOUR TIME/TRACE INFO.     *****',/,
     $           T30' *****                                *****')
920   FORMAT(A)
      END
C
C---END GETCRD
C
      LOGICAL FUNCTION VERIFY ( A, B )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          VERIFY           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          VERIFY
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          TR18
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CA 94035
C*          415-965-6235
C*
C*     PURPOSE :
C*          THIS FUNCTION IS TRUE IF EVERY CHARACTER IN THE FIRST
C*          ARGUMENT IS ALSO IN THE SECOND ARGUMENT.
C*
C*     METHODOLOGY :
C*          NA
C*
C*     INPUT ARGUMENTS :
C*          A - STRING TO BE VERIFIED
C*          B - STRING CONTAINING ALLOWABLE CHARACTERS
C*
C*     OUTPUT ARGUMENTS :
C*          VERIFY - TRUE IF ALL CHARACTERS IN 'A' ARE IN 'B'
C*                   FALSE OTHERWISE
C*
C*     INTERNAL WORK AREAS :
C*          NONE
C*
C*     COMMON BLOCKS :
C*          NONE
C*
C*     FILE REFERENCES :
C*          NONE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          LEN
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     11/17/82
C*
C*     CHANGE HISTORY :
C*          11/17/82     INITIAL VERSION
C*
C***********************************************************************
C*
      CHARACTER *(*) A,B
C
      VERIFY = .FALSE.
      LB = LEN(B)
      DO 200 I = 1, LEN(A)
          DO 100 J = 1, LB
             IF ( B(J:J) .EQ. A(I:I)) GO TO 200
  100        CONTINUE
          RETURN
  200     CONTINUE
      VERIFY = .TRUE.
      RETURN
      END
C
C---END VERIFY
C
      LOGICAL FUNCTION ASSURE ( STRING )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          ASSURE           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          ASSURE STATEMENT TYPE
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CA  94035
C*          (415) 965-5578
C*
C*     PURPOSE :
C*          TO ASSURE THAT THE INDEX OF THE STATEMENT KEYWORD WAS
C*          NOT IN A LITERAL FIELD.
C*
C*     METHODOLOGY :
C*          REMOVE SPACES AND CHECK FOR THE KEYWORD IN THE FIRST
C*          COLUMNS OF THE RESULTING STRING.
C*
C*     INPUT ARGUMENTS :
C*          STRING - THE STATEMENT IDENTIFICATION STRING(EG, 'SUBROUTINE')
C*
C*     OUTPUT VALUE :
C*          TRUE IF THE STRING WAS FOUND FIRST IN THE STATEMENT...
C*           FALSE OTHERWISE.
C*
C*     INTERNAL WORK AREAS :
C*          WORK - HOLDS THE PACKED STRING
C*
C*     COMMON BLOCKS :
C*          MISC
C*
C*     FILE REFERENCES :
C*          NONE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.1     22-APRIL-85
C*
C*     CHANGE HISTORY :
C*          22-APR-85    CHECKING OF 'RETURN' AND 'STOP' IMPROVED
C*          18-SEP-84    INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / MISC  / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD
      LOGICAL PUTSTP, PUTRET
      CHARACTER *(*) STRING
      CHARACTER *80 WORK
C
      ICPTR = 6
      IWPTR = 0
      WORK  = CARD
C
C --- PACK NON-BLANK CHARACTERS INTO WORK
C
      CALL BLANKS ( WORK, LL )
C
C --- CHECK TO SEE IF THE KEYWORD WAS FOUND
C
      IF ( STRING(1:4) .EQ. WORK(1:4)) THEN
         ASSURE = .TRUE.
         RETURN
      ENDIF
C
C --- FOR 'RETURN' AND 'STOP' ... CHECK FOR 'IF (LOGICAL) STOP'
C
      ASSURE = .FALSE.
      IF (STRING .EQ. 'RETURN') THEN
         IF (INDEX(WORK,')RETURN') .NE. 0) THEN
            ASSURE = .TRUE.
            RETURN
         ENDIF
      ELSE IF (STRING .EQ. 'STOP') THEN
         IF (INDEX(WORK,')STOP ') .NE. 0) ASSURE = .TRUE.
      ENDIF
      RETURN
      END
C
C---END ASSURE
C
      LOGICAL FUNCTION FASSUR ( STRING )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          FASSUR           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          ASSURE STATEMENT TYPE
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 207-5
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CA  94035
C*          (415) 965-5578
C*
C*     PURPOSE :
C*          TO ASSURE THAT THE INDEX OF THE STATEMENT KEYWORD WAS
C*          NOT IN A LITERAL FIELD.
C*
C*     METHODOLOGY :
C*          REMOVE SPACES AND CHECK FOR THE KEYWORD IN THE FIRST
C*          COLUMNS OF THE RESULTING STRING.
C*
C*     INPUT ARGUMENTS :
C*          STRING - THE STATEMENT IDENTIFICATION STRING(EG, 'FUNCTION')
C*
C*     OUTPUT VALUE :
C*          TRUE IF THE STRING WAS FOUND FIRST IN THE STATEMENT...
C*           FALSE OTHERWISE.
C*
C*     INTERNAL WORK AREAS :
C*          WORK - HOLDS THE PACKED STRING
C*
C*     COMMON BLOCKS :
C*          MISC
C*
C*     FILE REFERENCES :
C*          NONE
C*
C*     DATA BASE ACCESS :
C*          NONE
C*
C*     SUBPROGRAM REFERENCES :
C*          NONE
C*
C*     ERROR PROCESSING :
C*          NONE
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          NONE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NONE
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     18-SEP-84
C*
C*     CHANGE HISTORY :
C*          18-SEP-84    INITIAL VERSION
C*
C***********************************************************************
C*
      COMMON / MISC  / NUM, NUNIT, CARD, PUTSTP, PUTRET
      CHARACTER *80 CARD
      LOGICAL PUTSTP, PUTRET
      CHARACTER *(*) STRING
      CHARACTER *4 WORK
C
      ICPTR = 6
      IWPTR = 0
      WORK = '    '
C
C --- PACK NON-BLANK CHARACTERS INTO WORK
C
10    ICPTR = ICPTR + 1
      IF (CARD(ICPTR:ICPTR) .NE. ' ') THEN
         IWPTR = IWPTR + 1
         WORK(IWPTR:IWPTR) = CARD(ICPTR:ICPTR)
      ENDIF
C
C --- CHECK TO SEE IF THE KEYWORD WAS FOUND
C
      IF ((IWPTR .LT. 4) .AND. (ICPTR .LT. 71))GO TO 10
      FASSUR = .FALSE.
      IF ((WORK .EQ. 'FUNC') .OR. (WORK .EQ. 'LOGI') .OR.
     $    (WORK .EQ. 'INTE') .OR. (WORK .EQ. 'REAL') .OR.
     $    (WORK .EQ. 'DOUB') .OR. (WORK .EQ. 'COMP') .OR.
     $    (WORK .EQ. 'CHAR')) FASSUR = .TRUE.
      RETURN
      END
C
C---END FASSUR
C
      BLOCK DATA
      COMMON / MATCH / NAMES(500), NNAMES
      CHARACTER *6 NAMES
C
      DATA NNAMES/1/
      DATA NAMES(1)/'MAIN  '/
      END
C
C---END BLOCK DATA
C
C----END FILE
C

ext: for


text:
C$Procedure      ZZEKTR31 ( EK tree, 3-1 merge )

      SUBROUTINE ZZEKTR31 ( HANDLE, TREE )

C$ Abstract
C
C     Execute a 3-1 merge:  move the contents of two children into
C     the root node and delete the children.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     EK
C
C$ Keywords
C
C     EK
C     PRIVATE
C
C$ Declarations

      INCLUDE 'ektree.inc'
      INCLUDE 'ekpage.inc'
      INCLUDE 'ektype.inc'

      INTEGER               HANDLE
      INTEGER               TREE

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     TREE       I   Root of tree.
C
C$ Detailed_Input
C
C     HANDLE         is a file handle of an EK open for write access.
C
C     TREE           is the root node number of the tree of interest.
C
C$ Detailed_Output
C
C     None.  See $Particulars for a description of the effect of this
C     routine.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If HANDLE is invalid, the error will be diagnosed by routines
C         called by this routine.  The file will not be modified.
C
C     2)  If an I/O error occurs while reading the indicated file, the
C         error will be diagnosed by routines called by this routine.
C
C     3)  If there is not exactly 1 key in the root at the time this
C         routine is called, the error SPICE(BUG) is signalled.
C
C$ Files
C
C     See the EK Required Reading for a discussion of the EK file
C     format.
C
C$ Particulars
C
C     Deletions from an EK tree start at a leaf node.  If the node
C     underflows, the EK system attempts to shuffle keys at the leaf
C     level to resolve the underflow.  That attempt failing, the system
C     delegates the problem upward to the next higher level.  Underflow
C     may occur there as well; if it does, the problem gets passed
C     upward again.  If the root has only two children and one of these
C     underflows, the system reduces the height of the tree by
C     executing what's called a `3-1' merge:  the root loses its two
C     children, and all of the keys in the children are moved into
C     the root.  The former grandchildren of the root become
C     children of the root.
C
C     A tree is eligible for a 3-1 merge only if the root has exactly
C     two children, and the sum of the key counts of the children
C     constitutes an underflow of 1 key:  that is, the sum is
C
C        2*MNKEYC - 1
C
C     After the 3-1 merge, the tree is balanced and all invariants
C     relating to key counts are restored.
C
C     The tree grows shorter by one level as a result of a 3-1 merge;
C     this is the only circumstance under which the tree grows shorter.
C
C     Below are the gory details concerning the actions of this routine.
C     All of the parameters referred to here (in capital letters) are
C     defined in the include file ektree.inc.
C
C     In a 3-1 merge:
C
C
C        - The keys of the left child are moved into the root.  These
C          become the leftmost MNKEYC or MNKEYC-1 keys of the root,
C          depending on whether the underflow occurred in the left
C          child.
C
C        - The data values associated with the keys of the left child
C          of the root are moved into the root along with the keys.
C
C        - The left child pointers associated with the keys of the left
C          child of the root are moved into the root along with the
C          keys.
C
C        - The last right child pointer in the left child of the root
C          the root is moved to location NLEFT+1 in the child pointer
C          array of the root, where NLEFT is the number of keys in
C          the former left child.  This pointer overwrites the root's
C          pointer to the left child.
C
C        - The keys of the right child are moved into the root.  These
C          become the rightmost MNKEYC or MNKEYC-1 keys of the root,
C          depending on whether the underflow occurred in the right
C          child.
C
C        - The data values associated with the keys of the right child
C          of the root are moved into the root along with the keys.
C
C        - The left child pointers associated with the keys of the right
C          child of the root are moved into the root along with the
C          keys.  The first of these pointers overwrites the root's
C          pointer to the right child.
C
C        - The last right child pointer in the right child of the root
C          the root is moved to location 2*MNKEYC+1 in the child pointer
C          array of the root.
C
C        - The former children of the root are deleted.
C
C     As the above list shows, the root contains the maximum allowed
C     number of keys after a 3-1 merge.  This is because
C
C        MXKEYR  =  MXKIDR - 1
C
C                =  2 * ( (2*MXKIDC - 2)/3 )
C
C                =  2 * ( (2*MXKIDC + 1)/3  - 1 )
C
C                =  2 * ( MNKIDC - 1)
C
C                =  2 * MNKEYC
C
C     Our assumptions were that there was one key in the root and
C     that the sum of the key counts of the two children of the root
C     was
C
C        ( 2 * MNKEYC ) - 1
C
C     Thus the size constraints on the root node are met.
C
C$ Examples
C
C     See ZZEKTRDL.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 27-OCT-1995 (NJB)
C
C-&

C
C     Local variables
C
      INTEGER               C1PAGE ( PGSIZI )
      INTEGER               C2PAGE ( PGSIZI )
      INTEGER               CHILD  ( 2 )
      INTEGER               DELTA
      INTEGER               I
      INTEGER               MIDDLE
      INTEGER               NLKEYS
      INTEGER               NRKEYS
      INTEGER               ROOT
      INTEGER               RPAGE  ( PGSIZI )
      INTEGER               SUM

C
C     Use discovery check-in for speed.
C
      ROOT    =  TREE

      CALL ZZEKPGRI ( HANDLE, ROOT, RPAGE )

      NRKEYS  =  RPAGE ( TRNKR )

C
C     There must be exactly 1 key in the root.
C
      IF ( NRKEYS .NE. 1 ) THEN

         CALL CHKIN  ( 'ZZEKTR31'                                 )
         CALL SETMSG ( 'Number of keys in root = #; should be 1.' )
         CALL ERRINT ( '#',  NRKEYS                               )
         CALL SIGERR ( 'SPICE(BUG)'                               )
         CALL CHKOUT ( 'ZZEKTR31'                                 )
         RETURN

      END IF

C
C     Read in the child pages.  Get the key counts for these pages.
C
      CHILD(1)  =  RPAGE ( TRKIDR + 1 )
      CHILD(2)  =  RPAGE ( TRKIDR + 2 )

      CALL ZZEKPGRI ( HANDLE, CHILD(1), C1PAGE )
      CALL ZZEKPGRI ( HANDLE, CHILD(2), C2PAGE )

      NLKEYS    =  C1PAGE ( TRNKC )
      NRKEYS    =  C2PAGE ( TRNKC )
      SUM       =  NLKEYS + NRKEYS

C
C     The sum of the number of keys in the two input nodes must
C     sum exactly to value representing an underflow level of 1 key.
C
      IF (  SUM  .NE.  ( 2*MNKEYC - 1 )  ) THEN

         CALL CHKIN  ( 'ZZEKTR31'                                      )
         CALL SETMSG ( 'Number of keys in nodes LEFT = #; in RIGHT ' //
     .                 '= #; counts summing to # were expected.'       )
         CALL ERRINT ( '#',  NLKEYS                                    )
         CALL ERRINT ( '#',  NRKEYS                                    )
         CALL ERRINT ( '#',  2*MNKEYC-1                                )
         CALL SIGERR ( 'SPICE(BUG)'                                    )
         CALL CHKOUT ( 'ZZEKTR31'                                      )
         RETURN

      END IF

C
C     Shift the key and data pointer in the root to right to allow
C     insertion of NLKEYS new entries on the left.  The child pointers
C     need not be shifted; they'll be overwritten later.
C
      RPAGE (TRKEYR+NLKEYS+1)  =  RPAGE (TRKEYR+1)
      RPAGE (TRDATR+NLKEYS+1)  =  RPAGE (TRDATR+1)

C
C     Copy in the keys, data pointers, and child pointers from the
C     left child into the root.  The number of predecessors of the
C     new keys is unchanged by this operation.
C
      CALL MOVEI ( C1PAGE(TRKEYC+1), NLKEYS,     RPAGE(TRKEYR+1)  )
      CALL MOVEI ( C1PAGE(TRDATC+1), NLKEYS,     RPAGE(TRDATR+1)  )
      CALL MOVEI ( C1PAGE(TRKIDC+1), NLKEYS+1,   RPAGE(TRKIDR+1)  )

C
C     Copy in the keys, data pointers, and child pointers from the
C     right child into the root.  The number of predecessors of the
C     new keys is increased by the value of the last key already
C     present.
C
      MIDDLE  =  NLKEYS  +  1
      DELTA   =  RPAGE( TRKEYR + MIDDLE )

      DO I = 1, NRKEYS
         RPAGE( TRKEYR+MIDDLE+I )  =  C2PAGE(TRKEYC + I)  +  DELTA
      END DO

      CALL MOVEI ( C2PAGE(TRDATC+1), NRKEYS,    RPAGE(TRDATR+MIDDLE+1) )
      CALL MOVEI ( C2PAGE(TRKIDC+1), NRKEYS+1,  RPAGE(TRKIDR+MIDDLE+1) )

C
C     Now the root must be updated.  The root now contains
C     the maximum allowed number of keys.  The depth of the tree
C     has decreased, as well as the number of nodes in the tree.
C
      RPAGE ( TRNKR      )  =  MXKEYR
      RPAGE ( TRDPTH     )  =  RPAGE ( TRDPTH ) - 1
      RPAGE ( TRNNOD     )  =  RPAGE ( TRNNOD ) - 2

C
C     Write out the updated root.
C
      CALL ZZEKPGWI ( HANDLE, ROOT, RPAGE )

C
C     Free the pages occupied by the deleted children.
C
      DO I = 1, 2
         CALL ZZEKPGFR ( HANDLE, INT, CHILD(I)  )
      END DO

      RETURN
      END

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
c     # --------------------------------------------
c     # Default routines
c     #
c     # fclaw2d_fort_tag4refinement
c     # fclaw2d_fort_tag4coarsening
c     # fclaw2d_fort_interpolate2fine
c     # fclaw2d_fort_average2coarse
c     # --------------------------------------------

c     # We tag for coarsening if this coarsened patch isn't tagged for refinement
      subroutine square_tag4coarsening_wavelet(mx,my,mbc,meqn,
     &      xlower,ylower,dx,dy, blockno, q0, q1, q2, q3,
     &      coarsen_threshold, tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch
      integer blockno
      double precision xlower(0:3), ylower(0:3), dx, dy
      double precision coarsen_threshold
      double precision q0(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision q1(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision q2(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision q3(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer i,j, mq
      double precision qmin, qmax

c     # Assume that we will coarsen a family unless we find a grid
c     # that doesn't pass the coarsening test.
      tag_patch = 1
      mq = 1
      qmin = q0(1,1,mq)
      qmax = q0(1,1,mq)

c     # If we find that (qmax-qmin > coarsen_threshold) on any
c     # grid, we return immediately, since the family will then
c     # not be coarsened.

      call user_get_minmax_wavelet(mx,my,mbc,meqn,mq,q0,qmin,qmax,
     &      coarsen_threshold,tag_patch)
      if (tag_patch == 0) return

      call user_get_minmax_wavelet(mx,my,mbc,meqn,mq,q1,qmin,qmax,
     &      coarsen_threshold,tag_patch)
      if (tag_patch == 0) return

      call user_get_minmax_wavelet(mx,my,mbc,meqn,mq,q2,qmin,qmax,
     &      coarsen_threshold,tag_patch)
      if (tag_patch == 0) return

      call user_get_minmax_wavelet(mx,my,mbc,meqn,mq,q3,qmin,qmax,
     &      coarsen_threshold,tag_patch)

      end

      subroutine user_get_minmax_wavelet(mx,my,mbc,meqn,mq,q,
     &      qmin,qmax,coarsen_threshold,tag_patch)

      implicit none
      integer mx,my,mbc,meqn,mq,tag_patch
      double precision coarsen_threshold
      double precision qmin,qmax
      double precision q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

      integer initchoice
      common /initchoice_comm/ initchoice

      double precision qcoarse(1-mbc:mx+mbc, 1-mbc:my+mbc,meqn)
      double precision qfine(1-mbc:mx+mbc, 1-mbc:my+mbc,meqn)
      double precision areacoarse, areafine
      integer manifold, igrid

      integer i,j

      manifold = 0
      igrid = 0
      call wavelet_average2coarse(mx,my,mbc,meqn,
     &      q, qcoarse,areacoarse, areafine, manifold)

      call wavelet_interpolate2fine3
     &     (mx,my,mbc,meqn,qcoarse, qfine, areacoarse,
     &      areafine, manifold)

      do i = 1,mx
         do j = 1,my
             if (abs(q(i,j,1) - qfine(i,j,1)) .gt.
     &                coarsen_threshold) then
                 tag_patch = 0
                 return
            endif
         enddo
      enddo

      end

max_stars_repo_name: jbsnively/forestclaw

max_issues_repo_name: jbsnively/forestclaw

max_forks_repo_name: jbsnively/forestclaw


text:
          PROGRAM MAIN
          USE OMP_LIB
          IMPLICIT NONE

          INTEGER :: i, id, nthreads
          INTEGER, PARAMETER :: num_steps=100000000
          REAL*8 :: x, pi, sum, step
          REAL*8 :: start_time, run_time

          sum = 0.0

          step = 1.0 / num_steps

          CALL OMP_SET_NUM_THREADS(NTHREADS)
          start_time = OMP_GET_WTIME()

!$OMP PARALLEL PRIVATE(i,x)
!$OMP DO REDUCTION(+:sum)
          DO i = 1, num_steps
             x = (i - 0.5) * step
             sum = sum + 4.0 / (1.0 + x * x)
          ENDDO
!$OMP END DO
!$OMP END PARALLEL

          pi = step * sum
          run_time = OMP_GET_WTIME() - start_time
          WRITE(*,100) pi, run_time
100       FORMAT('pi is ',f15.8,' in ',f8.3,' secs')

          END PROGRAM MAIN

max_stars_repo_name: tgmattso/OmpCommonCore

max_issues_repo_name: tgmattso/OMP-CommonCore

max_forks_repo_name: tgmattso/OMP-CommonCore


text:
! =============================================================================
!
!> \file
!> \brief  Contains the Loggers module
!> \author CMJ (XCP-3; LANL)
!
!> The Loggers module contains the Logger class used by GSM and its sub-models
!> and model-data. The base member variables, member-procedures, and constructors
!> are contained here.
!
! =============================================================================
module Loggers

    use, intrinsic:: iso_fortran_env, only: int32, output_unit
    use, intrinsic:: iso_C_binding,   only: c_int

    implicit none
    private

    public:: prepareMessage

    ! >>> PARAMETERIZED DEFAULTS
    include "parameters.f90"

    ! >>> OBJECT CONSTRUCTION
    include "constructorInterface.f90"

    ! >>> DATA OBJECTS
    include "logger.f90"

 contains

     ! >>> CONSTRUCTORS
     include "constructors.f90"

     ! >>> INTROSPECTION
     include "introspection.f90"

     ! >>> SETTERS
     include "setters.f90"

     ! >>> PROCEDURES
     include "procedures.f90"

end module Loggers

max_stars_repo_name: lanl/generalized-spallation-model

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_name: lanl/generalized-spallation-model

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_name: lanl/generalized-spallation-model

max_forks_repo_licenses: Intel Unlicense


text:
// Generated Files
${PROJ_DIR}/axi4-mm/axi_mm_multi/aximm_ll_multi_tier1/aximm_ll_multi_tier1_slave_top.sv
${PROJ_DIR}/axi4-mm/axi_mm_multi/aximm_ll_multi_tier1/aximm_ll_multi_tier1_slave_concat.sv
${PROJ_DIR}/axi4-mm/axi_mm_multi/aximm_ll_multi_tier1/aximm_ll_multi_tier1_slave_name.sv

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

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

max_stars_repo_name: chipsalliance/aib-protocols

max_issues_repo_name: chipsalliance/aib-protocols

max_forks_repo_name: chipsalliance/aib-protocols


text:
     SUBROUTINE DEPVAR (A,I,W,L)
     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
***********************************************************************

  IN SUBROUTINE HADDON WHEN M, THE SYMMETRY OPERATION, IS 18 DEPVAR IS
  CALLED. DEPVAR SHOULD THEN CONTAIN A USER-WRITTEN SYMMETRY OPERATION.
  SEE HADDON TO GET THE IDEA ON HOW TO WRITE DEPVAR.

 ON INPUT:
           A = ARRAY OF INTERNAL COORDINATES
           I = ADDRESS OF REFERENCE ATOM
 ON OUTPUT:
           L = 1 (IF A BOND-LENGTH IS THE DEPENDENT FUNCTION)
             = 2 (IF AN ANGLE IS THE DEPENDENT FUNCTION)
             = 3 (IF A DIHEDRAL ANGLE IS THE DEPENDENT FUNCTION)
           W = VALUE OF THE FUNCTION

  NOTE:  IT IS THE WRITER'S RESPONSIBILITY TO MAKE CERTAIN THAT THE
         SUBROUTINE DOES NOT CONTAIN ANY ERRORS!
***********************************************************************
     RETURN
     END

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text: Meg Swarts is an Undergraduates undergraduate studying chemistry at UC Davis. You can find her at KDVS, the Davis Food Coop, the Chemistry Annex, or on the MU Patio.