text:
C    @(#)dcfact.f	20.7 4/5/00
        subroutine dcfact (ind)
	integer ind
        dimension ind(2,*)
c
C
C       THIS SUBROUTINE FACTORS THE "A" AND "C" MATRICES IN THE
C       DECOUPLED EQUATIONS:
C
C       A * T = P
C       C * V = Q
C
      include 'ipfinc/parametr.inc'

      include 'ipfinc/amtrx.inc'
      include 'ipfinc/beta.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/dcsln.inc'
      include 'ipfinc/ecvar.inc'
      include 'ipfinc/ikk.inc'
      include 'ipfinc/intbus.inc'
      include 'ipfinc/ntotzt.inc'
      include 'ipfinc/prt.inc'

      common /is_batch / is_batch
C
c     Local variables:
c
      integer mel, mlc, klp, krw, mlp
      integer ikstop, ml, ms, mt, ik, is_batch
      double precision rhin, rh, xh
c
C     If NTOTZT < NTOTX, reduce to NTOTZT and store in ALP. Then
C     continue factorization.
C
C     The reduced ALP system will be used with an LP to solve optimally
C     values of phase shift angle which will yield the most satisfactory
C     solution.
C
C     Begin factorization/reduction
C
      do 100 kt=1,nbslck
         ind(1,kt+ntota)=ikec
  100 ind(2,kt+ntota)=ikec
      kt=nbslck
  110 kt=kt+1
      kta=kt+ntota
      ind(1,kta)=ikec
      if (kta.eq.ntotx) go to 250
      if (ikk(1,kta).gt.0) go to 130
  120 continue
      ind(2,kta)=ikec
      go to 110

  130 call jacbfc
      if (lp.eq.0) go to 120
      mel=0
  140 mel=korder(mel)
      ms=kolum(mel)
      if (ms-kta) 160,146,142
  142 write (errbuf(1),144) intbus(kt),intbas(kt)
  144 format ('0 ILL-CONDITIONED CONSTRAINT: BUS ',a8,f7.1)
      call prterx ('W',1)
      call erexit

  146 if (kta .ge. ntotzt .and. msw .eq. 0) then
C
C        Store reduced columns NTOTZT to NTOTX - 1 only if prior
C        elimination has not occurred.
C
         klp = kta - ntotzt + 1
         if (alp(klp,klp) .eq. 0.0) then
            krw = mel
  148       if (krw .gt. 0) then
               mlp = kolum(krw) - ntotzt + 1
               alp(klp,mlp) = sngl(rowh(krw))
               krw = korder(krw)
               go to 148
            endif
         endif
      endif
c
c     if rowh=0 we have problems!
c
      rh=rowh(mel)
      if (abs (rh) .le. 1.0e-6) then
        rh = 1.0d-4
      endif
      rhin=1.0d0/rh
      amtrx(ikec)=rhin
      ikec=ikec+1
      ind(2,kta)=ikec
      if (kta.ge.ntotx-1) go to 110
  150 mel=korder(mel)
      if (mel.le.0) go to 110
      mt=kolum(mel)
      amtrx(ikec)=mt
      amtrx(ikec+1)=rowh(mel)*rhin
      ikec=ikec+2
      go to 150

  160 if (ms .ge. ntotzt .and. msw .eq. 0) then
C
C        Store reduced columns NTOTZT to NTOTX - 1
C
         klp = kta - ntotzt + 1
         krw = mel
  162    if (krw .gt. 0) then
            mlp = kolum(krw) - ntotzt + 1
            alp(klp,mlp) = sngl(rowh(krw))
            krw = korder(krw)
            go to 162
         endif
      endif

      rh=rowh(mel)
      ik=ind(2,ms)
      ikstop=ind(1,ms+1)-1
      if (ik.gt.ikstop) go to 140

      amtrx(ikec)=ms
      amtrx(ikec+1)=rh
      ikec=ikec+2

      krw=mel
  170 ml=amtrx(ik)
      xh=amtrx(ik+1)
      if (ml.gt.max) go to 200
  180 if (kolum(krw)-ml) 190,230,210
  190 ko=krw
      krw=korder(krw)
      go to 180
  200 max=ml
      ko=lp
      lp=mend
  210 korder(mend)=korder(ko)
      kolum(mend)=ml
      korder(ko)=mend
      mlc=mend
      ko=mend
      mend=mend+1
      rowh(mlc)=0.0d0
      if (mend .gt. 500) then
         write (errbuf(1),220)
  220    format('0 FATAL WORKING ROW OVERFLOW (500)')
         if (is_batch .eq. 0) then
            call prterx ('E',1)
            go to 250
         else
            call prterx ('F',1)
            call erexit()
         endif
      else
         go to 240
      endif
  230 mlc=krw
  240 rowh(mlc)=rowh(mlc)-rh*xh
      ik=ik+2
      if (ik.ge.ikstop) go to 140
      go to 170
  250 continue
      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
SUBROUTINE CALSFT(ISTL_,IS2TL_)
  !
  ! CHANGE RECORD
  ! **  SUBROUTINE CALSFT CALCULATES THE TRANSPORT OF SHELL FISH LARVAE
  ! **  AT TIME LEVEL (N+1).
  ! **  CALLED ONLY ON ODD THREE TIME LEVEL STEPS  (PMC - NO, CALLED IN BOTH HDMT & HDMT2T)
  !

  USE GLOBAL
  ! *** DS-INTL BEGIN BLOCK
  IMPLICIT NONE
  INTEGER :: ISTL_,IS2TL_
  INTEGER :: ISDARK,ITIME,K,L,LN,LF,LL,ND
  REAL :: TIME,RTIME,TIMTMP,FANGTMP,UTMP,VTMP,VELEKB,VELNKB,CURANG,ANGDIF,RCDZKMK,CCLBTMP
  REAL :: RABOVE,HABOVE,TMPVAL,WMAXX,DZCIT,TMPVAL1,CDYETMP,RCDZKK,CCUBTMP,CCMBTMP,EEB
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: WTFKB
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: WTFKC

  IF(  .NOT. ALLOCATED(WTFKB) )THEN
    ALLOCATE(WTFKB(KCM))
    ALLOCATE(WTFKC(KCM))
    ! *** ZERO LOCAL ARRAYS
    WTFKB=0.0
    WTFKC=0.0
  ENDIF
  ! *** DS-INTL END BLOCK
  !
  !PMC      DELT=DT2
  ! *** PMC
  IF( ISTL_ == 2 )THEN
    IF( ISDYNSTP == 0 )THEN
      DELT=DT
    ELSE
      DELT=DTDYN
    END IF
  ELSE
    DELT=DT2
  ENDIF
  ! *** PMC
  !
  ! **  UPDATED TIME SERIES CONCENTRATION BOUNDARY CONDITIONS
  ! **  DETERMINE IF CURRENT TIME STEP IS DURING DAYLIGHT OR DARKNESS
  !
  IF( ISSFLDN >= 1 )THEN
    ISDARK=1
    IF( ISDYNSTP == 0 )THEN
      TIME=(DT*FLOAT(N)+TCON*TBEGIN)/86400.
    ELSE
      TIME=TIMESEC/86400.
    ENDIF
    ITIME=INT(TIME)
    RTIME=FLOAT(ITIME)
    TIMTMP=TIME-RTIME
    IF( TIMTMP >= TSRSF .AND. TIMTMP <= TSSSF) ISDARK=0
  ENDIF
  !
  ! **  DETERMINE IF LOCAL CONDITIONS ARE EBB OR FLOOD
  !
  IF( ISSFLFE >= 1 )THEN
    IF( KC == 1 )THEN
      WTFKB(1)=1.
      WTFKC(1)=0.
    ENDIF
    IF( KC == 2 )THEN
      WTFKB(1)=1.0
      WTFKC(1)=0.0
      WTFKB(2)=0.0
      WTFKC(2)=1.0
    ENDIF
    IF( KC == 3 )THEN
      DO K=1,KC
        WTFKB(K)=FLOAT(KC-K)/FLOAT(KS)
        WTFKC(K)=1.0-WTFKB(K)
      ENDDO
    ENDIF
  !
  ! **  SET SWITCHES TO EBB
  !
    DO K=1,KC
      DO L=2,LA
        UUU(L,K)=0.
        VVV(L,K)=1.
      ENDDO
    ENDDO
  !
  ! **  RESET SWITCHES FOR FLOOD
  !
    DO K=1,KC
      DO L=2,LA
        LN=LNC(L)
        FANGTMP=ACCWFLD(L,1)*WTFKB(K)+ACCWFLD(L,2)*WTFKC(K)
        UTMP=0.5*STCUV(L)*(UWQ(LEC(L),K)+UWQ(L,K))
        VTMP=0.5*STCUV(L)*(VWQ(LN ,K)+VWQ(L,K))
        VELEKB=CUE(L)*UTMP+CVE(L)*VTMP+1.E-12
        VELNKB=CUN(L)*UTMP+CVN(L)*VTMP
        CURANG=ATAN2(VELNKB,VELEKB)
        ANGDIF=ABS(FANGTMP-CURANG)
        IF( ANGDIF < 1.5708 )THEN
          UUU(L,K)=1.
          VVV(L,K)=0.
        ENDIF
      ENDDO
    ENDDO
  ENDIF
  !
  ! **  SET UP ADVECTION FIELD
  ! **  SET ATTACHED TO BOTTOM AND NO ADVECTIVE TRANSPORT IN BOTTOM
  ! **  LAYER DURING EBB IF APPROPRIATE
  !
  IF( ISSFLFE >= 1 )THEN
    IF( SFNTBET < 1. )THEN
      DO L=2,LA
        K=KSZ(L)
        UHDYWQ(L,K)=UUU(L,K)*UHDYWQ(L,K)+SFNTBET*VVV(L,K)*UHDYWQ(L,K)
        VHDXWQ(L,K)=UUU(L,K)*UHDYWQ(L,K)+SFNTBET*VVV(L,K)*VHDXWQ(L,K)
        UWQ(L,K)=UUU(L,K)*UWQ(L,K)+SFNTBET*VVV(L,K)*UWQ(L,K)
        VWQ(L,K)=UUU(L,K)*VWQ(L,K)+SFNTBET*VVV(L,K)*VWQ(L,K)
      ENDDO
    ENDIF
  ENDIF

  ! *** COMPUTE SHELLFISH LARVAE ADVECTION
  CALL CALTRAN (ISTL_,IS2TL_,4,4,SFL,SFL2,1)
  !CALL CALTRWQ (4,0,SFL,SFL2)   ! PMC
  !
  ! **  SET UP VERTICAL MIGRATION AND SETTLING BEHAVIOR
  ! **  INITIALIZE VERTICAL VELOCTIY TO TIME DEPENDENT SETTLING VELOCITY
  !
  DO K=1,KS
    DO L=2,LA
      WWQ(L,K)=-WSFLSTT
    ENDDO
  ENDDO
  DO L=2,LA
    WWQ(L,KC)=0.
    WWQ(L,0)=0.
  ENDDO
  IF( ISSFLFE >= 1 .AND. ISSFLDN >= 1 )THEN
  !
  ! **  DAYLIGHT CONDITIONS
  !
    IF( ISDARK == 0 )THEN
      DO K=1,KS
        RABOVE=FLOAT(KC-K)/DZI
        DO L=2,LA
  !
  ! **   DETERMINE DISTANCE TO SURFACE
  !
          HABOVE=RABOVE*HWQ(L)
          IF( UUU(L,K) > 0. )THEN
  !
  ! **    FLOOD CONDITION : SWIM UP TO MIN DIST BELOW SURFACE
  !
            IF( HABOVE > DSFLMNT) WWQ(L,K)=WSFLSMT
          ELSE
  !
  ! **    EBB CONDITION : CONTINUE TO SINK OR SWIM UP TO MAX DIST BL SURF
  !
            IF( HABOVE > DSFLMXT) WWQ(L,K)=WSFLSMT
          ENDIF
        ENDDO
      ENDDO
    ENDIF
  !
  ! **  DARK CONDITIONS
  !
    IF( ISDARK == 1 )THEN
      DO K=1,KS
        DO L=2,LA
  !
  ! **   FLOOD CONDITION : SWIM UP TO  SURFACE
  !
          WWQ(L,K)=VVV(L,K)*WWQ(L,K)+UUU(L,K)*WSFLSMT
        ENDDO
      ENDDO
    ENDIF
  ENDIF
  IF( SFATBTT > 0. )THEN
    DO L=2,LA
      WWQ(L,0)=-WSFLSTT
    ENDDO
  ENDIF
  !
  ! **  CALCULATE NET VERTICAL SWIMING OR SETTLING
  !
  IF( WSFLSMT == 0. ) GOTO 100
  !
  ! **  LIMIT VERTICAL SETTLING AND/OR SWIMMING FOR STABILITY
  !
  DO K=0,KS
    DO L=2,LA
      WWW(L,K)=MIN(WWQ(L,K),0.)
      WWW(L,K)=ABS(WWW(L,K))
      WWQ(L,K)=MAX(WWQ(L,K),0.)
    ENDDO
  ENDDO
  TMPVAL=0.25/(DELT*DZI)
  DO K=1,KS
    DO L=2,LA
      WMAXX=TMPVAL*HWQ(L)
      WWW(L,K)=MIN(WWW(L,K),WMAXX)
      WWQ(L,K)=MIN(WWQ(L,K),WMAXX)
      WWQ(L,K)=WWQ(L,K)-WWW(L,K)
    ENDDO
  ENDDO
  DO K=1,KS
    DO L=2,LA
      FWU(L,K)=MAX(WWQ(L,K),0.)*SFL(L,K) &
          +MIN(WWQ(L,K),0.)*SFL(L,K+1)
    ENDDO
  ENDDO
  IF( SFATBTT > 0. )THEN
    DO L=2,LA
      SFLSBOT(L)=SFLSBOT(L)-DELT*FWU(L,0)
    ENDDO
  ENDIF
  DO K=1,KC
    DO L=2,LA
      SFL(L,K)=SFL(L,K) + DELT*(FWU(L,K-1)-FWU(L,K))*DZIC(L,K)/HWQ(L)
    ENDDO
  ENDDO
  GOTO 200
    100 CONTINUE
  !
  ! **  FULLY IMPLICIT SETTLING IF SWIMMING IS ZERO EVERYWHERE
  ! **  FULLY IMPLICIT SETTLING IN SURFACE LAYER
  !
  TMPVAL=DELT*WSFLSTT
  DZCIT=TMPVAL*DZIC(L,KC)
  DO L=2,LA
    TMPVAL1=DZCIT/HWQ(L)
    SFL(L,KC)=SFL(L,KC)/(1.+TMPVAL1)
  ENDDO
  !
  ! **  FULLY IMPLICIT SETTLING IN REMAINING LAYERS
  !
  IF( KC > 1 )THEN
    DO K=KS,1,-1
      IF( K < KSZ(L) )CYCLE
      DZCIT=TMPVAL*DZIC(L,K)
      DO L=2,LA
        TMPVAL1=DZCIT/HWQ(L)
        SFL(L,K)=(SFL(L,K)+TMPVAL1*SFL(L,K+1))/(1.+TMPVAL1)
      ENDDO
    ENDDO
  ENDIF
  IF( SFATBTT > 0. )THEN
    DO L=2,LA
      SFLSBOT(L)=SFLSBOT(L)+TMPVAL*SFL(L,KSZ(L))
    ENDDO
  ENDIF
    200 CONTINUE
  DO L=2,LA
    FWU(L,0)=0.
    WWQ(L,0)=0.
    WWW(L,0)=0.
  ENDDO
  !
  ! **  CALCULATE LINEAR DECAY
  !
  IF( RKDSFLT >= 0. )THEN
    CDYETMP=1./(1.+DELT*RKDSFLT)
    DO K=1,KC
      DO L=2,LA
        SFL(L,K)=CDYETMP*SFL(L,K)
      ENDDO
    ENDDO
  ENDIF
  IF( KC == 1 ) GOTO 2000
  !
  ! **  VERTICAL DIFFUSION CALCULATION
  !
  DO L=2,LA
    HWQI(L)=1./HWQ(L)
  ENDDO
  DO ND=1,NDM
    LF=2+(ND-1)*LDM
    LL=MIN(LF+LDM-1,LA)
    DO L=LF,LL
      RCDZKK=-DELT*CDZKK(L,KSZ(L))
      CCUBTMP=RCDZKK*HWQI(L)*AB(L,KSZ(L))
      CCMBTMP=1.-CCUBTMP
      EEB=1./CCMBTMP
      CU1(L,KSZ(L))=CCUBTMP*EEB
      SFL(L,KSZ(L))=SFL(L,KSZ(L))*EEB
    ENDDO
  ENDDO
  DO ND=1,NDM
    LF=2+(ND-1)*LDM
    LL=MIN(LF+LDM-1,LA)
    DO K=2,KS
      DO L=LF,LL
        IF( K < KSZ(L)+1 )CYCLE
        RCDZKMK=-DELT*CDZKMK(L,K)
        RCDZKK=-DELT*CDZKK(L,K)
        CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1)
        CCUBTMP=RCDZKK*HWQI(L)*AB(L,K)
        CCMBTMP=1.-CCLBTMP-CCUBTMP
        EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1))
        CU1(L,K)=CCUBTMP*EEB
        SFL(L,K)=(SFL(L,K)-CCLBTMP*SFL(L,K-1))*EEB
      ENDDO
    ENDDO
  ENDDO
  K=KC
  DO ND=1,NDM
    LF=2+(ND-1)*LDM
    LL=MIN(LF+LDM-1,LA)
    DO L=LF,LL
      RCDZKMK=-DELT*CDZKMK(L,K)
      CCLBTMP=RCDZKMK*HWQI(L)*AB(L,K-1)
      CCMBTMP=1.-CCLBTMP
      EEB=1./(CCMBTMP-CCLBTMP*CU1(L,K-1))
      SFL(L,K)=(SFL(L,K)-CCLBTMP*SFL(L,K-1))*EEB
    ENDDO
  ENDDO
  DO ND=1,NDM
    LF=2+(ND-1)*LDM
    LL=MIN(LF+LDM-1,LA)
    DO K=KC-1,1,-1
      DO L=LF,LL
        SFL(L,K)=SFL(L,K)-CU1(L,K)*SFL(L,K+1)
      ENDDO
    ENDDO
  ENDDO
  !
  ! **  UPDATE SHELL FISH LARVAE CONCENTRATIONS
  !
    2000 CONTINUE
  DO K=1,KC
    DO L=2,LA
      SFL2(L,K)=SFL(L,K)
    ENDDO
  ENDDO
  RETURN

END

max_stars_repo_name: dsi-llc/EFDCPlus

max_forks_repo_name: dsi-llc/EFDCPlus


text:
      module io
        use, intrinsic :: iso_fortran_env, only : REAL64, INT16, INT32, INT64, stdout=>output_unit, stdin=>input_unit

        integer NDataFiles

        character(len=25), allocatable :: fnames(:)
        integer, allocatable :: nrd(:)
        real(REAL64), allocatable :: raw(:,:,:)
        real(REAL64), allocatable :: e0raw(:), e1raw(:), Araw(:), Qraw(:)
        integer, allocatable :: productsraw(:)

        character(len=*), parameter, public :: paramformat = '((A),(Es9.3),(A8))'

        integer, parameter :: in_f = 11, cs_f = 13, eedf_f = 17, rate_f = 19, pops_f = 23

      contains

        subroutine read_program_input(Nruns, tfin, dt, e0, p, Npops, neexpr)

          implicit none

          integer row, col, i
          integer(INT64) Nruns
          real(REAL64) tfin, dt, e0, p, NRunsreal
          integer Npops
          character(len=*) neexpr

          read(stdin,*) NRunsreal, tfin, dt, e0, p

          read(stdin,*) neexpr

          read(stdin,*) NDataFiles, Npops

          allocate(fnames(NDataFiles))
          allocate(nrd(NDataFiles))
          allocate(e0raw(NDataFiles))
          allocate(e1raw(NDataFiles))
          allocate(productsraw(NDataFiles))

          allocate(Araw(Npops), Qraw(Npops))

          read(stdin,*) Araw, Qraw

          read(stdin,*) fnames

          Nruns = int(NRunsreal)

          if (NRunsreal .gt. huge(NRunsreal)) then
            write(stdout,*) "# WARNING: overflow in input N - lower the number of simulated particles!"
          end if

          ! first pass over data files: count line numbers
          do i=1, NDataFiles
            nrd(i) = lines_in_file(trim(fnames(i)))-1
          end do
          ! allocate space for raw data
          allocate(raw(maxval(nrd),2,NDataFiles))
          ! second pass over data files: read data into memory
          do i=1, NDataFiles
            ! open data file
            open(cs_f, file=trim(fnames(i)), status='old')
            ! read metadata
            read(unit=cs_f,fmt=*) e0raw(i), e1raw(i), productsraw(i)
            ! read cross-sections
            read(unit=cs_f,fmt=*) ((raw(row,col,i),col=1,2),row=1,nrd(i))
            ! Close the file so the handle can be reused
            close(cs_f)
          end do

          ! Rescale the data to SI units - expecting cross-sections in cm^2
          raw(:,2,:) = raw(:,2,:)*1.0e-4
        end subroutine read_program_input

        subroutine clean_up_io()
          implicit none

          deallocate(e0raw)
          deallocate(e1raw)
          deallocate(fnames)
          deallocate(nrd)
          deallocate(productsraw)
          deallocate(raw)
        end subroutine clean_up_io

        function lines_in_file(fname)
          implicit none

          integer lines_in_file, stat
          character*(*) fname
          character*120 line

          open(20, file=fname)

          lines_in_file = 0
          read (20,*,iostat=stat) line

          do while(stat.eq.0)
            lines_in_file = lines_in_file+1
            read (20,*,iostat=stat) line
            enddo

            close(20)
        end function lines_in_file

        function padr(string, length) result(r)
          character(len=*) :: string
          integer          :: length
          character(len=length) :: r

          r = adjustl(string)
        end function padr

      end module io

ext: f

max_stars_repo_name: tlycken/bari-montecarlo

max_issues_repo_name: tomasaschan/bari-montecarlo

max_forks_repo_name: tomasaschan/bari-montecarlo


text:
      SUBROUTINE LWP_INPUT
     &          (more_data,root_file,
     &           plt_device,plt_orientation,
     &           gcpath,lwflds,opa_grid,preseg,
     &           power,incl,headng,talt,ralt,
     &           print_lwf,print_mc,print_wf,nrcmp,
     &           lwf_dst_min,lwf_dst_max,lwf_dst_inc,
     &           map_id,map_prjctn,map_type,
     &           map_lat,map_lon,map_size,
     &           bflag,area_id,range_max,
     &           n_model,n_month,n_day,n_year,n_UT,bandw,
     &           month,day,year,UT)

c***********************************************************************

c     Reads input data for LWPM.

c***********************************************************************

c CONTROL STRINGS:

c PLOTTER     PLOT-DEVICE PLOT-ORIENTATION
c FILE-MDS    directory-location-of-MDS-files
c FILE-LWF    directory-location-of-LWF-files
c FILE-GRD    directory-location-of-GRD-files
c FILE-PRF    directory-location-of-PRF-files
c FILE-NDX    directory-location-of-NDX-files
c FILE-LWT    directory-location-of-LWT-files
c CASE-ID     CASE-ID
c TX-NTR      TX-DATA-FILE
c JX-NJR      JX-DATA-FILE
c TX-DATA     TX-ID freq tx-lat tx-lon power inclination heading tx-alt
c TX-DATA     TX-ID TX-SPECIFICATION-FILE
c JX-DATA     JX-ID freq jx-lat jx-lon power inclination heading jx-alt
c JX-DATA     JX-ID JX-SPECIFICATION-FILE
c RX-DATA     VERTICAL   rx-alt
c RX-DATA     HORIZONTAL rx-alt
c IONOSPHERE  HOMOGENEOUS TABLE FILE-NAME
c IONOSPHERE  HOMOGENEOUS EXPONENTIAL beta hprime
c IONOSPHERE  LWPM DAY
c IONOSPHERE  LWPM NIGHT
c IONOSPHERE  LWPM MONTH/day/year hour:minute
c IONOSPHERE  RANGE TABLE       FILE-NAME
c IONOSPHERE  RANGE EXPONENTIAL FILE-NAME
c IONOSPHERE  CHI   TABLE       FILE-NAME
c IONOSPHERE  CHI   EXPONENTIAL FILE-NAME
c IONOSPHERE  GRID  TABLE       FILE-NAME
c LWTIME      MONTH/day/year hour:minute
c BEARINGS    bearing-1 bearing-2 ...
c +BEARINGS   bearing-n bearing-m ...
c RECEIVERS   rx-lat-1 rx-lon-1 rx-lat-2 rx-lon-2 ...
c +RECEIVERS  rx-lat-n rx-lon-n rx-lat-m rx-lon-m ...
c RANGE-MAX   maximum-range-for-BEARINGS-and-RECEIVERS
c OP-AREA     AREA-ID op-lat1 op-lon1 op-lat2 op-lon2
c OP-AREA     AREA-ID OP-AREA-SPECIFICATION-FILE
c A-NOISE     N_MODEL MONTH/day/year hour:minute band-width
c LWF-VS-DIST lwf-dist-max lwf-dist-inc
c MC-OPTIONS  MC-STEP mc-test wf-iterate
c MAP-AREA    MAP-ID RECTANGULAR  lat1 lon1 lat2 lon2 size-x size-y
c MAP-AREA    MAP-ID MERCATOR     lat1 lon1 lat2 lon2 size-x size-y
c MAP-AREA    MAP-ID GNOMONIC     lat0 lon0 range     size-x size-y
c MAP-AREA    MAP-ID AZIMUTHAL    lat0 lon0 range     size-x size-y
c MAP-AREA    MAP-ID ORTHOGRAPHIC lat0 lon0 range     size-x size-y
c MAP-AREA    MAP-ID MAP-AREA-SPECIFICATION-FILE
c MAP-TYPE    LAND
c MAP-TYPE    COAST
c MAP-TYPE    LAND COAST
c MAP-TYPE    COAST LAND
c PRINT-LWF   print-lwf
c PRINT-MC    print-mc
c PRINT-MDS   print-mds
c PRINT-SWG   print-swg
c PRINT-WF    print-wf
c GCPATH
c LWFLDS
c OPA-GRID
c PRESEG
c START
c QUIT

c***********************************************************************

c PLOTTER           Defines the graphical output device

c    INPUT PARAMETERS:

c    PLOT-DEVICE    Plotter device (SYS-SCR/SYS-PRN/FILE-NAME)

c    PLOT-ORIENTATION
c                   Orientation (LANDSCAPE/PORTRAIT)

c CASE-ID           Provides for user identification of the data

c    INPUT PARAMETERS:

c    CASE-ID        identification string [80 characters]

c TX-NTR            Provides a root file name from which output files
c                   are constructed.

c    INPUT PARAMETERS:

c    NTR            transmitter number provided for convenience in
c                   identifying transmitters for complicated cases.
c                   If it is not required, then the control string
c                   may be shortened to "TX".

c    TX-DATA-FILE   character string which will be used to define file
c                   names [120 characters]. It may contain a directory
c                   name. This and other programs in the LWPC generate
c                   files with different extensions using this name as
c                   the root. For example, the output from the mode
c                   sum program is of the form: TX-DATA-FILE.LWF

c JX-NJR            Provides a root file name from which output files
c                   are constructed. Equivalent in effect to "TX-NTR".

c    INPUT PARAMETERS:

c    NJR            jammer number provided for convenience in
c                   identifying jammers for complicated cases.
c                   If it is not required, then the control string
c                   may be shortened to "JX".

c    JX-DATA-FILE   character string which will be used to define file
c                   names [120 characters]. It may contain a directory
c                   name. This and other programs in the LWPC generate
c                   files with different extensions using this name as
c                   the root. For example, the output from the mode
c                   sum program is of the form: JX-DATA-FILE.LWF

c TX-DATA           Defines the parameters of the transmitter.

c    INPUT PARAMETERS:

c    TX-ID          character string which identifies the transmitter
c                   [20 characters]
c    FREQ           frequency
c    TX-LAT         latitude
c    TX-LON         longitude
c    POWER          power
c    INCLINATION    inclination of the antenna
c    HEADING        heading of the antenna
c    TX-ALT         altitude of the antenna

c    TX-SPECIFICATION-FILE
c                   name of a file which contains records containing
c                   the above list of parameters for the transmitter;
c                   the file is searched for a match with TX-ID and
c                   the corresponding parameters are returned.

c JX-DATA           Defines the parameters of the jammer. Equivalent in
c                   effect to "TX-DATA".

c    INPUT PARAMETERS:

c    JX-ID          character string which identifies the jammer
c                   [20 characters]
c    FREQ           frequency
c    JX-LAT         latitude
c    JX-LON         longitude
c    POWER          power
c    INCLINATION    inclination of the antenna
c    HEADING        heading of the antenna
c    JX-ALT         altitude of the antenna

c    JX-SPECIFICATION-FILE
c                   name of a file which contains records containing
c                   the above list of parameters for the jammer.
c                   the file is searched for a match with JX-ID and
c                   the corresponding parameters are returned.

c RX-DATA           Defines the parameters of the received fields.

c    INPUT PARAMETERS:

c    VERTICAL       indicates that only the vertical fields (Ez) are
c                   to be computed; this string may be shortened.

c    HORIZONTAL     indicates that both the vertical and horizontal
c                   fields (Ez and Ey) are to be computed; this string
c                   may be shortened.

c    RX-ALT         altitude of the antenna

c IONOSPHERE        Defines the ionospheric profile(s).

c    INPUT PARAMETERS:

c    HOMOGENEOUS TABLE FILE-NAME
c                   indicates that a homogeneous ionosphere is to be
c                   used over the whole path; the profile parameters
c                   are defined by a table found in the file named
c                   FILE-NAME.PRF

c    HOMOGENEOUS EXPONENTIAL beta hprime
c                   indicates that a homogeneous exponential
c                   ionosphere is to be used over the whole path;
c                   the profile parameters are a slope BETA and a
c                   reference height HPRIME.

c    LWPM DAY       indicates that all day-time conditions are to be
c                   used over the whole path; the parameters of the
c                   ionosphere are to be set by the program.

c    LWPM NIGHT     indicates that all night-time conditions are to be
c                   used over the whole path; the parameters of the
c                   ionosphere are to be set by the program.

c    LWPM MONTH/day/year hour:minute
c                   indicates that a specific date and time is to be
c                   used; the parameters of the ionospheric profiles
c                   are to be set by the program; the parameters of
c                   the date and time is as follows:
c                      MONTH  name of the month
c                      day    day of the month
c                      year   year
c                      hour   hour of the day
c                      minute minute of the hour
c                   The day may be omitted by using two "/"; the year
c                   may be omitted by dropping "/year"; the day and
c                   year may be omitted by dropping "/day/year"; the
c                   year may be entered modulo (100). The minutes may
c                   be omitted by dropping ":minute".

c    RANGE TABLE FILE-NAME
c                   indicates that the ionosphere varies along the
c                   path; the profile parameters are defined using
c                   files with the root name defined by FILE-NAME;
c                   the index file, named FILE-NAME.NDX, contains
c                   a list of ranges and associated profile indices;
c                   the ionosphere for each index "nnn" is defined in
c                   a table found in the file FILE-NAMEnnn.PRF

c    RANGE EXPONENTIAL FILE-NAME
c                   indicates that the ionosphere varies along the
c                   path; the profile parameters are defined by a
c                   file, named FILE-NAME.NDX, which contains a list
c                   of ranges and associated BETAs and HPRIMEs.

c    CHI TABLE FILE-NAME
c                   indicates that the ionosphere varies with solar
c                   zenith angle (chi); the profile parameters are
c                   defined using files with the root name defined by
c                   FILE-NAME; the index file, named FILE-NAME.NDX,
c                   contains a list of ranges and associated profile
c                   indices; the convention to be used is actually to
c                   use the complement of the zenith angle such that
c                   0<CHI<90 is midnight to noon and 90<CHI<180 is
c                   noon to midnight; the ionosphere for each index
c                   "nnn" is defined in a table found in the file
c                   FILE-NAMEnnn.PRF

c    CHI EXPONENTIAL FILE-NAME
c                   indicates that the ionosphere varies with solar
c                   zenith angle (chi); the convention to be used is
c                   actually to use the complement of the zenith angle
c                   such that 0<CHI<90 is midnight to noon and
c                   90<CHI<180 is noon to midnight; the profile
c                   parameters are defined by a file, named
c                   FILE-NAME.NDX, which contains a list of solar
c                   zenith angles (chi) and associated BETAs and
c                   HPRIMEs.

c    GRID TABLE FILE-NAME
c                   indicates that the ionosphere varies with
c                   position; the profile parameters are defined using
c                   files with the root name defined by FILE-NAME;
c                   the index file, named FILE-NAME.NDX, contains a
c                   grid of positions and associated profile indices;
c                   the ionosphere for each index "nnn" is defined in
c                   a table found in the file FILE-NAMEnnn.PRF

c LWTIME            Defines the date and time for the output.

c    NOTE:          This control string used only by program LWTime.

c    INPUT PARAMETERS:

c    MONTH/day/year hour:minute
c                   indicates the specific date and time to be used;
c                   the parameters of the date and time are:
c                      MONTH  name of the month
c                      day    day of the month
c                      year   year
c                      hour   hour of the day
c                      minute minute of the hour
c                   The day may be omitted by using two "/"; the year
c                   may be omitted by dropping "/year"; the day and
c                   year may be omitted by dropping "/day/year"; the
c                   year may be entered modulo (100). The minutes may
c                   be omitted by dropping ":minute".

c BEARINGS          Defines a list of bearing angles used to define
c                   paths.

c    INPUT PARAMETERS:

c    bearing        geographic bearing angle of a path [120 values];
c                   a list is continued by the control string
c                   "+BEARINGS".

c RECEIVERS         Defines a list of receiver positions used to define
c                   paths

c    INPUT PARAMETERS:

c    rx-lat rx-lon  geographic coordinates of a receiver [60 values];
c                   a list is continued by the control string
c                   "+RECEIVERS".

c RANGE-MAX         Defines the maximum range of paths when they are
c                   defined using "BEARINGS" and "RECEIVERS".

c    INPUT PARAMETERS:

c    maximum-range  maximum range

c OP-AREA           Defines an operating area used to define paths

c    INPUT PARAMETERS:

c    AREA-ID        character string which identifies the op area
c                   [20 characters]
c    op-lat1        bottom latitude  of the op area
c    op-lon1        left   longitude of the op area
c    op-lat2        top    latitude  of the op area
c    op-lon2        right  longitude of the op area

c    AREA-SPECIFICATION-FILE
c                   name of a file which contains records containing
c                   the above list of parameters for the op area.
c                   the file is searched for a match with AREA-ID and
c                   the corresponding parameters are returned.

c A-NOISE           Defines parameters for computation of atmospheric
c                   noise

c    INPUT PARAMETERS:

c    N-MODEL        noise model name [4 characters: ITSN, NTIA]
c    MONTH          name of the month
c    day            day of the month
c    year           year
c    NOTE:          The day may be omitted by using two "/"; the year
c                   may be omitted by dropping "/year"; the day and
c                   year may be omitted by dropping "/day/year"; the
c                   year may be entered modulo (100).

c    hour           hour of the day
c    minute         minute of the hour
c    NOTE:          The minutes may be omitted by dropping ":minute".

c    band-width     band width in Hz

c LWF-VS-DIST       Defines the range of distance over which the mode
c                   sum is computed

c    INPUT PARAMETERS:

c    lwf-dist-max   distance at which to end the mode sum
c    lwf-dist-inc   distance increment

c MC-OPTIONS        Controls which mode conversion calculation is used.

c    INPUT PARAMETERS:

c    MC-STEP        =FULL-WAVE indicates that the full wave
c                   calculations are to be performed; this means
c                   integration of the wave fields through the
c                   ionosphere; if the flag ITERATE is true, then
c                   the eigen angles are iterated until the mode
c                   equation is satisfied.

c                   =MIXED indicates that a mix of full wave and
c                   approximate calculations is to be performed; the
c                   full wave calculations are done when the h' on
c                   either side of a slab boundary is greater than
c                   the value defined by MC-TEST.

c                   =APPROXIMATE indicates that only the approximate
c                   form of the calculations is to be used.

c    mc-test        the value of h' used to determine when full wave
c                   calculations are to be performed.

c    wf-iterate     =TRUE tells the WaveFields routine to iterate the
c                   input eigen angles to ensure that the mode
c                   equation is satisfied.

c PRINT-MC          Indicates levels of print from ModeConversion

c    INPUT PARAMETERS:

c    print-mc       =0: minimum print
c                   =1: adds conversion coefficients
c                   =2: adds integrals

c PRINT-WF          Indicates levels of print from WaveFields

c    INPUT PARAMETERS:

c    print-wf       =0: minimum print
c                   =1: adds iterations
c                   =1: adds fields vs. height

c MAP-AREA          Defines the map onto which the path segmentation is
c                   to be plotted for the "PREVIEW".

c    INPUT PARAMETERS:

c    MAP-ID         map area name [20 characters]

c    MERCATOR       calls for a Mercator projection

c    lat1           bottom latitude  of the map area
c    lon1           left   longitude of the map area
c    lat2           top    latitude  of the map area
c    lon2           right  longitude of the map area

c    RECTANGULAR    calls for a projection which is linear in latitude
c                   and longitude

c    lat1           bottom latitude  of the map area
c    lon1           left   longitude of the map area
c    lat2           top    latitude  of the map area
c    lon2           right  longitude of the map area

c    AZIMUTHAL      Azimuthal-equidistant projection

c    lat0           center latitude  of the map area
c    lon0           center longitude of the map area
c    range          maximum range to be mapped

c    GNOMONIC       call for a projection in which great circles are
c                   straight lines

c    lat0           center latitude  of the map area
c    lon0           center longitude of the map area
c    range          maximum range to be mapped

c    ORTHOGRAPHIC   Orthographic projection

c    lat0           center latitude  of the map area
c    lon0           center longitude of the map area
c    range          maximum range to be mapped

c    size-x         length of horizontal axis
c    size-y         length of vertical   axis

c    MAP-AREA-SPECIFICATION-FILE
c                   name of a file which contains records containing
c                   the above list of parameters for the map area.
c                   the file is searched for a match with MAP-ID and
c                   the corresponding parameters are returned.

c MAP-TYPE          Indicates the method of denoting land masses for the
c                   map plots.

c    INPUT PARAMETERS:

c    LAND           does land mass overlay from LWPC_DAT:LAND$D
c    COAST          does coastal outlines  from LWPC_DAT:WRLD$D

c PRINT-LWF         Indicates levels of print out for the mode summation

c    INPUT PARAMETERS:

c    print-lwf      =0: minimum print from LWF file
c                   =1: adds fields vs. distance

c PRINT-MC          Indicates levels of print from ModeConversion

c    INPUT PARAMETERS:

c    print-mc       =0: minimum print
c                    1: adds conversion coefficients
c                    2: adds integrals

c PRINT-MDS         Indicates levels of print out for the mode
c                   parameters

c    INPUT PARAMETERS:

c    print-mds      =0: minimum print from MDS file
c                   =1: adds attenuation rate, etc.
c                   =2: adds conversion coefficients
c                   =3: adds slab integrals

c PRINT-SWG         Indicates levels of print out for the calculations
c                   along the propagation paths

c    INPUT PARAMETERS:

c    print-swg      =0: none
c                   =1: path parameters and mode lists:   LWP_DRIVER
c                   =2: mode parameter outputs:           SW_WVGD
c                   =3: extrapolation parameter outputs:  SW_EXTRAP

c PRINT-WF          Indicates levels of print from WaveFields

c    INPUT PARAMETERS:

c    print-wf       =0: minimum print
c                    1: adds iterations
c                    2: adds fields vs. height

c GCPATH            Indicates that the path segmentation is to be
c                   printed; no mode parameters are be generated.

c LWFLDS            Re-compute the mode summation; presumes that the
c                   altitudes or orientation of the transmitter/jammer
c                   or receiver has been changed.

c OPA-GRID          Re-compute the grid file; presumes a new mode sum or
c                   a different operating area.

c PRESEG            Use precomputed segmentation data; the list of
c                   segments follows the control string; see LWP_INPUT
c                   for details.

c START             Indicates that all inputs are complete and processing
c                   of the paths can begin.

c QUIT              Terminates the run.

c***********************************************************************

c NAMELIST          Set miscellaneous parameters with NAMELIST (DATUM).

c    INPUT PARAMETERS:

c    brsltn         bearing angle resolution in degrees; used when
c                   BFLAG=0

c    Input unique to SW:

c    ftol           F-function tolerance used to terminate iterations

c    maxitr         maximum number of iterations

c    rpoly          flag to control inexact/exact calculations

c    nrtlst         number of T-list angles to use in the inexact
c                   interpolation of the reflection coefficients

c    Input unique to MF:

c    mf_range       limits search area for modes; a 2x3 matrix
c                   (1,1) FREQ1; (1,2) min RANGER; (1,3) min RANGEI
c                   (2,1) FREQ2; (2,2) min RANGER; (2,3) min RANGEI

c    atnmax         maximum attenuation rate used to restrict search
c                   area for modes

c    The following variables control debug print out:

c    lprnt:         search box; branch points; gmax; bxrtio; tmesh; lub;
c                   htintrp; g;
c                   adjmsh;
c                   theta, reflht

c    mprnt:         ITRATE

c    mrprnt:        search box; branch points; gmax; bxrtio; tmesh; lub;
c                   zeta; eigen vectors;
c                   search for htintrp; htintrp; g;
c                   adjmsh;
c                   theta, reflht;
c                   iterations on final eigens;
c                   INIT_ROE; INIT_LG

c    msprnt:        list of search boxes;
c                   WGSORT

c    mzprnt:        FZEROS

c    rprnt:         theta; q; r; x

c    xprnt:         r; dr; ep; dep; v; dv

c***********************************************************************

c The flow of this program is determined by the use of control strings
c and their associated data. Control strings begin in column 1; control
c strings beginning with a blank in this column are treated as comments;
c a control string may be shortened so long as it is unique. More than
c one space may separate the control string from its associated data and
c any number of spaces may appear between data items. In the list of
c control strings, quantities which appear in upper case are character
c data.

c***********************************************************************

c Common parameters, units of measure, conventions:

c Quantity:       Units:
c    frequency      kz
c    power          kW
c    altitude       km
c    distance       km
c    latitude       degrees North
c    longitude      degrees West
c    inclination    degrees from vertical
c    heading        degrees East of North (geographic)
c    bearing        degrees East of North (geographic)

c Conventions:
c    Southern latitudes are input as negative values
c    Eastern longitudes are input as negative values
c    Dates are input as MONTH/day/year
c    Times are input as hour:minute
c    Antennae are modeled as short dipoles

c***********************************************************************

c LU:    Ext:   File:
c    2              xmtr, map-area, op-area
c    3     INP      Input file
c    4     LOG      Log file

c    11    NDX      Ionospheric profile index file
c    12    PRF      Ionospheric profile
c    13    MDS      Mode parameters
c    14    LWF      Mode sum vs. distance
c    15    GRD      Grid data

c    16             ITSN noise coefficients
c    17             NTIA noise coefficients

c    20             Temporary storage of wf data: direct azimuth
c    21             Temporary storage of wf data: adjoint
c    22             Temporary storage of wf data: previous

c    95             Corrected geomagnetic coordinates
c    96             Land mass map
c    97             Coastal outline map
c    98             Ground conductivity map

c    99             Scratch

c***********************************************************************

c Preferred plotter set up:
c   PEN:   COLOR:   PLOT_GRD:      COND_MAP:    PREVIEW:
c    1     black    labels                      border
c    2     green    solid          1e-2/3e-2
c    3     blue     long dash      1e-3/3e-3
c    4     purple   medium dash      3e-5       op_area
c    5     red      short dash       1e-5       paths
c    6     black    dots             3e-4
c    7     yellow   land overlay     1e-4       land
c    8     broad    coast                       coast

c***********************************************************************

c Change history:
c     23 Oct 90     Modified to use the more rigorous testing of maps,
c                   op areas and transmitters found in GET_MAP, GET_OPA
c                   and GET_XMTR.

c     28 Feb 91     Modified to accept MF printout flags through DATUM.

c     14 Mar 91     Store noise year MOD 100.

c     30 Jan 92     Modified to use DECODE_* routines.

c     10 Feb 92     Modified /LWPC_IN/ to store HOFWR, TOPHT, BOTHT and
c                   PINDEX

c     27 Feb 92     Deleted /LWPC_PR/.

c     22 May 92     T.A.Hepner
c                   Changed file access mode from "READONLY" to
c                   "MODE='READ' " to work under MS FORTRAN 5.x.

c                   Added a new common block called LWPC_CFG, which is
c                   used to store configuration information, such as
c                   the location of the lwpc_dat data files.

c                   Added the following control strings which are used
c                   to specify the location of the various data files
c                   used or created by LWPM:
c                      FILE-DAT, FILE-MDS, FILE-LWF, FILE-GRD,
c                      FILE-PRF, FILE-NDX

c     20 Jan 93     Added frequency dependent limits for RANGER and
c                   RANGEI.

c     10 Nov 93     Added solar zenith angle dependent ionospheres.

c     11 Nov 93     Removed PREVIEW control string.

c     30 Dec 93     Added control strings for LWTime and SetupLWT.

c     17 Jan 94     Removed unused common MF_SW_2.

c     09 Feb 94     Changed PLT_DEVICE and PLT_ORIENTATION to
c                   CHARACTER*(*).

c     22 Feb 94     Added FILE-LWT to specify the location of the LWT
c                   files created and used by LWTime.

c     20 Apr 95     Ensure that the 'lwpcXXX_loc' end with '\'.

c     26 Sep 95     Changed all PRINTs to WRITE(6)s.

c     21 Oct 95     Changed to get logical units from LWPC_LUN.CMN.

c     18 Dec 95     Added PRINT-MC and PRINT-WF parameters to
c                   argument list.

c     16 Dec 96     Generalize delimiters used with file names.

c     04 Mar 97     Added options for presegmentation.

c     15 Jan 98     Dropped PLT_UNIT; use PLT_DEVICE to store file name
c                   when output to a file.

c     05 Feb 98     Removed control string FILE-DAT.

c*******************!***************************************************

c     LWPC parameters
      INCLUDE      'lwpc_cfg.cmn'
      INCLUDE      'lwpc_lun.cmn'

      parameter    (mxpath=120,mxsgmnt=201,mxeigen=50)

      character*  8 archive,prgm_id
      character* 20 xmtr_id,path_id
      character* 40 prfl_id
      character* 80 case_id
      character*120 file_id
      integer       pflag,pindex
      real     *  4 freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht

      common/lwpc_in/
     &              archive,file_id(3),prgm_id,
     &              case_id,prfl_id,xmtr_id,path_id,
     &              freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &              lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &              hofwr,topht,botht,pindex

      real     *  4 ranger,rangei,atnmax,lub,h
      complex  *  8 eigen

      common/lwpc_mf/
     &              ranger(2),rangei(2),atnmax,lub,h,
     &              eigen(mxeigen),nreigen

      real     *  4 hten,algen,htnu,algnu,
     &              charge,ratiom,select_hgts,hgts

      common/lwpc_pr/
     &              hten(51),algen(51,3),nrhten,ihten,
     &              htnu(51),algnu(51,3),nrhtnu,ihtnu,
     &              charge(3),ratiom(3),nrspec,lu_prf,
     &              select_hgts(2),hgts(3)

      integer       rprnt,xprnt

      common/mf_prnt/
     &              lprnt,lgprnt,mprnt,mrprnt,msprnt,mzprnt,rprnt,xprnt

      common/mf_sw_3/
     &              op_lat(2),op_lon(2),brsltn(2),
     &              bearing(mxpath),rhomax(mxpath),
     &              rxlat(mxpath),rxlon(mxpath),rxrho(mxpath),nrpath

      integer       print_swg
      real     *  4 drmin,drmax

      common/sw_path/
     &              drmin,drmax,mdir,lost,lx,print_swg

      integer       rpoly
      real     *  4 dtheta,tol,deigen,thtinc,ftol,alpha,prec

      common/sw_wgin/
     &              dtheta(2),tol(2),deigen(2),thtinc,
     &              ftol,maxitr,alpha,prec,rpoly,nrtlst

      complex       tp,param2

      common/sw_wgou/
     &              tp(mxeigen),param2(5,mxeigen),lu_mds

      character*120 prfl_file
      real     *  8 max_wf_ht,mc_test
      integer       arb_azim

      common/mc_inpt/
     &              prfl_file,max_wf_ht,mc_test,
     &              lu_wfd,lu_wfa,lu_wfp,mc_step,arb_azim

      common/mf_sw_1/
     &              dst(mxsgmnt),xla(mxsgmnt),xlo(mxsgmnt),
     &              azm(mxsgmnt),xdp(mxsgmnt),fld(mxsgmnt),
     &              sgm(mxsgmnt),eps(mxsgmnt),ncd(mxsgmnt),
     &              bta(mxsgmnt),hpr(mxsgmnt),npr(mxsgmnt),
     &              num(mxsgmnt),nrsgmnt

      character*(*) plt_device,plt_orientation
      character*  1 components
      character*  1 delimiter(3)
      character*  3 month_string
      character*  4 map_type(2),map_prjctn,n_model
      character*  5 time_string
      character* 12 prfl_model
      character* 20 area_id,map_id,
     &              mc_option(3)
      character* 22 date_string
      character*120 string,control_string,data_string,
     &              directory,root_file,extension
      character*200 error_msg
      logical       more_data,bdata,fdata,xdata,
     &              gcpath,lwflds,opa_grid,preseg
      integer       str_length,
     &              bflag,
     &              month,day,year,hour,minute,UT,
     &              print_mds,print_lwf,print_mc,print_wf
      real          incl,map_lat(2),map_lon(2),map_size(2),
     &              lwf_dst_min,lwf_dst_max,lwf_dst_inc,
     &              mf_range(2,3),
     &              preseg_list(10)

      dimension     rx_location(mxpath),dst_max_inc(2)

      namelist/datum/
     &              brsltn,
     &              select_hgts,
     &              ftol,maxitr,rpoly,nrtlst,
     &              atnmax,mf_range,
     &              lprnt,lgprnt,mprnt,mrprnt,msprnt,mzprnt,rprnt,xprnt

      data          bdata,fdata,xdata/3*.false./,

c                            f1  f2  r1  r2  i1  i2
     &              mf_range/20.,60.,60.,40.,-9.,-6./

c     Get delimiters used in the file names
      call GET_DELIMITER (delimiter)

      more_data=.true.
10    read (lwpcINP_lun,'(a)',end=90) string
      write(lwpcLOG_lun,'(a)') string

      if (string(1:1) .eq. ' ') go to 10

c     Get the limits of the data within the control string
      call DECODE_CONTROL_DATA (string,control_string,data_string)

c     Convert the control string to upper case
      call STR_UPPER (control_string,0,0)

c FILE-LWF
      if (control_string(1:8) .eq. 'FILE-LWF') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcLWF_loc=' '
         else
            lwpcLWF_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcLWF_loc)
            if (lwpcLWF_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcLWF_loc(n:n)=delimiter(3)
            end if
         end if
         go to  10
      end if

c FILE-GRD
      if (control_string(1:8) .eq. 'FILE-GRD') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcGRD_loc=' '
         else
            lwpcGRD_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcGRD_loc)
            if (lwpcGRD_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcGRD_loc(n:n)=delimiter(3)
            end if
         end if
         go to 10
      end if

c FILE-MDS
      if (control_string(1:8) .eq. 'FILE-MDS') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcMDS_loc=' '
         else
            lwpcMDS_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcMDS_loc)
            if (lwpcMDS_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcMDS_loc(n:n)=delimiter(3)
            end if
         end if
         go to 10
      end if

c FILE-LWT
      if (control_string(1:8) .eq. 'FILE-LWT') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcLWT_loc=' '
         else
            lwpcLWT_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcLWT_loc)
            if (lwpcLWT_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcLWT_loc(n:n)=delimiter(3)
            end if
         end if
         go to 10
      end if

c FILE-PRF
      if (control_string(1:8) .eq. 'FILE-PRF') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcPRF_loc=' '
         else
            lwpcPRF_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcPRF_loc)
            if (lwpcPRF_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcPRF_loc(n:n)=delimiter(3)
            end if
         end if
         go to 10
      end if

c FILE-NDX
      if (control_string(1:8) .eq. 'FILE-NDX') then
         if (data_string(1:1) .eq. ' ') then
c           Current directory is default
            lwpcNDX_loc=' '
         else
            lwpcNDX_loc=data_string(1:STR_LENGTH(data_string))
            n=STR_LENGTH(lwpcNDX_loc)
            if (lwpcNDX_loc(n:n) .ne. delimiter(3)) then
               n=n+1
               lwpcNDX_loc(n:n)=delimiter(3)
            end if
         end if
         go to 10
      end if

c A-NOISE
      if (control_string(1:1) .eq. 'A') then

         call DECODE_A_NOISE
     &       (data_string,n_model,n_month,n_day,n_year,n_UT,bandw)
         go to 10
      end if

c BEARINGS
      if (control_string(1:1) .eq. 'B') then

         call DECODE_LIST_FLT
     &       (data_string,mxpath,nrpath,bearing)

         bflag=1
         bdata=.true.
         path_id='Bearings'
         op_lat(1)=0.
         op_lon(1)=0.
         op_lat(2)=0.
         op_lon(2)=0.
         go to 10
      end if

c +BEARINGS
      if (control_string(1:2) .eq. '+B') then

         call DECODE_LIST_FLT
     &       (data_string,mxpath-nrpath,nrlist,bearing(nrpath+1))
         nrpath=nrpath+nrlist
         go to 10
      end if

c CASE-ID
      if (control_string(1:1) .eq. 'C') then

         if (data_string(1:1) .eq. ' ') then
            write(error_msg,
     &          '(''[LWP_INPUT]: Data string missing'')')
            call LWPC_ERROR ('ERROR',error_msg)
         end if

         case_id=data_string
         go to 10
      end if

c GCPATH
      if (control_string(1:1) .eq. 'G') then

         gcpath=.true.
         go to 10
      end if

c IONOSPHERE
      if (control_string(1:1) .eq. 'I') then

         call DECODE_IONOSPHERE
     &       (data_string,
     &        prfl_model,month,day,year,UT,pflag,beta,hprime,prfl_file)
         go to 10
      end if

c LWTIME
      if (control_string(1:3) .eq. 'LWT') then

         call STR_COUNT_LIST (data_string,0,0,nritem)
         if (nritem .ne. 2) then
            write(error_msg,
     &          '(''[LWP_INPUT]: '',
     &            ''Date/Time specification is incomplete'')')
            call LWPC_ERROR ('ERROR',error_msg)
         end if

         call STR_GET_ITEM (1,data_string,date_string,n1,n2)
         call STR_UPPER (date_string,0,0)
         call DECODE_DATE (date_string,month_string,day,year)

         call STR_UPPER (month_string,1,1)
         call STR_LOWER (month_string,2,0)
         call MONTH_NUMBER (month_string,month)

         year=MOD(year,100) ! store last two digits of the year

         call STR_GET_ITEM (2,data_string,time_string,n1,n2)
         call DECODE_TIME (time_string,hour,minute)
         UT=100*hour+minute
         go to 10
      end if

c LWF-VS-DISTANCE
      if (control_string(1:4) .eq. 'LWF-' .or.
     &    control_string(1:4) .eq. 'LWF_') then

         call DECODE_LIST_FLT
     &       (data_string,2,nrlist,dst_max_inc)
         lwf_dst_min=0.
         lwf_dst_max=dst_max_inc(1)
         if (nrlist .eq. 2) lwf_dst_inc=dst_max_inc(2)
         go to 10
      end if

c MC-OPTIONS
      if (control_string(1:2) .eq. 'MC') then

         call DECODE_LIST_STR
     &       (data_string,3,nrlist,mc_option)

         call STR_LOWER (mc_option(1),0,0)
         if (mc_option(1)(1:1) .eq. 'f') then
            mc_step=0
         else
     &   if (mc_option(1)(1:1) .eq. 'm') then
            mc_step=1
         else
     &   if (mc_option(1)(1:1) .eq. 'a') then
            mc_step=2
         else
            write(error_msg,
     &          '(''[LWP_INPUT]: '',
     &            ''MC-STEP option not recognized'')')
            call LWPC_ERROR ('ERROR',error_msg)
         end if

         if (nrlist .gt. 1) then
            write(string,'(''(f'',i3.3,''.0)'')')
     &            STR_LENGTH(mc_option(2))
            read (mc_option(2),string) mc_test

            if (nrlist .gt. 2) then
               call STR_LOWER (mc_option(3),0,0)
               if (mc_option(3)(1:1) .eq. 't') then
                  iter_flag=1
               else
                  iter_flag=0
               end if
            end if
         end if
         go to 10
      end if

c LWFLDS
      if (control_string(1:3) .eq. 'LWF') then

         lwflds=.true.
         go to 10
      end if

c MAP-AREA
      if (control_string(1:5) .eq. 'MAP-A' .or.
     &    control_string(1:5) .eq. 'MAP_A') then

         call DECODE_MAP_AREA
     &       (data_string,.true.,
     &        map_id,map_prjctn,
     &        map_lon(1),map_lon(2),map_size(1),
     &        map_lat(1),map_lat(2),map_size(2))
         call STR_LOWER (map_id, 0,0)
         call STR_LOWER (map_prjctn,0,0)
cxxcDEBUG
cxx         write(lwpcLOG_lun,
cxx     &       '(/''[LWP_INPUT] DEBUG: '',a,1x,a,1x,6f7.1)')
cxx     &          map_id(:STR_LENGTH(map_id)),map_prjctn,
cxx     &          map_lat(1),map_lon(1),map_lat(2),map_lon(2)
         go to 10
      end if

c MAP-TYPE
      if (control_string(1:5) .eq. 'MAP-T' .or.
     &    control_string(1:5) .eq. 'MAP_T') then

         call DECODE_LIST_STR
     &       (data_string,2,nrlist,map_type)
         do n=1,nrlist
            call STR_LOWER (map_type(n),0,0)
         enddo
         go to 10
      end if

c OP-AREA
      if (control_string(1:3) .eq. 'OP-' .or.
     &    control_string(1:3) .eq. 'OP_') then

         call DECODE_OP_AREA
     &       (data_string,.true.,
     &        area_id,op_lon(1),op_lon(2),op_lat(1),op_lat(2))

         call STR_LOWER (area_id, 0,0)

         bflag=0
         bdata=.true.
         path_id=area_id
cxxcDEBUG
cxx         write(lwpcLOG_lun,
cxx     &       '(/''[LWP_INPUT] DEBUG: '',a,1x,4f7.1)')
cxx     &          area_id(:STR_LENGTH(area_id)),
cxx     &          op_lat(1),op_lon(1),op_lat(2),op_lon(2)
         go to 10
      end if

c OPA-GRID
      if (control_string(1:3) .eq. 'OPA') then

         opa_grid=.true.
         go to 10
      end if

c PLOTTER
      if (control_string(1:2) .eq. 'PL') then

         call DECODE_PLOTTER
     &       (data_string,plt_device,plt_orientation)
         call STR_LOWER (plt_device,0,0)
         go to 10
      end if

c PRESEG
      if (control_string(1:3) .eq. 'PRE') then

c        Read precomputed segmentation data
         rho=0.
         nrsgmnt=0
         do while (rho .lt. 40000.)
            read (lwpcINP_lun,'(a)') data_string
            call DECODE_LIST_FLT
     &          (data_string,10,nrlist,preseg_list)
            rho=preseg_list(1)
            if (rho .lt. 40000.) then
               nrsgmnt=nrsgmnt+1
               num(nrsgmnt)=0
               dst(nrsgmnt)=preseg_list( 1)
               azm(nrsgmnt)=preseg_list( 2)
               xdp(nrsgmnt)=preseg_list( 3)
               fld(nrsgmnt)=preseg_list( 4)
               ncd(nrsgmnt)=preseg_list( 5)
               sgm(nrsgmnt)=preseg_list( 6)
               eps(nrsgmnt)=preseg_list( 7)
               npr(nrsgmnt)=preseg_list( 8)
               bta(nrsgmnt)=preseg_list( 9)
               hpr(nrsgmnt)=preseg_list(10)
            end if
         end do
         preseg=.true.
         go to 10
      end if

c PRINT-LWF
      if (control_string(1:7) .eq. 'PRINT-L' .or.
     &    control_string(1:7) .eq. 'PRINT_L') then

         call DECODE_LIST_INT
     &       (data_string,1,nlist,print_lwf)
         go to 10
      end if

c PRINT-MC
      if (control_string(1:8) .eq. 'PRINT-MC' .or.
     &    control_string(1:8) .eq. 'PRINT_MC') then

         call DECODE_LIST_INT
     &       (data_string,1,nlist,print_mc)
         go to 10
      end if

c PRINT-MDS
      if (control_string(1:8) .eq. 'PRINT-MD' .or.
     &    control_string(1:8) .eq. 'PRINT_MD') then

         call DECODE_LIST_INT
     &       (data_string,1,nlist,print_mds)
         go to 10
      end if

c PRINT-SWG
      if (control_string(1:7) .eq. 'PRINT-S' .or.
     &    control_string(1:7) .eq. 'PRINT_S') then

         call DECODE_LIST_INT
     &       (data_string,1,nlist,print_swg)
         go to 10
      end if

c PRINT-WF
      if (control_string(1:7) .eq. 'PRINT-W' .or.
     &    control_string(1:7) .eq. 'PRINT_W') then

         call DECODE_LIST_INT
     &       (data_string,1,nlist,print_wf)
         go to 10
      end if

c QUIT
      if (control_string(1:1) .eq. 'Q') then

         more_data=.false.
         RETURN
      end if

c RANGE-MAX
      if (control_string(1:2) .eq. 'RA') then

         call DECODE_LIST_FLT
     &       (data_string,1,nrlist,range_max)
         go to 10
      end if

c RECEIVERS
      if (control_string(1:2) .eq. 'RE') then

c        Read the data in linear order. Later, this array must be
c        rearranged to put RX_LAT and RX_LON in proper order.
         call DECODE_LIST_FLT
     &       (data_string,mxpath,nrlist,rx_location)
         nrpath=0
         do m=1,nrlist,2
            nrpath=nrpath+1
            rxlat(nrpath)=rx_location(m)
            rxlon(nrpath)=rx_location(m+1)
         end do

         bflag=2
         bdata=.true.
         path_id='Receivers'
         op_lat(1)=0.
         op_lon(1)=0.
         op_lat(2)=0.
         op_lon(2)=0.
         go to 10
      end if

c +RECEIVERS
      if (control_string(1:2) .eq. '+R') then

         call DECODE_LIST_FLT
     &       (data_string,mxpath,nrlist,rx_location)
         do m=1,nrlist,2
            nrpath=nrpath+1
            rxlat(nrpath)=rx_location(m)
            rxlon(nrpath)=rx_location(m+1)
         end do
         go to 10
      end if

c RX-DATA
      if (control_string(1:2) .eq. 'RX') then

         call DECODE_RX_DATA
     &       (data_string,components,nrcmp,ralt)
         go to 10
      end if

c TX-DATA
c JX-DATA
      if (control_string(1:4) .eq. 'TX-D' .or.
     &    control_string(1:4) .eq. 'TX_D' .or.
     &    control_string(1:4) .eq. 'JX-D' .or.
     &    control_string(1:4) .eq. 'JX_D') then

         call DECODE_TX_DATA
     &       (data_string,.true.,
     &        xmtr_id,freq,tlat,tlon,power,incl,headng,talt)

         xdata=.true.
cxxcDEBUG
cxx         write(lwpcLOG_lun,
cxx     &       '(/''[LWP_INPUT] DEBUG: '',a,1x,7f7.1)')
cxx     &          xmtr_id(:STR_LENGTH(xmtr_id)),
cxx     &          freq,tlat,tlon,power,incl,headng,talt
         go to 10
      end if

c TX-NTR
c JX-NJR
      if (control_string(1:1) .eq. 'T' .or.
     &    control_string(1:1) .eq. 'J') then

         call DECODE_FILE_NAME
     &       (data_string,directory,root_file,extension)

         fdata=.true.
         go to 10
      end if

c***********************************************************************
c NAMELIST
      if (control_string(1:1) .eq. 'N') then

c        Get NAMELIST parameters (DEBUG only)
         read (lwpcINP_lun,datum)
         write(lwpcLOG_lun,datum)
         go to 10
      end if
c***********************************************************************

c START
      if (control_string(1:1) .ne. 'S') then
         write(error_msg,
     &       '(''[LWP_INPUT]: Control string not recognized'')')
         call LWPC_ERROR ('ERROR',error_msg)
      end if

      if (.not.bdata) then
         write(error_msg,
     &       '(''[LWP_INPUT]: Op area or path data not specified'')')
         call LWPC_ERROR ('ERROR',error_msg)
      end if

      if (.not.fdata) then
         write(error_msg,
     &       '(''[LWP_INPUT]: Root file name not specified'')')
         call LWPC_ERROR ('ERROR',error_msg)
      end if

      if (.not.xdata) then
         write(error_msg,
     &       '(''[LWP_INPUT]: Xmtr/Jammer data not specified'')')
         call LWPC_ERROR ('ERROR',error_msg)
      end if
      go to 99

c     End of input file.
90    write(lwpcLOG_lun,'(''End of input file'')')
      more_data=.false.
      RETURN

c     Set profile identification
99    call PRFL_SPECIFICATION
     &    (.true.,print_swg,
     &     prfl_file,prfl_id,pflag,
     &     freq,month,day,year,UT,
     &     lat,lon,range,dip,zenith,
     &     hpr_mid,beta,hprime,pindex)

c     Select MODEFNDR search range
      ranger(2)=90.
      rangei(1)=0.
      if (freq .lt. mf_range(1,1)) then
         ranger(1)=mf_range(1,2)
         rangei(2)=mf_range(1,3)
      else
         ranger(1)=mf_range(2,2)
         rangei(2)=mf_range(2,3)
      end if

      RETURN
      END      ! LWP_INPUT

ext: for

max_stars_repo_name: spinorkit/LWPC

max_issues_repo_name: spinorkit/LWPC

max_forks_repo_name: spinorkit/LWPC


text:
! { dg-do compile }
! Tests patch for problem that was found whilst investigating
! PR24158. The call to foo would cause an ICE because the
! actual argument was of a type that was not defined.  The USE
! GLOBAL was commented out, following the fix for PR29364.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module global
  type :: t2
    type(t3), pointer :: d ! { dg-error "has not been declared" }
  end type t2
end module global

program snafu
!  use global
  implicit type (t3) (z)

  call foo (zin) ! { dg-error "defined|Type mismatch" }

contains

  subroutine foo (z)

    type :: t3
      integer :: i
    end type t3

    type(t3)  :: z
    z%i = 1

  end subroutine foo
end program snafu

! { dg-final { cleanup-modules "global" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
great_ne(b1,h1).
great_ne(t1,kk1).
great_ne(z1,m1).
great_ne(cc1,h1).
great_ne(q1,y1).
great_ne(bb1,i1).
great_ne(q1,ii1).
great_ne(jj1,aa1).
great_ne(u1,aa1).
great_ne(k1,w1).
great_ne(q1,hh1).
great_ne(z1,dd1).
great_ne(kk1,w1).
great_ne(jj1,v1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


text:
program my_test
implicit none

print *, "Test passed! That was easy!"

end program my_test

max_stars_repo_name: LKedward/fpm-haskell

max_issues_repo_name: LKedward/fpm-haskell

max_forks_repo_name: LKedward/fpm-haskell


module funcmod

    use,intrinsic   :: iso_c_binding
    implicit none

contains

    function func1() bind(c,name='func1')

        implicit none
        integer(c_int) func1

        write( *,* ) '1. This is a function in the static library which is packed by a module!'
        func1 = 1

    end function func1

end module funcmod


text:
submodule (filesystem) fs_cpp

use, intrinsic :: iso_c_binding, only : c_char, c_ptr, C_INT, C_NULL_CHAR, C_SIZE_T

implicit none (type, external)

interface !< fs.cpp

subroutine cfs_filesep(sep) bind(C, name='filesep')
import
character(kind=c_char), intent(out) :: sep(*)
end subroutine

logical(C_BOOL) function cfs_match(path, pattern) bind(C, name='match')
import
character(kind=c_char), intent(in) :: path, pattern
end function

integer(C_SIZE_T) function cfs_as_posix(path) bind(C, name="as_posix")
import
character(kind=c_char), intent(inout) :: path(*)
end function

integer(C_SIZE_T) function cfs_file_name(path, filename) bind(C, name="file_name")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: filename(*)
end function

integer(C_SIZE_T) function cfs_stem(path, fstem) bind(C, name="stem")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: fstem(*)
end function

integer(C_SIZE_T) function cfs_parent(path, fparent) bind(C, name="parent")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: fparent(*)
end function

integer(C_SIZE_T) function cfs_suffix(path, fsuffix) bind(C, name="suffix")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: fsuffix(*)
end function

integer(C_SIZE_T) function cfs_with_suffix(path, new_suffix, swapped) bind(C, name="with_suffix")
import
character(kind=c_char), intent(in) :: path(*), new_suffix
character(kind=c_char), intent(out) :: swapped(*)
end function

integer(C_SIZE_T) function cfs_normal(path, normalized) bind(C, name="normal")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: normalized(*)
end function

logical(c_bool) function cfs_is_symlink(path) bind(C, name="is_symlink")
import
character(kind=c_char), intent(in) :: path(*)
end function

integer(C_INT) function cfs_create_symlink(target, link) bind(C, name="create_symlink")
import
character(kind=c_char), intent(in) :: target(*), link(*)
end function

integer(C_INT) function cfs_create_directories(path) bind(C, name="create_directories")
import
character(kind=c_char), intent(in) :: path(*)
end function

integer(C_SIZE_T) function cfs_canonical(path, strict) bind(C, name="canonical")
import
character(kind=c_char), intent(inout) :: path(*)
logical(c_bool), intent(in), value :: strict
end function

logical(c_bool) function cfs_remove(path) bind(C, name="fs_remove")
import c_bool, c_char
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_exists(path) bind(C, name="exists")
import c_bool, c_char
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_is_file(path) bind(C, name="is_file")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_is_dir(path) bind(C, name="is_dir")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_equivalent(path1, path2) bind(C, name="equivalent")
import c_bool, c_char
character(kind=c_char), intent(in) :: path1(*), path2(*)
end function

integer(C_INT) function cfs_copy_file(source, dest, overwrite) bind(C, name="copy_file")
import
character(kind=c_char), intent(in) :: source(*), dest(*)
logical(c_bool), intent(in), value :: overwrite
end function

integer(C_SIZE_T) function cfs_relative_to(path, base, result) bind(C, name="relative_to")
import
character(kind=c_char), intent(in) :: path(*), base(*)
character(kind=c_char), intent(out) :: result(*)
end function

logical(c_bool) function cfs_touch(path) bind(C, name="touch")
import
character(kind=c_char), intent(in) :: path(*)
end function

integer(C_SIZE_T) function cfs_expanduser(path, result) bind(C, name="expanduser")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: result(*)
end function

integer(C_SIZE_T) function cfs_get_homedir(path) bind(C, name="get_homedir")
import
character(kind=c_char), intent(out) :: path(*)
end function

integer(C_SIZE_T) function cfs_get_tempdir(path) bind(C, name="get_tempdir")
import
character(kind=c_char), intent(out) :: path(*)
end function

integer(C_SIZE_T) function cfs_get_cwd(path) bind(C, name="get_cwd")
import
character(kind=c_char), intent(out) :: path(*)
end function

integer(C_SIZE_T) function cfs_root(path, result) bind(C, name="root")
import
character(kind=c_char), intent(in) :: path(*)
character(kind=c_char), intent(out) :: result(*)
end function

integer(C_SIZE_T) function cfs_file_size(path) bind(C, name="file_size")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_is_exe(path) bind(C, name="is_exe")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_is_absolute(path) bind(C, name="is_absolute")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_chmod_exe(path) bind(C, name="chmod_exe")
import
character(kind=c_char), intent(in) :: path(*)
end function

logical(c_bool) function cfs_chmod_no_exe(path) bind(C, name="chmod_no_exe")
import
character(kind=c_char), intent(in) :: path(*)
end function

end interface

contains

module procedure filesep
character(kind=c_char) :: cbuf(2)

call cfs_filesep(cbuf)

filesep = cbuf(1)

end procedure filesep

module procedure match
match = cfs_match(trim(path) // C_NULL_CHAR, trim(pattern) // C_NULL_CHAR)
end procedure match

module procedure file_name
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_file_name(trim(path) // C_NULL_CHAR, cbuf)

file_name = trim(cbuf(:N))

end procedure file_name

module procedure stem
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_stem(trim(path) // C_NULL_CHAR, cbuf)

stem = trim(cbuf(:N))
end procedure stem

module procedure parent
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_parent(trim(path) // C_NULL_CHAR, cbuf)

parent = trim(cbuf(:N))
end procedure parent

module procedure suffix
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_suffix(trim(path) // C_NULL_CHAR, cbuf)

suffix = trim(cbuf(:N))
end procedure suffix

module procedure normal
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_normal(trim(path) // C_NULL_CHAR, cbuf)

normal = trim(cbuf(:N))
end procedure normal

module procedure as_posix
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

cbuf = path // C_NULL_CHAR

N = cfs_as_posix(cbuf)

as_posix = trim(cbuf(:N))
end procedure as_posix

module procedure with_suffix
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_with_suffix(trim(path) // C_NULL_CHAR, trim(new) // C_NULL_CHAR, cbuf)

with_suffix = trim(cbuf(:N))
end procedure with_suffix

module procedure touch
if(.not. cfs_touch(trim(path) // C_NULL_CHAR)) error stop "filesystem:touch: " // path
end procedure touch

module procedure is_absolute
!! no expanduser to be consistent with Python filesystem etc.
is_absolute = cfs_is_absolute(trim(path) // C_NULL_CHAR)
end procedure is_absolute

module procedure is_symlink
is_symlink = cfs_is_symlink(trim(path) // C_NULL_CHAR)
end procedure is_symlink

module procedure create_symlink
integer(C_INT) :: ierr

ierr = cfs_create_symlink(trim(tgt) // C_NULL_CHAR, trim(link) // C_NULL_CHAR)
if(present(status)) then
  status = ierr
elseif (ierr < 0) then
  error stop "ERROR:filesystem:create_symlink: platform is not capable of symlinks."
elseif (ierr /= 0) then
  error stop "ERROR:filesystem:create_symlink: " // link
endif
end procedure create_symlink

module procedure mkdir
integer :: ierr

ierr = cfs_create_directories(trim(path) // C_NULL_CHAR)
if(present(status)) then
  status = ierr
elseif (ierr /= 0) then
  error stop "ERROR:filesystem:mkdir: failed to create directory: " // path
endif
end procedure mkdir

module procedure canonical
character(kind=c_char, len=MAXP) :: cpath
integer(C_SIZE_T) :: N
logical(c_bool) :: s

s = .false.
if(present(strict)) s = strict

cpath = path // C_NULL_CHAR

N = cfs_canonical(cpath, s)

canonical = trim(cpath(:N))

end procedure canonical

module procedure root
character(kind=c_char, len=3) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_root(trim(path) // C_NULL_CHAR, cbuf)

root = trim(cbuf(:N))

end procedure root

module procedure exists
exists = cfs_exists(trim(path) // C_NULL_CHAR)
end procedure exists

module procedure is_file
is_file = cfs_is_file(trim(path) // C_NULL_CHAR)
end procedure is_file

module procedure is_dir
is_dir = cfs_is_dir(trim(path) // C_NULL_CHAR)
end procedure is_dir

module procedure is_exe
is_exe = cfs_is_exe(trim(path) // C_NULL_CHAR)
end procedure is_exe

module procedure same_file
same_file = cfs_equivalent(trim(path1) // C_NULL_CHAR, trim(path2) // C_NULL_CHAR)
end procedure same_file

module procedure f_unlink
logical(c_bool) :: e

e = cfs_remove(trim(path) // C_NULL_CHAR)
if (.not. e) write(stderr, '(a)') "filesystem:unlink: " // path // " did not exist."
end procedure f_unlink

module procedure copy_file
logical(c_bool) :: ow
integer(C_INT) :: ierr

ow = .false.
if(present(overwrite)) ow = overwrite

ierr = cfs_copy_file(trim(src) // C_NULL_CHAR, trim(dest) // C_NULL_CHAR, ow)
if (present(status)) then
  status = ierr
elseif(ierr /= 0) then
  error stop "failed to copy file: " // src // " to " // dest
endif

end procedure copy_file

module procedure relative_to
character(kind=c_char, len=MAXP) :: rel
integer(C_SIZE_T) :: N

N = cfs_relative_to(trim(a) // C_NULL_CHAR, trim(b) // C_NULL_CHAR, rel)

relative_to = trim(rel(:N))
end procedure relative_to

module procedure expanduser
character(kind=c_char, len=MAXP) :: cbuf
integer(C_SIZE_T) :: N

N = cfs_expanduser(trim(path) // C_NULL_CHAR, cbuf)

expanduser = trim(cbuf(:N))
end procedure expanduser

module procedure get_homedir
character(kind=c_char, len=MAXP) :: cpath
integer(C_SIZE_T) :: N

N = cfs_get_homedir(cpath)

get_homedir = trim(cpath(:N))
end procedure get_homedir

module procedure get_tempdir
character(kind=c_char, len=MAXP) :: cpath
integer(C_SIZE_T) :: N

N = cfs_get_tempdir(cpath)

get_tempdir = trim(cpath(:N))
end procedure get_tempdir

module procedure get_cwd
character(kind=c_char, len=MAXP) :: cpath
integer(C_SIZE_T) :: N

N = cfs_get_cwd(cpath)

get_cwd = trim(cpath(:N))
end procedure get_cwd

module procedure file_size
file_size = cfs_file_size(trim(path) // C_NULL_CHAR)
end procedure file_size

module procedure chmod_exe
logical :: s

s = cfs_chmod_exe(trim(path) // C_NULL_CHAR)
if(present(ok)) ok = s
end procedure chmod_exe

module procedure chmod_no_exe
logical :: s

s = cfs_chmod_no_exe(trim(path) // C_NULL_CHAR)
if(present(ok)) ok = s
end procedure chmod_no_exe

end submodule fs_cpp

max_stars_repo_name: scivision/fortran-pathlib

max_issues_repo_name: scivision/fortran-filesystem

max_forks_repo_name: scivision/fortran-filesystem


text:
c******************************************************************************
c
c      ESPCAM  valve program prepartion for ESP
c
c------------------------------------------------------------------------------
       PARAMETER (IMAX=48)
c------------------------------------------------------------------------------
c    general setup work arrays
       INCLUDE 'INTWRKZZ.H'
       EQUIVALENCE(ID(5),NC)
       EQUIVALENCE(ID(6),NI)
       EQUIVALENCE(ID(7),NR)
c------------------------------------------------------------------------------
c    application-specific subroutines called by GETZZ
       EXTERNAL SVP1VV,HVP1VV,AVP1VV
       EXTERNAL SVP2VV,AVP2VV
c------------------------------------------------------------------------------
c    task control
       COMMON /TASKVV/ NTASK
c------------------------------------------------------------------------------
c    old and new file data
       CHARACTER*32    FILEO,FILEN
       CHARACTER*48    NAMEO,NAMEN
       DIMENSION       ADO(IMAX),FDO(IMAX)
       DIMENSION       ADN(IMAX),FDN(IMAX)
       COMMON /VPDOVV/ NAMEO,FMAXO,NDO,ADO,FDO
       COMMON /VPDNVV/ NAMEN,FMAXN,NDN,ADN,FDN
       COMMON /FILEVV /FILEO,FILEN
c------------------------------------------------------------------------------
c    output file controls
       CHARACTER*32    MPFILE,PRFILE,VPFILE
       DIMENSION NOPO(3)
       COMMON /VPOFVV/MPFILE,PRFILE,VPFILE,NOPO
c------------------------------------------------------------------------------
c    data from table
       DIMENSION AV(2*IMAX)
       COMMON /NVPTVV/AV
c------------------------------------------------------------------------------
       LOGICAL OK
c------------------------------------------------------------------------------
c    line length for non-graphical interface message box
       COMMON /MESBZZ/ LMESS
       LMESS = 78
c------------------------------------------------------------------------------
c    load unset indicators (be consistent with SETZZ in file IB.F
       CD(1) = CHAR(239)
       ID(1) = -22222
       RD(1) = -1.1111111E11
c------------------------------------------------------------------------------
c   opening header
       CALL MESSZZ('#','#ESPCAM v1.06  Creates valve program file '//
     ;             'for ESP.# #'//
     ;             'Address all enquiries to '//
     ;             ' wcr@thermo.stanford.edu.##')
       CALL HVPCVV
       CALL PAUSZZ(1)
c
10     NIV1 = 0
c    main menu
       CALL GETZZ(NIV1,SVP1VV,HVP1VV,AVP1VV,NOPA1)

c    check for edit of existing file
       IF (NTASK.EQ.1) THEN
c        get file
           CALL OPFLVV(10,FILEO,.TRUE.,.FALSE.,OK)
           IF (.NOT.OK)  THEN
               CALL FMESVV(1,'@','#','Valve program file # '//
     ;         'not found.@',FILEO)
               GOTO 10
               ENDIF
           CALL  RVPDVV(10,IMAX,NAMEO,NDO,FMAXO,ADO,FDO,IERR)
           CLOSE(10)
c        check for file error
           IF (IERR.NE.0) THEN
c            try V1 format
               CALL OPUOVV(10,FILEO,IERR)
               IF (IERR.NE.0)  THEN
                   CALL FMESVV(1,'@','#','Valve program file # '//
     ;             'not found.@',FILEO)
                   GOTO 10
                   ENDIF
               CALL RVPOVV(10,IMAX,NAMEO,NDO,FMAXO,ADO,FDO,IERR)
               IF (IERR.NE.0)  THEN
                   CALL FMESVV(2,'@','#','Valve program file # '//
     ;             'corrupted.@',FILEO)
                   GOTO 10
                   ENDIF
               CALL FMESVV(1,'@','#','Valve program file # was in '//
     ;             'ESP v1 format. Save to ESP v2+ format.@',FILEO)
               CLOSE(10)
               ENDIF

c        load the old file to new
           NAMEN = NAMEO
           NDN = NDO
           DO I=1,NDO
               AV(I) = ADO(I)
               AV(I+NDN) = FDO(I)
               ENDDO
           NIV2 = 1
           GOTO 20
           ENDIF
c
c    new table input
       NIV2 = 0
c
c    get or correct data
20     CALL GETZZ(NIV2,SVP2VV,HVP1VV,AVP2VV,NOPA2)

c *  data checks
c
c    check first angle
       IF (AV(1).NE.0)  THEN
           CALL WARNZZ('@','@Error; first angle must be zero@@')
           NIV2 = 1
           GOTO 20
           ENDIF
c
c    check angles for monotonicity
       DO I=2,NDN
           IF (AV(I).LE.AV(I-1))  THEN
               CALL WARNZZ('@','@Error;  angles must increase@@')
               NIV2= 1
               GOTO 20
               ENDIF
           ENDDO
c    lifts were checked for >=0 in table construction
c
c    scan and load the table
       FMAXN = 0
       DO  I=1,NDN
           ADN(I) = AV(I)
           FDN(I) = AV(I+NDN)
           IF (FDN(I).GT.FMAXN) FMAXN = FDN(I)
           ENDDO
c    matlab file
       IF (NOPO(1).EQ.1)  THEN
           CALL OPFLVV(10,MPFILE,.FALSE.,.TRUE.,OK)
           IF (OK)  THEN
                   CALL VPMPVV(10,NAMEN,NDN,ADN,FDN)
                   CALL FMESVV(1,'@','#','Plot file # written.@',
     ;                         MPFILE)
               ELSE
                   CALL FMESVV(2,'@','#','Plot file # not written.@',
     ;                         MPFILE)
               ENDIF
           CLOSE(10)
           ENDIF
c    print file
       IF (NOPO(2).EQ.1)  THEN
           CALL OPFLVV(10,PRFILE,.FALSE.,.TRUE.,OK)
           IF (OK)  THEN
                   CALL DVPTVV(10,0,NAMEN,NDN,ADN,FDN)
                   CALL FMESVV(1,'@','#','Print file # written.@',
     ;                         PRFILE)
               ELSE
                   CALL FMESVV(2,'@','#','Print file # not written.@',
     ;                         PRFILE)
               ENDIF
           CLOSE(10)
           ENDIF
       IF (NOPO(3).EQ.1)  THEN
c        .ESV file
           CALL OPFLVV(10,VPFILE,.FALSE.,.FALSE.,OK)
           IF (OK)  THEN
                   CALL WVPDVV(10,IMAX,NAMEN,NDN,FMAXN,ADN,FDN,IERR)
                   IF (IERR.EQ.0)  THEN
                           CALL FMESVV(1,'@','#',
     ;                      'Valve program file # written.@',VPFILE)
                       ELSE
                           CALL FMESVV(2,'@','#',
     ;                      'Error writing valve program  file #  . '//
     ;                         'File missing or corrupted.@',VPFILE)
                       ENDIF
               ELSE
                   IF (IERR.NE.0)  CALL FMESVV(1,'@','#',
     ;                 'Valve program file # not written.@',VPFILE)
               ENDIF
               CLOSE(10)
           ENDIF
c    next program
       GOTO 10
c
       END
c******************************************************************************
c
       SUBROUTINE SVP1VV
c
c      Setup for getting valve program task
c------------------------------------------------------------------------------
       PARAMETER (IMAX=48)
c------------------------------------------------------------------------------
c    old and new file data
       CHARACTER*32    FILEO,FILEN
       CHARACTER*48    NAMEO,NAMEN
       DIMENSION       ADO(IMAX),FDO(IMAX)
       DIMENSION       ADN(IMAX),FDN(IMAX)
       COMMON /VPDOVV/ NAMEO,FMAXO,NDO,ADO,FDO
       COMMON /VPDNVV/ NAMEN,FMAXN,NDN,ADN,FDN
       COMMON /FILEVV /FILEO,FILEN
c------------------------------------------------------------------------------
       COMMON /TASKVV/ NTASK
c------------------------------------------------------------------------------
c    exit actions
       CALL AOZZ('@','Do task@')
       CALL AOZZ('@','Quit ESPCAM@')
c    task options and data
       CALL BEOGZZ(0,0,'@','Task@',2,NTASK,J0)
         CAll HOZZ(J0,0,'@','Help@',51,JX)
         CALL ODZZ(J0,1,'@','Edit #@',1,J0E)
           CALL FNZZ(J0E,1,'Save file',9,32,'ESV',1,FILEO,JX)
         CALL ODZZ(J0,2,'@','Create new program with # points@',1,J0N)
           CALL IVZZ(J0N,1,'N',1,12,2,IMAX,NDN,JX)
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE AVP1VV(I,NOPA)
c
c      Setup ACTIONS
c
c      I=1 do task
c        2 Quit
c------------------------------------------------------------------------------
c    Setup file name
       CHARACTER*32  SUFILE
       COMMON /SUFVV/SUFILE
c------------------------------------------------------------------------------
       LOGICAL OK,YESZZ
c------------------------------------------------------------------------------
       IF (I.EQ.1)  THEN
c        set to check data and exit
           NOPA = 1
           RETURN
           ENDIF
       IF (I.EQ.2) THEN
c        confirm quit
           IF (YESZZ('Do you really want to quit ESPCAM?')) STOP
c        no quit
           NOPA = 0
           RETURN
           ENDIF
c    improper request
c      CALL ERRFZZ('@','@Illegal action request.@@')
       NOPA = 0
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE  HVP1VV(K)
c
c      Responds to interface's requests for help code K.
c------------------------------------------------------------------------------
c    clear output window
       CALL CLOWZZ
c    provide the help
       IF (K.EQ.51)  THEN
               CALL HVPCVV
           ELSEIF (K.EQ.52)  THEN
               CALL HVPCVV
           ELSEIF (K.EQ.53)  THEN
               CALL HVPOVV
           ELSE
               CALL MESSZZ('@','Error; help missing.@@')
           ENDIF
       CALL PAUSZZ(1)
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE HVPCVV
c
c      Help in valve program construction
c------------------------------------------------------------------------------
       CALL MESSZZ('@',
     ;     '@Before using ESPCAM, prepare a table of the '//
     ;     'valve lift (arbitrary units) as a function of '//
     ;     'crank angle (arbitrary units) past the angle at '//
     ;     'which the valve opens.  The opening and closing '//
     ;     'angles will be set as an operating parameter in ESP.  '//
     ;     'ESP will stretch your cam curve to fit these angles. '//
     ;     'In ESPCAM you enter the number of points in this '//
     ;     'table (48 max), the angles and lifts, the name of '//
     ;     'your valve program, and the .ESV save file name.  '//
     ;     'The table must contain at least 2 points.  '//
     ;     'The first point must be at zero angle. ' //
     ;     'Angles and lifts are floating '//
     ;     'point numbers used with linear interpolations between.@ @'//
     ;     'A smooth cam should have zero lift at the first and last '//
     ;     'points.  You can make a step up at opening by setting '//
     ;     'non-zero lift at the first point and a step down '//
     ;     'at the end by non-zero lift at the last point.@ @'//
     ;     'You can edit an existing .ESV file as long as you '//
     ;     'do not change the number of data points, and save the '//
     ;     'new program in the same or a different .ESV file.  '//
     ;     'ESPCAM can generate a Matlab plot file for your valve '//
     ;     'program and/or write the valve program to a print file.@@')
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE HVPOVV
c
c      Help on output
c------------------------------------------------------------------------------
       CALL MESSZZ('@','@Write a Matlab .M file to make a plot using '//
     ;    'Matlab.  Write a .PRN file to use for printing your '//
     ;    'valve program.  Save an .ESV file to use in ESP.@@')
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE STOPZZ
c
c      Interface error stop routine
c------------------------------------------------------------------------------
c    setup data storage
       INCLUDE 'INTWRKZZ.H'
       EQUIVALENCE(ID(2),NC)
       EQUIVALENCE(ID(3),NI)
       EQUIVALENCE(ID(4),NR)
c------------------------------------------------------------------------------
       OPEN (19,FILE='WORKDUMP.INT')
c    work array dump
       WRITE (19,82) (ID(I),I=1,NI)
82     FORMAT (' ID: ',15I5)
       WRITE (19,83) (RD(I),I=1,NR)
83     FORMAT (' RD: ',15F5.2)
       WRITE (19,84) (CD(I),I=1,NC)
84     FORMAT (' CD: ',75A1)
       CLOSE(19)
       STOP
       END
c******************************************************************************
c
       SUBROUTINE SVP2VV
c
c      Setup for getting new program data
c------------------------------------------------------------------------------
       PARAMETER (IMAX=48)
c------------------------------------------------------------------------------
c    new file data
       CHARACTER*32    FILEN
       CHARACTER*48    NAMEN
       DIMENSION       ADN(IMAX),FDN(IMAX)
       COMMON /VPDNVV/ NAMEN,FMAXN,NDN,ADN,FDN
c------------------------------------------------------------------------------
c    data from table
       DIMENSION AV(2*IMAX)
       COMMON /NVPTVV/AV
c------------------------------------------------------------------------------
c    frozen table columns referenced but not used
       DIMENSION AF(1)
c------------------------------------------------------------------------------
c    output file controls
       CHARACTER*32    MPFILE,PRFILE,VPFILE
       DIMENSION NOPO(3)
       COMMON /VPOFVV/MPFILE,PRFILE,VPFILE,NOPO
c------------------------------------------------------------------------------
c    data restrictions
       DIMENSION KRC(2),NCW(2),VMINC(2),VMAXC(2)
       DATA KRC /12,4/
       DATA VMINC /0.,0./
       DATA VMAXC /720.,0./
       DATA NCW /22,22/
c------------------------------------------------------------------------------
c    plot task designator
       CHARACTER*32    FILEOP
c------------------------------------------------------------------------------
c    set no output options
       DO I=1,3
           NOPO(I) = 0
           ENDDO
c    exit actions
       CALL AOZZ('@','Save indicated files@')
       CALL AOZZ('@','Return to main menu@')
       CALL AOZZ('@','Quit ESPCAM@')
       CALL BIGZZ(0,0,'@','Valve program construction/output@',2,J0)
         CALL HOZZ(J0,0,'@','Help@',52,JX)
c       table
         CALL BTABZZ(J0,1,'@','Valve program@',NDN,0,2,NCW,
     ;    'Degrees past open@@'//
     ;    'Relative lift@@',
     ;     KRC,VMINC,VMAXC,AF,AV,KSO,JT)
           CALL GDZZ(JT,48,NAMEN,JX)
           CAll HOZZ(JT,0,'@','Help@',52,JX)
c       output options
         CALL BIOGZZ(J0,2,'@','Output file options@',
     ;              3,3,NOPO,J0O)
           CALL HOZZ(J0O,0,'@','Help@',53,JX)
           CALL GDZZ(J0O,32,FILEOP,JX)
             CALL ODZZ(J0O,1,'@','Make #@',1,J0OM)
               CALL FNZZ(J0OM,1,'Matlab plot file',16,32,'M  ',
     ;                  2,MPFILE,JX)
             CALL ODZZ(J0O,2,'@','Write to #@',1,J0OP)
               CALL FNZZ(J0OP,1,'Print File',10,32,'PRN',
     ;                  2,PRFILE,JX)
             CALL ODZZ(J0O,3,'@','Save in #@',1,J0OV)
               CALL FNZZ(J0OV,1,'Valve file',10,32,'ESV',
     ;                  2,VPFILE,JX)
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE AVP2VV(I,NOPA)
c
c      Setup ACTIONS
c
c      I=1 save file
c        2 return to main menu
c        3 Quit
c------------------------------------------------------------------------------
c    Setup file name
       CHARACTER*32  SUFILE
       COMMON /SUFVV/SUFILE
c------------------------------------------------------------------------------
       LOGICAL OK,YESZZ
c------------------------------------------------------------------------------
       IF (I.EQ.1)  THEN
c        set to check data and exit
           NOPA = 1
           RETURN
           ENDIF
       IF (I.EQ.2)  THEN
c        set to check data and exit
           NOPA = 2
           RETURN
           ENDIF
       IF (I.EQ.3) THEN
c        confirm quit
           IF (YESZZ('Do you really want to quit ESPCAM?')) STOP
c        no quit
           NOPA = 0
           RETURN
           ENDIF
c    improper request
c      CALL ERRFZZ('@','@Illegal action request.@@')
       NOPA = 0
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE  RVPDVV(IU,NDMAX,NAME,ND,FMAX,AD,FD,IERR)
c
c      Reads a new-style valve program file from opened unit IU
c      Checks that the array size ND <= NDMAX
c      Returns IERR=0 of ok, otherwise 1
c------------------------------------------------------------------------------
       DIMENSION AD(NDMAX),FD(NDMAX)
c------------------------------------------------------------------------------
       CHARACTER*48    NAME
c------------------------------------------------------------------------------
c    read name and size
       READ (IU,ERR=20,END=20) NAME,ND,FMAX
c    check size
       IF (ND.GT.NDMAX)  THEN
           CALL WARNZZ('@','@Valve program file too large@@')
           GOTO 20
           ENDIF
c    read the file
       READ (10,END=20,ERR=20) (AD(I),I=1,ND),(FD(I),I=1,ND)
       IERR = 0
       RETURN
c    file error
20     IERR=1
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE  WVPDVV(IU,NDMAX,NAME,ND,FMAX,AD,FD,IERR)
c
c      Writes a new-style unformatted valve program file to opened unit IU.
c      Returns IERR=0 of ok, otherwise 1.
c------------------------------------------------------------------------------
       DIMENSION AD(NDMAX),FD(NDMAX)
c------------------------------------------------------------------------------
       CHARACTER*48    NAME
c------------------------------------------------------------------------------
c    write file
       WRITE (IU,ERR=20) NAME,ND,FMAX
       WRITE (IU,ERR=20) (AD(I),I=1,ND),(FD(I),I=1,ND)
       IERR = 0
       RETURN
c    error writing file
20     IERR = 1
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE VPMPVV(IU,NAME,ND,AD,FD)
c
c      Writes a Matlab valve program plot file to open unit IU
c------------------------------------------------------------------------------
c    new file data
       CHARACTER*48    NAME
       DIMENSION       AD(ND),FD(ND)
c------------------------------------------------------------------------------
       WRITE (IU,1)
1      FORMAT (' clear'/' figure'/' subplot(1,1,1)')
       WRITE (IU,4) AD(1),FD(1)
c
4      FORMAT (' A = [ ',2(1PE12.4),'    ;')
       WRITE (IU,5) (AD(I),FD(I),I=2,ND-1)
5      FORMAT ('       ',2(1PE12.4),'    ;')
       WRITE (IU,6) AD(ND),FD(ND),NAME
6      FORMAT ('       ',2(1PE12.4),'  ] ;'/
     ;   'plot (A(:,1),A(:,2))'/
     ;   'xlabel (''Crank angle degrees past valve open'')'/
     ;   'ylabel (''Relative lift '')'/
     ;   'title  ('' ',A,' '')' )
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE  DVPTVV(IU,L,PROG,ND,AD,FD)
c
c      Displays a valve program table on unit IU.
c      No action for IU=0.
c
c      L=1 for intake, 2 for exhaust; 0 unspecified.
c------------------------------------------------------------------------------
       CHARACTER*48    PROG
       DIMENSION       AD(ND),FD(ND)
c------------------------------------------------------------------------------
c    no write for IU=0
       IF (IU.EQ.0)  RETURN
       IF (L.EQ.1)  THEN
               WRITE(IU,1) PROG
1              FORMAT (/' Intake valve program: ',A)
           ELSEIF (L.EQ.2)  THEN
               WRITE(IU,2) PROG
2              FORMAT (/' Exhaust valve program: ',A)
           ELSE
               WRITE (IU,3) PROG
3              FORMAT (/' Valve program: ',A)
           ENDIF
       WRITE (IU,4)
4      FORMAT(
     ; ' * Angles are in arbitrary units measured from valve opening.'/
     ; '   The curve is stretched to fit the open and close angles.'/
     ; ' * Lifts are in arbitrary units; max flow area set separately.'/
     ; ' * Linear interpolation is used between tabulated points.'/
     ; ' ============================================================='/
     ; '  angle  lift     angle  lift     angle  lift     angle  lift'/
     ; ' -------------------------------------------------------------')
       WRITE (IU,11) (AD(J),FD(J),J=1,ND)
11     FORMAT (4(F7.1,F7.3,2X))
c     write table ender
       WRITE (IU,12)
12     FORMAT(
     ; ' -------------------------------------------------------------')
       RETURN
       END
c*****************************************************************************
c
       SUBROUTINE OPFLVV(IU,NAME,KE,KF,OK)
c
c      Opens file NAME on unit IU and returns OK=.TRUE. or writes problem
c      message.
c
c       KE  .TRUE. if file must exist
c       KF  .TRUE. if file is formatted
c-----------------------------------------------------------------------------
       LOGICAL         KE,KF,OK
       CHARACTER*32    NAME
c-----------------------------------------------------------------------------
c    check for existence
       IF (KE)  THEN
           INQUIRE (FILE=NAME,EXIST=OK)
           IF (.NOT.OK)  THEN
               CALL FMESVV(2,'@','#','File # not found@',NAME)
               RETURN
               ENDIF
           ENDIF
c    open the file
       IF (KF) THEN
               OPEN(IU,FILE=NAME,ERR=90)
           ELSE
               OPEN(IU,FILE=NAME,FORM='UNFORMATTED',ERR=90)
           ENDIF
       OK = .TRUE.
       RETURN
c    file open error
90     CALL FMESVV(2,'@','#','File # not opened. Probable '//
     ;     'cause; in use by other application or by ESP '//
     ;     'elsewhere.@',NAME)
       OK = .FALSE.
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE FMESVV(K,ESC,INS,STRING,NAME)
c
c      Issues message (K=1) or warning (K=2) ESC-terminated STRING with
c      file name inserted where INS is found.
c-----------------------------------------------------------------------------
       PARAMETER   (LNAME=32)
       PARAMETER   (LMAX=256)
       CHARACTER*1 ESC,INS,STRING(*),NAME(32),TEXT(LMAX)
c-----------------------------------------------------------------------------
c    find end of name
       DO I=1,LNAME
           IF (NAME(I).EQ.' ') THEN
               N = I - 1
               GOTO 8
               ENDIF
           ENDDO
c    no blanks
       N = LNAME
c    set to scan the string
8      LS = 0
       LT = 1
       TEXT(LT) = ESC
c    continue the scan
10     LS = LS + 1
       IF (STRING(LS).EQ.INS)  THEN
c        insert the name
           DO I=1,N
               IF (LT.EQ.LMAX-2)  GOTO 40
               LT = LT + 1
               TEXT(LT) = NAME(I)
               ENDDO
           GOTO 10
           ENDIF
       IF (STRING(LS).EQ.ESC)  GOTO 40
       IF (LT.EQ.LMAX-2)  GOTO 40
       LT = LT + 1
       TEXT(LT) = STRING(LS)
       GOTO 10
c    end the string
40     TEXT(LT+1) = ESC
       TEXT(LT+2) = ESC
c    send the message
       IF (K.EQ.1)  THEN
               CALL MESSZZ(ESC,TEXT)
               CALL PAUSZZ(0)
           ELSE
               CALL WARNZZ(ESC,TEXT)
           ENDIF
       RETURN
       END
c******************************************************************************

max_stars_repo_name: kjfergu/esp

max_issues_repo_name: fergu/esp

max_forks_repo_name: fergu/esp