module matrix_mod
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    public :: print_matrix

contains

    subroutine print_matrix(a)
        real(kind=dp), dimension(:,:), intent(in) :: a
        integer :: r
        do r = 1, size(a, 1)
            print *, a(r, :)
        end do
    end subroutine print_matrix

end module matrix_mod


! This is the Fortran program containing
! - introduction to conditional statements and
! - the achar command
! - and the index command

program testingChars

implicit none

character(len=80) :: text
integer :: i

text = 'The intrinsic data type character stores characters and strings.'

i = index(text, 'character') ! using index to find the first occurence of the string 'character'

if (i /= 0) then
    print*, 'The word character found at position', i
    print*, 'in text: ', text
end if

end program testingChars


c adding external zone delay cost (extadd(mxext),extcst) to generalized cost field
c station 1, adding 4500 cents to abcst and bacst
c station 10 adding 1500 cents to abcst and bacst
c station 10 adding 3000 cents to abcst and bacst - try upping to 3000 to increase trip lengths
c station 11,12 adding 3000 cents to abcst and bacst
c spd of hov is 5mph > sov spd
c 1/25/05 	add code to automaticly generate turn prohibitors between two ramps if
c 		intersect with none ramps
c 2/2/05    cap fwy capacity to certain threashhold
c     hwycov to transcad conversion program
c
      parameter (mxramp=2500,mxrlk=1000,mxrt=500,mxnrt=10,mxzrt=50,
     *mxradt=12999,mxadt=9999)
      common /reccom/ srec,rlkarr
      include 'sandag.inc'
      include 'tcov.inc'
      include 'zone.inc'
c
c     program variables
c
      logical uniq(mxhca),stop,inff,used,zoneo(mxzn),hov3,toll,hot3,
     *first,endf,entry(mxhcn),exit(mxhcn),tsm,new,nused(mxhcn)
      integer*2 pfc(15),pjur(6),psph(20),fcarr(mxhca),fwysta(mxid),
     *cnnode(mxhcn),snode(mxhcn),adtmtr(9999),xang(2,mxhca,3),angle(3),
     *mjur(mxfc),mway(mxfc),mspd(mxfc),mmed(mxfc),mln(mxfc),mlf(mxfc,8),
     *gcsig(4,9,9),gcstp4(9,9),gcstp2(9),mtspd(mxfc),
     *kdist(mxrlk),jur(mxrlk),med(mxrlk),tfln(3,mxrlk),lfcap(10),
     *tfaux(mxrlk),hov(mxrlk),tfcnt(mxrlk),
     *tftl(mxrlk),tfrl(mxrlk),tfll(mxrlk),tfgc(mxrlk),
     *tfotm(mxrlk),tfptm(mxrlk),xan(2),xbn(2)
      integer*4 n1arr(mxhca),n2arr(mxhca),tpxy(mxtpn),
     *xapp(mxhcn),xstop(mxhcn),xdapp(mxhcn),
     *rlkarr(mxhca),srec(mxhca),luno,hovfwy(mxid),
     *nid(mxid),krno(mxrlk),kid(mxrlk),fc(mxrlk),tplb(3,mxrt),
     *spd(mxrlk),tfcap(3,mxrlk),znspd(3),
     *aatxfc(2),zonety(mxzn),aatmln(2),
     *lbid(mxhca),lbfc(mxhca),lbrt(mxhca),lid,xlb(2,mxhca,3),hrpk(24),
     *nodemrt(mxhcn),nodert(mxtpn,mxnrt),
     *tdzmrt(mxtdz),tdzrt(mxtdz,mxzrt),
     *tdzrtnode(mxtdz,mxzrt),tdzrtid(mxtdz,mxzrt),taztdz(mxzn)
      real xtdz(mxtdz),ytdz(mxtdz),xnode(mxtpn),ynode(mxtpn),
     *tdzrtdist(mxtdz,mxzrt),adtvols(29),adthst(mxradt)
      real rsafac(6),bordel(5,3,2),fwycap,auxcap,extadd(mxext),
     *dsum(mxid),tisum(mxid),tasum(mxid),remtoll(3),
     *stappf(3,2,mxbsta),hrpct(24),pkmax(3),
     *frmile(17),flmile(3,17),fcmile(17),frhour(17),
     *jrmile(3,10),jlmile(3,10),jcmile(3,10),jrhour(3,10)
      character*1 intnam(8),c1
      character*32 extnam
      character*150 idat
      character*1 nln(10),nxl(10)
      character*2 cdir
      character*3 njur(6),nmed(3)
      character*4 nhov(4)
      character*6 ncnt(9)
      character*7 nway(2)
      character*11 nfc(12)
      character*12 nrdir(4)
      character*17 nmjur(10)
      character*19 nminc(3)
      character*20 nmarr(mxhca),kname(mxrlk),name1,nmhov(4)
      data angle/0,-90,90/
      data first/.true./,stop/.false./,lnode/5000/
      data znspd/20,30,45/,xan/2,1/,xbn/1,2/
      data hrpk/1,1,1,1,1,1,2,2,2,1,1,1,1,1,1,3,3,3,1,1,1,1,1,1/
      data mspd/65,45,40,35,30,40,35,65,30,30,50,25,25,30/
      data mtspd/55,45,40,35,30,40,35,55,30,30,50,25,25,30/
      data mmed/2,2,2,1,1,1,1,1,1,1,1,1,1,1/
      data mway/1,2,2,2,2,2,2,1,1,2,2,2,2,2/
      data mln/4,3,2,2,1,1,1,1,1,1,1,1,1,1/
      data mjur/1,5,5,6,6,6,6,1,1,6,6,6,6,1/
      data extadd/4500,0,0,0,0,0,0,0,0,3000,3000,3000/
      data ncnt/'0-none','1-sig ','2-4stp','3-2stp','4-mtr-',
     *'5-mtr+','6-lrt ','7-toll','8-prev'/
      data nfc/'1:freeway  ','2:prime art',
     *         '3:major art','4:collector',
     *         '5:local col','6:rural col',
     *         '7:local    ','8:fwy-fwy  ',
     *         '9:ramp     ','10:access  ',
     *         '  sub-total','   total   '/
      data nminc/
     *'Incorporated Cities',
     *'Unincorporated Area',
     *'Regional Total      '/
      data nmjur/
     *'Caltrans Freeways',
     *'Caltrans HOVs    ',
     *'Caltrans Highways',
     *'Caltrans Ramps   ',
     *'CMP Routes       ',
     *'Non-CMP RSA Roads',
     *'Other RA Roads   ',
     *'Other Major Roads',
     *'Other Local Roads',
     *'Total            '/
      data njur/'1-s','2-c','3-r','4-r','5-m','6-l'/,rsafac/6*1.0/
      data nhov/'mix','hov2','hov3','toll'/
      data nln/'0','1','2','3','4','5','6','7','8','n'/
      data nxl/'0','1','2','3','4','5','6','f','x','n'/
      data nmed/'1:n','2:m','3:c'/
      data nrdir/'1-southbound','2-eastbound ','3-northbound',
     *'4-westbound '/
      data nway/'one-way','two-way'/
      data nmhov/'sbhov.sbfwy','nbhov.nbfwy',
     *'ebhov.ebfwy','wbhov.wbfwy'/
      data lfcap/250,250,150,100,100,100,100,100,100,0/
      data gcstp2/50,50,75,100,125,125,150,150,100/
      data lunin,lunerr,lunpr,luno,aatlun,natlun,lunsum,patlun,
     *seclun,luninf,lunsig,tatlun,lunxy,lunsta
     */11,12,13,14,15,16,17,18,19,20,21,22,23,24/
      data rlkarr/mxhca*99999999/
      data uniq/mxhca*.true./
      eject = ' '
      mlf(2,1)=2
      mlf(2,2)=1
      mlf(2,3)=1
      mlf(3,1)=1
      mlf(3,2)=1
      mlf(3,3)=1
      mlf(4,1)=1
      mlf(4,2)=1
      mlf(9,1)=1
      mlf(9,2)=1
      mlf(9,3)=1
      call dattim
c
c     create output files
c
      open (unit=lunerr,file='tchc.err')
      open (unit=lunsta,file='tchc-sta.prn')
      open (unit=luninf,file='tchc.info')
      open (unit=lunpr,file='tchc.pr')
      open (unit=luno,file='turns.csv')
      write(luno,20920)
      open (unit=lunsum,file='tchc.sum')
      open (unit=lunxy,file='zc.gen')
c
c     read program control
c
      psph(1)=9999
      pjur(1)=9999
      pfc(1)=1
      pfc(2)=2
      pfc(3)=3
      fnamo='tchc.in'
      open (unit=lunin,file=fnamo,status='old',err=9)
      read(lunin,10001) (psph(i),i=1,20)
      read(lunin,10001) (pjur(i),i=1,6)
      read(lunin,10001) (pfc(i),i=1,15)
      close(lunin)
c
c     read printout heading
c
    9 fnami='head'
      call opendata(lunin)
      if(istat.ne.0) go to 9000
      read(lunin,10003) cheadi
      call cheadr
      close(lunin)
c
c     read analysis year
c
      fnamo='hwyyear'
      open (unit=lunin,file=fnamo,status='old',err=11)
      go to 12
   11 fnamo='year'
      open (unit=lunin,file=fnamo,status='old',err=9000)
   12 icol=1
      read(lunin,10000,iostat=istat) idata,adata
      if(istat.ne.0) go to 9001
      call sd_getdat(idata,adata,icol,iyear,i2,i3,lunerr)
      close(lunin)
      tsm=.false.
      if(iyear.gt.2015) tsm=.true.
      open (unit=lunin,file=fnamo,status='old',err=13)
      tsm=.false.
   13 close(lunin)
      fnamo='notsm'
      if(iyear.lt.2010) go to 20
      if(.not.tsm) go to 20
      jyear=min(iyear,2020)
      xfac=1.0+(jyear-2010)*0.01
      do 14 i=1,4
      rsafac(i)=xfac
   14 continue
c    read arterial traffic count
c
   20 if(iyear.eq.2010) iadtyr = iyear-1982+1

	fnami='../data/histfill1982_2010'
      call opendata(lunin)
      if(istat.ne.0) go to 9000
      read(lunin,10009,iostat=istat) c1
      if(istat.ne.0) go to 9000
   16 read(lunin,10033,iostat=istat) aatadt,adtvols
      if(istat.ne.0) go to 18
      if(aatadt.lt.1.or.aatadt.gt.mxadt) go to 9030
      adthst(aatadt)=nint(adtvols(iadtyr)/100.0)
      go to 16
   18 close(lunin)

c
c     flag cbd zones (zonety=1)
c
      icol=2
      fnamo='zone.avrzone'
      open (unit=lunin,file=fnamo,status='old',err=21)
      go to 22
   21 fnamo='../data/zone.avrzone'
      open (unit=lunin,file=fnamo,status='old',err=9000)
   22 read(lunin,10000,iostat=istat) idata,adata
      if(istat.ne.0) go to 23
      call sd_getdat(idata,adata,icol,izone,iavr,i3,lunerr)
      if(izone.lt.1.or.izone.gt.mxzn) go to 9001
      if(iavr.eq.1) zonety(izone)=1
      go to 22
   23 close(lunin)
      call ozonep
      if(patio.ne.0) go to 9000
      patrec=2
   24 call rzonep
      if(patio.ne.0) go to 29
      if(patzon.lt.1.or.patzon.gt.mxzn) go to 9001
      mzone=max(mzone,patzon)
      xacres=patare/43560.
      if(zonety(patzon).lt.1) then
      zonety(patzon)=1
      if(xacres.gt.200) zonety(patzon)=2
      if(xacres.gt.5000) zonety(patzon)=3
      endif
      patrec=patrec+1
      go to 24
   29 close(patlun)
c
c     gcdata
c
   30 fnamo='gc'
      open (unit=lunin,file=fnamo,status='old',err=31)
      go to 33
   31 fnamo='../data/gc'
      open (unit=lunin,file=fnamo,status='old',err=9000)
   33 do 36 ifc=1,9
      read(lunin,10030,iostat=istat) (gcsig(4,ifc,itofc),itofc=1,9)
      if(istat.ne.0) go to 9000
   36 continue
      do 37 ifc=1,9
      read(lunin,10030,iostat=istat) (gcsig(3,ifc,itofc),itofc=1,9)
      if(istat.ne.0) go to 9000
   37 continue
      do 38 ifc=1,9
      read(lunin,10030,iostat=istat) (gcsig(2,ifc,itofc),itofc=1,9)
      if(istat.ne.0) go to 9000
   38 continue
      do 39 ifc=1,9
      read(lunin,10030,iostat=istat) (gcstp4(ifc,itofc),itofc=1,9)
      if(istat.ne.0) go to 9000
   39 continue
      close(lunin)
c
c     border delay times
c
      fnamo='border.del'
      open (unit=lunin,file=fnamo,status='old',err=41)
      go to 43
   41 fnamo='../data/border.del'
      open (unit=lunin,file=fnamo,status='old',err=9000)
   43 do 44 ibord=1,5
      read(lunin,10040,iostat=istat)
     *(bordel(ibord,ipk,1),bordel(ibord,ipk,2),ipk=1,3)
      if(istat.ne.0) go to 9000
   44 continue
      close(lunin)
c
c     read freeway-hov lane connections
c
      icol=2
      do 59 ifile=1,4
      fnami=nmhov(ifile)
      call opendata(lunin)
      if(istat.ne.0) go to 9000
   51 read(lunin,10000,iostat=istat) idata,adata
      if(istat.ne.0) go to 58
      call sd_getdat(idata,adata,icol,ihov,ifwy,i3,lunerr)
      if(ifwy.lt.1.or.ifwy.gt.mxid) go to 9001
      if(ihov.lt.1.or.ihov.gt.mxid) go to 51
      hovfwy(ihov)=ifwy
      go to 51
   58 close(lunin)
   59 continue
c
c     adt links with new meters
c
      fnamo='adtlk.mtr'
      open (unit=lunin,file=fnamo,status='old',err=61)
      go to 63
   61 fnamo='../data/adtlk.mtr'
      open (unit=lunin,file=fnamo,status='old',err=9000)
   63 read(lunin,10060,iostat=istat) aatadt,cdir
      if(istat.ne.0) go to 69
      idir=9
      i=index(cdir,'SB')
      if(i.gt.0) idir=1
      i=index(cdir,'EB')
      if(i.gt.0) idir=2
      i=index(cdir,'NB')
      if(i.gt.0) idir=3
      i=index(cdir,'WB')
      if(i.gt.0) idir=4
      adtmtr(aatadt)=idir
      go to 63
   69 close(lunin)
      fnamo='sta.hrpct'
      open (unit=lunin,file=fnamo,status='old',err=71)
      go to 73
   71 fnamo='../data/sta.hrpct'
      open (unit=lunin,file=fnamo,status='old',err=9000)
      read(lunin,10009,iostat=istat) c1
      if(istat.ne.0) go to 9000
   73 read(lunin,10070,iostat=istat)
     *ista,idir,hrpct
      if(istat.ne.0) go to 79
      if(ista.lt.1.or.ista.gt.mxbsta) go to 9070
      do ipk=1,3
      pkmax(ipk)=0.0
      end do
c
c     for peak periods use max hour
c
      do ihr=1,24
      ipk=hrpk(ihr)
      if(ipk.ne.1)
     *pkmax(ipk)=max(pkmax(ipk),hrpct(ihr))
      end do
c
c     for off-peak period use mid-day hour
c
      do ihr=11,13
      ipk=hrpk(ihr)
      pkmax(ipk)=max(pkmax(ipk),hrpct(ihr))
      end do
      do ipk=1,3
      stappf(ipk,idir,ista)=1.0/pkmax(ipk)
      end do
      go to 73
   79 close(lunin)
c     commented out until we decide on better way of handling peak spreading
c      if(iyear.lt.2020) go to 89
c      fnami='notdm'
c      call opendata(lunin)
c      if(istat.ne.0) go to 80
c      close(lunin)
c      go to 89
c   80 do idir=1,2
c      do ipk=2,3
c      do ista=1,999
c      stappf(ipk,idir,ista)=3.0
c      end do
c      end do
c      end do
   89 write(0,11002)
      fnami='../data/taz.tdz'
      call opendata(lunin)
	if(istat.ne.0) go to 9000
   95 read(lunin,10000,iostat=istat) idata,adata
      if(istat.ne.0) go to 96
      call sd_getdat(idata,adata,icol,izone,itdz,i3,lunerr)
      if(izone.lt.1.or.izone.gt.mxzn) go to 9001
      taztdz(izone)=itdz
      go to 95
   96 close(lunin)
      fnamo='../covs/tdzs/pat.adf'
      open(unit=patlun,convert='big_endian',file=fnamo,access=
     *'direct',form='unformatted',recl=12,status='old',err=9000)
       patrec=2
   98 call rzonep
      if(patio.ne.0) go to 99
      xtdz(patzon)=float(patx)
      ytdz(patzon)=float(paty)
      patrec=patrec+1
      go to 98
   99 close(patlun)
      call ohca
      if(aatio.ne.0) go to 9000
      aatrec=1
      mid=0
c
c     read hwycov aat and save data.
c
  100 call rhca
      if(aatio.ne.0) go to 129
      if(aathov(1).eq.3.and.(hov3.eq..false..or.hot3.eq..false.)) then
       hov3=.true. !flag whether any hov3+ facilities exist
       if(aattoll(1,1).gt.0.and.aatln(1,1,1).lt.9) hot3=.true. !flag whether any hot3+ facilities exist
       if(aattoll(2,1).gt.0.and.aatln(2,1,1).lt.9) hot3=.true. !flag whether any hot3+ facilities exist
       if(aattoll(3,1).gt.0.and.aatln(3,1,1).lt.9) hot3=.true. !flag whether any hot3+ facilities exist
      endif
      if(aathov(1).eq.4) toll=.true. !flag whether any toll facilities exist
      rlkarr(aatrec)=aatrt*1000+aatlk
      lbid(aatlb)=aatid
      lbfc(aatlb)=aatfc(1)
      lbrt(aatlb)=aatrt
      if(aatfc(1).eq.1) fwysta(aatid)=aatsta
      do idir=1,2 !loop through each direction for link
       in=aatarn(idir)
       itpn=aattpn(idir)

        if(in.lt.1.or.in.gt.mxhcn) then !check for valid node number
         write(lunerr,19100) aatrec,in,aatnm,aatxnm(idir)
         errf=.true.
         aatarn(idir)=mxhcn
         stop=.true.
        endif

       if(in.gt.mnode) mnode=in
       if(aattpn(idir).gt.mtpn) mtpn=aattpn(idir)
       if(aatfc(1).le.9) then  !check for non-zone connector links
        xapp(in)=xapp(in)+1
        if(aatcnt(idir,1).eq.3) xstop(in)=xstop(in)+1
        if(aatway(1).eq.2.or.idir.eq.1) xdapp(in)=xdapp(in)+1

c       save route numbers at node

        mnrt=nodemrt(itpn)
        new=.true.
         if(mnrt.gt.0) then !if node-route connenctions already exist then find out if this is a new one
          do irt=1,mnrt !loop through routes at this node
           if(aatrt.eq.nodert(itpn,irt)) new=.false.
          end do !end of old route loop
         end if !end of old connection check

         if(new) then !if this is a new route connection then add to matrix
          mnrt=mnrt+1
           if(mnrt.gt.mxnrt) then
            write(lunerr,19104)
            errf=.true.
            go to 9999
           endif

          nodemrt(itpn)=mnrt
          nodert(itpn,mnrt)=aatrt
        end if !end of new route check
       end if !end of check for non-zone connector links
      end do ! end of directional loop

      if(aatfc(1).lt.1.or.aatfc(1).gt.mxfc) go to 128
      srec(aatrec)=aatrec
      nmarr(aatrec)=aatnm
      n1arr(aatrec)=aatarn(1)
      n2arr(aatrec)=aatarn(2)
      if(aatfc(1).eq.10) go to 120
      entry(aatarn(1))=.true.
      exit(aatarn(2))=.true.
      fcarr(aatrec)=aatfc(1)

c     for HOV lanes sum up unadjusted and adjusted times on adjacent main lanes

      if(aatfc(1).eq.1) then
       do id=1,mxid
        if(hovfwy(id).eq.aatid) then
        xdist=aatlen/5280.0
        dsum(id)=dsum(id)+xdist
        if(aatspd(1).lt.1.or.aatspd(1).gt.75) aatspd(1)=mspd(aatfc(1))
        if(aattspd(1).lt.1.or.aattspd(1).gt.75)
     *    aattspd(1)=mtspd(aatfc(1))
        ispd=aatspd(1)
        tisum(id)=tisum(id)+xdist/float(ispd)
        if(aatasp.gt.0.and.aatasp.le.75) ispd=aatasp
        tasum(id)=tasum(id)+xdist/float(ispd)
        end if
       end do
      end if
  107 if(aatway(1).eq.1) go to 128
      entry(aatarn(2))=.true.
      exit(aatarn(1))=.true.
      go to 128
  120 fcarr(aatrec)=aatfc(1)
      go to 128
  128 aatrec=aatrec+1
      if(aatrec.le.mxhca) go to 100
      write(lunerr,19128)
      errf=.true.
      go to 9999
  129 if(stop) go to 9999
      naat=aatrec-1
      write(0,11004) naat
      if(stop) go to 9999
      do id=1,mxid
      denom=tisum(id)
      if(denom.gt.0.0)
     *tisum(id)=dsum(id)/denom
      denom=tasum(id)
      if(denom.gt.0.0)
     *tasum(id)=5.0+dsum(id)/denom
      end do
      fnamo='info/arc.dir'
      open(unit=lunin,convert='big_endian',file=fnamo,access=
     *'direct',form='unformatted',recl=95,status='old',err=9000)
      infrec=1
  132 read(lunin,rec=infrec,iostat=istat) extnam,intnam,idat
      if(istat.ne.0) go to 9130
      i=index(extnam,'HWYCOV.TRN')
      if(i.gt.0) go to 133
      infrec=infrec+1
      go to 132
  133 write(fnamo,20130) (intnam(i),i=4,7)
      close(lunin)
      open(unit=tatlun,convert='big_endian',file=fnamo,access=
     *'direct',form='unformatted',recl=7,status='old',err=9000)
c
c     preset arcs on same route as through move
c
      tatrec=1
  134 call rhct
      if(tatio.ne.0) go to 139
      if(fcarr(tatlb2).eq.10) go to 138
      if(lbrt(tatlb1).ne.lbrt(tatlb2)) go to 138
      if(tatlb.eq.n1arr(tatlb1)) then
      idir=1
      else
       if(tatlb.eq.n2arr(tatlb1)) then
       idir=2
       else
       go to 9140
       endif
      endif
        ipos=1
      if(xlb(idir,tatlb1,ipos).gt.0) go to 138
      xlb(idir,tatlb1,ipos)=tatlb2
      xang(idir,tatlb1,ipos)=iang
  138 tatrec=tatrec+1
      go to 134
  139 tatrec=1
  140 call rhct
      if(tatio.ne.0) go to 149
      if(fcarr(tatlb2).eq.10) go to 148
      if(lbrt(tatlb1).eq.lbrt(tatlb2)) go to 148
      iang=nint(tatang)
      if(tatlb.eq.n1arr(tatlb1)) then
      idir=1
      else
       if(tatlb.eq.n2arr(tatlb1)) then
       idir=2
       else
       go to 9140
       endif
      endif
      ipos=2
      if(iang.gt.0) ipos=3
      if(iang.gt.-45.and.iang.le.45) ipos=1
      if(tatlb1.eq.22011) then
      print *,tatlb1
      endif
      if(xlb(idir,tatlb1,ipos).gt.0) go to 141
      xlb(idir,tatlb1,ipos)=tatlb2
      xang(idir,tatlb1,ipos)=iang
      go to 148
  141 idiff1=abs(angle(ipos)-xang(idir,tatlb1,ipos))
      idiff2=abs(angle(ipos)-iang)
      if(idiff1.gt.idiff2) go to 144
      mdiff=999
      mpos=0
      do 142 jpos=1,3
      if(jpos.eq.ipos) go to 142
      idiff=abs(angle(jpos)-iang)
      if(idiff.lt.mdiff) then
      mdiff=idiff
      mpos=jpos
      endif
  142 continue
      if(xlb(idir,tatlb1,mpos).gt.0) go to 143
      xlb(idir,tatlb1,mpos)=tatlb2
      xang(idir,tatlb1,mpos)=iang
      go to 148
  143 idiff1=abs(angle(mpos)-xang(idir,tatlb1,mpos))
      idiff2=abs(angle(mpos)-iang)
      if(idiff2.gt.idiff1) go to 148
      xlb(idir,tatlb1,mpos)=tatlb2
      xang(idir,tatlb1,mpos)=iang
      go to 148
  144 kang=xang(idir,tatlb1,ipos)
      klb=xlb(idir,tatlb1,ipos)
      xlb(idir,tatlb1,ipos)=tatlb2
      xang(idir,tatlb1,ipos)=iang
      mdiff=999
      mpos=0
      do 145 jpos=1,3
      if(jpos.eq.ipos) go to 145
      idiff=abs(angle(jpos)-kang)
      if(idiff.lt.mdiff) then
      mdiff=idiff
      mpos=jpos
      endif
  145 continue
      if(xlb(idir,tatlb1,mpos).gt.0) go to 146
      xlb(idir,tatlb1,mpos)=klb
      xang(idir,tatlb1,mpos)=kang
      go to 148
  146 idiff1=abs(angle(mpos)-xang(idir,tatlb1,mpos))
      idiff2=abs(angle(mpos)-kang)
      if(idiff2.gt.idiff1) go to 148
      xlb(idir,tatlb1,mpos)=klb
      xang(idir,tatlb1,mpos)=kang
  148 tatrec=tatrec+1
      go to 140
  149 tatrec=1
  150 call rhct
      if(tatio.ne.0) go to 159
      if(fcarr(tatlb2).ne.10) go to 158
      iang=nint(tatang)
      if(tatlb.eq.n1arr(tatlb1)) then
      idir=1
      else
       if(tatlb.eq.n2arr(tatlb1)) then
       idir=2
       else
       go to 9140
       endif
      endif
      ipos=2
      if(iang.gt.0) ipos=3
      if(iang.gt.-45.and.iang.le.45) ipos=1
      if(xlb(idir,tatlb1,ipos).gt.0) go to 158
      xlb(idir,tatlb1,ipos)=tatlb2
      xang(idir,tatlb1,ipos)=iang
  158 tatrec=tatrec+1
      go to 150
c
c     sort records end-to-end by name.
c
  159 write(0,11006)
      call recsrt
      do 398 i=1,naat
      if(srec(i).ne.0) go to 398
      write(0,19399) i
      stop=.true.
  398 continue
      if(stop) go to 9999
      write(0,11008)
c
c     rhca nat file
c
      write(0,11010)
      call ohcn
      natrec=1

c
c     read node point attribute table saving arrays of node data
c     for node
c
  410 call rhcn
      if(natio.ne.0) go to 419
      if(nattpn.lt.1.or.nattpn.gt.mxtpn) go to 9000
      xnode(nattpn)=float(natx)
      ynode(nattpn)=float(naty)
      nattmp=0
      if(natlb.gt.0.and.natlb.le.mnode) go to 412
      nattmp=1
      write(lunerr,19411) natlb,natxnm(1),natxnm(2)
      errf=.true.
      go to 418
  412 snode(natlb)=natsph
      cnnode(natlb)=natcnt(1)
      if(xdapp(natlb).gt.4) xdapp(natlb)=4
      if(xdapp(natlb).lt.2) xdapp(natlb)=2
      if(nattpn.gt.0.and.nattpn.le.mxtpn) go to 413
      nattmp=2
      write(lunerr,19412) natlb,nattpn,natxnm(1),natxnm(2)
      errf=.true.
      go to 418
  413 jjxy=natx+naty
      if(tpxy(nattpn).gt.0) go to 414
      tpxy(nattpn)=jjxy
      go to 418
  414 if(tpxy(nattpn).eq.jjxy) go to 415
      nattmp=3
      write(lunerr,19413) natlb,nattpn,natxnm(1),natxnm(2)
      errf=.true.
      go to 418
  415 if(xapp(natlb).lt.5) go to 416
      nattmp=4
      write(luninf,19414) natlb,natxnm(1),natxnm(2)
      inff=.true.
      go to 418
  416 if(natcnt(1).ne.3) go to 418
      idiff=xapp(natlb)-xstop(natlb)
      if(idiff.lt.3) go to 418
      nattmp=5
      write(luninf,19415) natrec,natxnm(1),natxnm(2)
      inff=.true.
  418 natiuc=(natcnt(1)+1)*10+1
c
c     insert hnode into nodeid for exporting to transCAD
      natid=nattpn
      call whcn
      natrec=natrec+1
      go to 410
  419 close(natlun)
c
c     reread aat for final time in route-link order.
c
      iaat=1
      iline=99
      ipage=1
      isec=20000
      secdst=0.0
  500 irtno=rlkarr(iaat)/1000
      ilkno=rlkarr(iaat)-irtno*1000
      aatrec=srec(iaat)
      krec=0
      isec=isec+1
      secdst=0.0
  501 call rhca
      if(aatio.ne.0) go to 9000
      if(aatarn(2).lt.1.or.aatarn(2).gt.mxhcn) aatarn(2)=mxhcn
      if(aatarn(1).lt.1.or.aatarn(1).gt.mxhcn) aatarn(1)=mxhcn
	if (aatfc(1).gt.1.and.aatfc(1).lt.8)then
	   aatvol=0
	   if (aatadt.gt.0.and.adthst(aatadt).gt.0)aatvol=adthst(aatadt)
	endif
      extcst=0
      isph=snode(aatarn(2))/100
      jsph=snode(aatarn(1))/100
      inc=1
      if(isph.eq.19.or.jsph.eq.19) inc=2
      ijur=aatjur(1)+3
      if(ijur.eq.4) ijur=3
      if(ijur.eq.3.and.aatfc(1).eq.1) ijur=1
      if(aatfc(1).eq.1.and.(aathov(1).eq.2.or.aathov(1).eq.3)) ijur=2
      if(ijur.eq.3.and.aatfc(1).eq.8) ijur=4
      if(ijur.eq.3.and.aatfc(1).eq.9) ijur=4
      if(nid(aatid).eq.0) go to 504
      do 502 i=1,mxid
      if(nid(i).eq.0) go to 504
  502 continue
      go to 9502
  503 aatid=i
  504 nid(aatid)=nid(aatid)+1
      aattmp(1)=0
      aattmp(2)=0
      if(aatfc(1).eq.10) go to 511
      if(.not.entry(aatarn(2))) go to 505
      if(.not.exit(aatarn(2))) go to 505
      if(.not.entry(aatarn(1))) go to 505
      if(.not.exit(aatarn(1))) go to 505
      go to 510
  505 write(luninf,19505)
     *aatid,aatnm,aatxnm(2),aatxnm(1),aatarn(2),aatarn(1)
      aattmp(1)=1
      inff=.true.
  510 if(aatfc(1).ge.1.and.aatfc(1).le.mxfc) go to 511
      aattmp(1)=2
      write(lunerr,19510) aatid,aatnm,aatxnm(2),aatxnm(1),aatfc(1)
      errf=.true.
      stop=.true.
      go to 878
  511 if(aatfc(1).eq.1) go to 516
      if(aatid.eq.14836) then
      print *, aatid
      endif
      do 513 idir=1,2
      if(aatway(1).eq.1.and.idir.gt.1) go to 513
      aattlb(idir)=xlb(idir,aatlb,1)
      aatrlb(idir)=xlb(idir,aatlb,2)
      aatllb(idir)=xlb(idir,aatlb,3)
c
c     for ramps add turn probibitors for when through link is also a ramp and link
c     itersects with arterial
c
      if(aatfc(1).eq.9) then
       ilb=aattlb(idir)
       if(ilb.gt.0.and.lbfc(ilb).eq.9) then
        id=lbid(ilb)
        ilb=(aatrlb(idir))
        irfc=0
        if(ilb.gt.0) irfc=lbfc(ilb)
        ilb=(aatllb(idir))
        ilfc=0
        if(ilb.gt.0) ilfc=lbfc(ilb)
         if(irfc.ge.2.and.irfc.le.7) then
         write(luno,20925) aatid,id
         else
         if(ilfc.ge.2.and.ilfc.le.7) write(luno,20925) aatid,id
         endif
       endif
      endif
      aatxfc(idir)=7
      tatlb1=xlb(idir,aatlb,2)
      tatlb2=xlb(idir,aatlb,3)
      ifc1=10
      ifc2=10
      if(tatlb1.gt.0) ifc1=fcarr(tatlb1)
      if(tatlb2.gt.0) ifc2=fcarr(tatlb2)
      if(ifc2.lt.ifc1) go to 512
      ifc=ifc1
      if(ifc.lt.10) aatxnm(idir)=nmarr(tatlb1)
      if(ifc.lt.2.or.ifc.gt.7) go to 513
      aatxfc(idir)=ifc
      go to 513
  512 ifc=ifc2
      if(ifc.lt.10) aatxnm(idir)=nmarr(tatlb2)
      if(ifc.lt.2.or.ifc.gt.7) go to 513
      aatxfc(idir)=ifc
  513 continue
      go to 520
  516 aatxfc(1)=7
      aatxfc(2)=7
  520 iln=aatln(1,1,1)+aatln(1,2,1)
      if(aatfc(1).eq.10) go to 580
      aatsec=aatadt
      if(aatsec.gt.0) go to 530
      secdst=secdst+aatlen
      if(aatxfc(1).le.3.and.secdst.gt.5280.0) go to 525
      aatsec=isec
      secdst=secdst+aatlen
      go to 530
  525 isec=isec+1
      aatsec=isec
      secdst=aatlen
c
c     fill in missing initial non-directional data with defaults.
c
  530 if(aatjur(1).lt.1.or.aatjur(1).gt.6) aatjur(1)=mjur(aatfc(1))
      if(aathov(1).lt.1.or.aathov(1).gt.4) aathov(1)=1
      if(aattrk(1).lt.1.or.aattrk(1).gt.7) aattrk(1)=1
      if(tasum(aatid).gt.50.0.and.tasum(aatid).lt.90.0) go to 531
      if(aatspd(1).lt.1.or.aatspd(1).gt.75) aatspd(1)=mspd(aatfc(1))
      if(aattspd(1).lt.1.or.aattspd(1).gt.75)
     *  aattspd(1)=mtspd(aatfc(1))
      ispd=aatspd(1)
      if(aatasp.gt.0.and.aatasp.le.75) ispd=aatasp
      go to 532
  531 ispd=nint(tisum(aatid))
      aatspd(1)=ispd
      ispd=nint(tasum(aatid))
      aatasp=ispd
  532 if(aatway(1).lt.1.or.aatway(1).gt.2) aatway(1)=mway(aatfc(1))
      if(aatmed(1).lt.1.or.aatmed(1).gt.3) aatmed(1)=mmed(aatfc(1))
      do 539 idir=1,2
      if(idir.eq.2.and.aatway(1).eq.1) go to 537
      aatmln(idir)=0
      do 533 ipk=1,3
      if(aatln(ipk,idir,1).lt.1.or.aatln(ipk,idir,1).gt.8) go to 533
      aatmln(idir)=max(aatmln(idir),aatln(ipk,idir,1))
  533 continue
      if(aatmln(idir).lt.1) aatmln(idir)=mln(aatfc(1))
      do 535 ipk=1,3
      if(aatln(ipk,idir,1).ge.1.and.aatln(ipk,idir,1).le.9) go to 535
      if(idir.eq.2) go to 534
      aatln(ipk,idir,1)=aatmln(idir)
      go to 535
  534 aatln(ipk,idir,1)=aatln(ipk,1,1)
  535 continue
      if(aataux(idir,1).lt.1.or.aataux(idir,1).gt.9) aataux(idir,1)=0
c
c     determine control at aatarn(1) from node data
c
      icnt=cnnode(aatarn(idir))
      if(icnt.eq.4.and.aatfc(1).eq.1) icnt=0
      if(icnt.eq.5.and.aatfc(1).eq.1) icnt=0
      if(icnt.eq.3) go to 536
      aatcnt(idir,1)=icnt
      if(aatcnt(idir,1).gt.8) aatcnt(idir,1)=0
  536 if(aatcnt(idir,1).lt.1.or.aatcnt(idir,1).gt.7) go to 538
      if(aattl(idir,1).lt.1.or.aattl(idir,1).gt.9)
     *aattl(idir,1)=aatln(1,idir,1)
      if(aatrl(idir,1).lt.1.or.aatrl(idir,1).gt.9) aatrl(idir,1)=0
      if(aatll(idir,1).lt.1.or.aatll(idir,1).gt.9)
     *aatll(idir,1)=mlf(aatfc(1),aatcnt(idir,1))
      go to 539
  537 aatln(1,idir,1)=0
      aatln(2,idir,1)=0
      aatln(3,idir,1)=0
      aataux(idir,1)=0
      aatcnt(idir,1)=0
  538 aattl(idir,1)=0
      aatrl(idir,1)=0
      aatll(idir,1)=0
  539 continue
      isph=snode(aatarn(2))/100
      jsph=snode(aatarn(1))/100
      go to 590
  580 aatnm='zone connector'
      ian=aattpn(2)
      ibn=aattpn(1)
      in=ian
      jn=ibn
      if(ian.le.mxzn) go to 581
      if(ibn.le.mxzn) go to 582
      aattmp(1)=6
      write(lunerr,19580) aatid,ian,ibn,in
      errf=.true.
      go to 590
  581 if(ibn.ge.mxzn) go to 583
      aattmp(1)=7
      write(lunerr,19581) aatrec,aatarn(2),aatarn(1),in
      errf=.true.
      go to 583
  582 in=ibn
      jn=aatarn(2)
      aattmp(2)=1
  583 zoneo(in)=.true.
      aatjur(1)=6
      aatway(1)=2
      aatspd(1)=znspd(zonety(in))
      aattspd(1)=znspd(zonety(in))
      ispd=aatspd(1)
      aatmed(1)=1
      aathov(1)=1
      aattrk(1)=1
      if (in.le.mxext) extcst=extadd(in)
      do 587 idir=1,2
      aataux(idir,1)=0
      aatln(1,idir,1)=1
      aatln(2,idir,1)=1
      aatln(3,idir,1)=1
      aatcnt(idir,1)=0
      aattl(idir,1)=0
      aatrl(idir,1)=0
      aatll(idir,1)=0
  587 continue

c     save tdz nodes for shortest tdz connection to each route

      itdz=taztdz(in)
      aattmp(1)=itdz
      xz=xtdz(itdz)
      yz=ytdz(itdz)
      xn=xnode(jn)
      yn=ynode(jn)
      xdist=sqrt((xz-xn)**2+(yz-yn)**2) !distance from tdz centroid to node
      mzrt=tdzmrt(itdz)
      mnrt=nodemrt(jn)
       if(mzrt.gt.0) then !if tdz-route connenctions already exist then find out if this is a new one
        do irt=1,mnrt !loop through routes at this node
          irtno=nodert(jn,irt)
          new=.true.

           do jrt=1,mzrt !loop through existing connections
            jrtno=tdzrt(itdz,jrt)
            zdist=tdzrtdist(itdz,jrt)
             if(irtno.eq.jrtno) then !if new route matches old route then this isn't a new connection
              new=.false.
               if(xdist.lt.zdist) then !if it is an old connection this may be a shorter distance
                tdzrtdist(itdz,jrt)=xdist
                tdzrtnode(itdz,jrt)=jn
               end if !end of distance check
             end if !end of new connection check
            end do !end of extisting tdz-route connections loop

          if(new) then !if this is a new route connection then add to matrix
           mzrt=mzrt+1
            if(mzrt.gt.mxzrt) then
             write(lunerr,19582)
             errf=.true.
             go to 9999
            endif
           mmzrt=max(mmzrt,mzrt)
           tdzmrt(itdz)=mzrt
           tdzrt(itdz,mzrt)=irtno
           tdzrtdist(itdz,mzrt)=xdist
           tdzrtnode(itdz,mzrt)=jn
           tdzrtid(itdz,mzrt)=aatid !re-use id numbers for tdz connections
          endif !end of new check
        end do !end of loop through node routes
       else !this is the first connection for tdz

        do irt=1,mnrt !loop through routes at this node
          irtno=nodert(jn,irt)
          mzrt=mzrt+1
          tdzmrt(itdz)=mzrt
          tdzrt(itdz,mzrt)=irtno
          tdzrtdist(itdz,mzrt)=xdist
          tdzrtnode(itdz,mzrt)=jn
          tdzrtid(itdz,mzrt)=aatid !re-use id numbers for tdz connections
        end do !end of loop through node routes

       endif !end of number of connections check
c
c     fill in fields needed for transcad
c
  590 xdist=aatlen/5280.0
      xspd=float(ispd)

c     convert per mile toll cost to actual toll

       do ipk=1,3
        xtoll=float(aattoll(ipk,1))*xdist+remtoll(ipk)
        itoll=nint(xtoll)
        remtoll(ipk)=xtoll-float(itoll)
c     added by jor and zou for ML tolling on very short links, July, 2010
        if(aattoll(ipk,1).gt.0.and.itoll.eq.0)itoll=1
        aattoll(ipk,1)=itoll
       enddo
      xtime=xdist*60./xspd
      aatcst=xdist*15.
      ista=aatsta
      if(aathov(1).eq.2.or.aathov(1).eq.3) then
       ista=0
       ifwy=hovfwy(aatid)
       if(ifwy.gt.0) ista=fwysta(ifwy)
      endif
      if(ista.lt.1.or.ista.gt.mxbsta.or.aatfc(1).ne.1) ista=1
      do 699 idir=1,2
      aattc(idir)=999.999
      do 698 ipk=1,3
      aatlt(ipk,idir)=999.0
      aatxt(ipk,idir)=0.0
      aatlc(ipk,idir)=999999.0
      aatxc(ipk,idir)=999999.0
      aathc(ipk,idir)=0.0
      if(aatway(1).eq.1.and.idir.eq.2) go to 698
      if(aatln(ipk,idir,1).eq.9) go to 698
      aatlt(ipk,idir)=xtime
      if(aatfc(1).eq.10) go to 698
       if(aatfc(1).eq.1) then
        iidir=1
        i=index(aatnm,'NB')
        if(i.gt.0) iidir=2
        i=index(aatnm,'WB')
        if(i.gt.0) iidir=2
        xppf=stappf(ipk,iidir,ista)
         if(xppf.lt.1.0.or.xppf.gt.15.0) then
          write(lunsta,19698) ista,xppf
c          errf=.true.
          xppf=stappf(ipk,iidir,1)
         endif
       else
        xppf=stappf(ipk,idir,ista)
       endif
  591 fwycap=2000.0
      auxcap=1200.0
      iapp=xdapp(aatarn(idir))
      xadd=0.0
      if(aatfc(1).eq.1) go to 601
      if(aatfc(1).eq.8) go to 605
      if(aatfc(1).eq.9) go to 606
      if(aatplc(idir).eq.950.and.aatln(ipk,idir,1).lt.2) then
      xcap=950.0
      else
      xcap=float(aatln(ipk,idir,1))*1800.-300.
       if(aatmed(1).lt.2) xcap=xcap-200.
      endif
      go to 608
  601 if(aathov(1).eq.2.or.aathov(1).eq.3) then
       !changed from 1600 to 2000. Consistent with GP Lanes
       xcap=float(aatln(ipk,idir,1))*2000.0
       go to 608
      endif
      if(iyear.ge.2015) then
       if(aatadt.eq.552.or.aatadt.eq.553) aatplc(1)=2000
       if(aatsta.eq.935.or.aatsta.eq.980.or.aatsta.eq.999)
     * aatplc=2200
      endif
      if(aatplc(1).ge.1600.and.aatplc(1).le.2400)
     *fwycap=float(aatplc(1))
      fwycap=min(fwycap,2100.0)
      if(aatsta.ne.936) fwycap=max(fwycap,1900.0) ! don't let capacity go lower than 1900 except for SR-94 coming into CBD
      xcap=float(aatln(ipk,idir,1))*fwycap+float(aataux(idir,1))*auxcap
      if(.not.tsm) go to 608
      iadt=aatadt
      if(iadt.lt.1.or.iadt.gt.9999) iadt=9999
      imtr=adtmtr(iadt)
      if(imtr.lt.1) go to 608
      if(imtr.eq.9) go to 603
      iidir=0
      i=index(aatnm,'SB')
      if(i.gt.0) iidir=1
      i=index(aatnm,'EB')
      if(i.gt.0) iidir=2
      i=index(aatnm,'NB')
      if(i.gt.0) iidir=3
      i=index(aatnm,'WB')
      if(i.gt.0) iidir=4
      if(iidir.ne.imtr) go to 608
  603 xcap=xcap*1.10
      fwycap=fwycap*1.10
      go to 608
  605 i=index(aatnm,'ACCESS')
       if(i.gt.0) then
        aathc(ipk,idir)=9999
        aatlc(ipk,idir)=999999
        go to 609
       else
        xcap=float(aatln(ipk,idir,1))*1800.0
        go to 608
       endif
  606 xcap=float(aatln(ipk,idir,1))*1200.0
  608 aathc(ipk,idir)=xcap
      aatlc(ipk,idir)=xcap*xppf
  609 ith=aattl(idir,1)
      irt=aatrl(idir,1)
      ilf=aatll(idir,1)
      if(ith.gt.7) ith=0
      if(irt.gt.7) irt=0
      if(ilf.gt.7) ilf=0
      if(ith.eq.7) ith=1
      if(irt.eq.7) irt=1
      if(ilf.eq.7) ilf=1
      if(ith.lt.1) then
      iapp=3
      if(irt.gt.ilf) then
      ith=irt
      irt=0
      else
      ith=ilf
      ilf=0
      endif
      endif
      if(aatcnt(idir,1).eq.1) go to 610
      if(aatcnt(idir,1).eq.2) go to 620
      if(aatcnt(idir,1).eq.3) go to 630
      if(aatcnt(idir,1).eq.4.and.ipk.gt.1) go to 640
      if(aatcnt(idir,1).eq.5.and.ipk.gt.1) go to 650
      if(aatcnt(idir,1).eq.6) go to 660
      if(aatcnt(idir,1).eq.7) go to 670 !toll booths
      go to 698
  610 aatxt(ipk,idir)=0.17
      if(aatgc(idir).lt.10)
     *aatgc(idir)=gcsig(iapp,aatfc(1),aatxfc(idir))
      gcth=float(aatgc(idir))/100.0
      gcrt=float(aatgc(idir))/100.0
      xcap=float(ith)*1800.*gcth
      xlfcap=float((ilf+irt)*lfcap(aatfc(1)))
      xcap=xcap+xlfcap
      if(xcap.lt.1000.) xcap=1000.0
      aatxc(ipk,idir)=xcap*rsafac(aatjur(1))*xppf
      aathc(ipk,idir)=xcap*rsafac(aatjur(1))
      go to 698
  620 aatxt(ipk,idir)=0.20
      if(aatgc(idir).lt.1)
     *aatgc(idir)=gcstp4(aatfc(1),aatxfc(idir))
      gcth=float(aatgc(idir))/100.0
      gcrt=float(aatgc(idir))/100.0
      xcap=float(ith)*1800.*gcth
      xlfcap=float((ilf+irt)*lfcap(aatfc(1)))
      xcap=xcap+xlfcap
      if(xcap.lt.500.) xcap=500.0
      aatxc(ipk,idir)=xcap*xppf
      aathc(ipk,idir)=xcap
      go to 698
  630 aatxt(ipk,idir)=0.20
      aatgc(idir)=gcstp2(aatxfc(idir))
      gcth=float(aatgc(idir))/100.0
      gcrt=float(aatgc(idir))/100.0
      gclf=float(aatgc(idir))/100.0
      if(irt.ne.7) go to 632
      gcrt=1.0
      irt=1
  632 xcap=float(ith)*500.*gcth+float(irt)*500.*gcrt+
     *float(ilf)*500.*gclf
      if(xcap.lt.500.) xcap=500.0
      aatxc(ipk,idir)=xcap*xppf
      aathc(ipk,idir)=xcap
      go to 698
  640 aatxt(ipk,idir)=0.50
      xcap=1000.
      if(aatgc(idir).lt.1) go to 641
      gcth=float(aatgc(idir))/100.0
      xcap=xcap*gcth
  641 aatxc(ipk,idir)=xcap*xppf
      aathc(ipk,idir)=xcap
      go to 698
  650 aatxt(ipk,idir)=0.50
      xcap=1000.
      if(aatgc(idir).lt.1) go to 651
      gcth=float(aatgc(idir))/100.0
      xcap=xcap*gcth
  651 aatxc(ipk,idir)=xcap*xppf
      aathc(ipk,idir)=xcap
      go to 698
c  660 aatxc(ipk,idir)=float(ith+irt+ilf)*1300.*xppf !source of this equation is unknown
c      aathc(ipk,idir)=float(ith+irt+ilf)*1300.
  660 aatxt(ipk,idir)=0.02 !RCU - changed to ~1 second delay/veh (T:\data\RailCrossingDelay.xls)
      go to 698
  670 ith=aattl(idir,1)
      if(ith.lt.aatmln(idir)) ith=aatmln(idir)
      aatxc(ipk,idir)=float(ith)*500.*xppf !Period Intersection Capacity = 500 veh/lane/hr * # of lanes * peak period factor
      aathc(ipk,idir)=float(ith)*500. !Hourly Capacity = 500 veh/lane/hr * # of lanes
      i=index(aatnm,'BORDER')
      if(i.gt.0) go to 672
c  Sphere 3 = Coronado; Sphere 14 = City of SD; jsph = Destination Sphere
      if(jsph.ne.3.and.jsph.ne.14) go to 671
c    Coronado and City of SD section
      aatxt(ipk,idir)=1.0 !Intersection time = 1 minute
      if(ipk.eq.1.and.idir.eq.1) aatcst=aatcst+50.0 !Extra cost (toll booth) = 50 cents
      go to 698
c    Other Cities section
  671 aatxt(ipk,idir)=1.0 !Intersection time = 1 minute
      if(ipk.eq.1.and.idir.eq.1) aatcst=aatcst+25.0 !Extra cost (toll booth) = 25 cents
      go to 698
  672 i=index(aatnm,'YSIDRO')
      if(i.gt.0) ibord=1
      i=index(aatnm,'OTAY')
      if(i.gt.0) ibord=2
      i=index(aatnm,'EAST')
      if(i.gt.0) ibord=3
      i=index(aatnm,'TECATE')
      if(i.gt.0) ibord=4
      i=index(aatnm,'JACUMBA')
      if(i.gt.0) ibord=5
      iidir=1
      i=index(aatnm,'NB')
      if(i.gt.0) iidir=2
      aatxt(ipk,idir)=bordel(ibord,ipk,iidir)
  698 continue
      if(aatfc(1).eq.1) aatplc(idir)=nint(fwycap)
      if(idir.ne.1) go to 6981
      if(aathov(1).eq.2.or.aathov(1).eq.3) go to 6981
      i=index(aatnm,'AUX')
      if(i.gt.0) go to 6981
      frmile(aatfc(1))=frmile(aatfc(1))+xdist
      if(aatfc(1).ne.10)
     *jrmile(inc,ijur)=jrmile(inc,ijur)+xdist
 6981 if(aatway(1).eq.1.and.idir.eq.2) go to 699
      ihov=1
      if(aathov(1).eq.2.or.aathov(1).eq.3) ihov=2
      xlanes=float(aatln(2,idir,1))
      xauxlanes=float(aataux(idir,1))
      if(xlanes.gt.8) then
        xlanes=0.0
      else
        xlanes=xlanes+xauxlanes
      endif
      xmile=xdist*xlanes
      flmile(ihov,aatfc(1))=flmile(ihov,aatfc(1))+xmile
      fcmile(aatfc(1))=fcmile(aatfc(1))+xdist*aathc(2,idir)
c	    August 4, 2009, modified by ZOU,
c     use AM period lane and AM period time,to avoid reversible lane with
c     abtmo = 999
      frhour(aatfc(1))=frhour(aatfc(1))+
     *aatlt(2,idir)*xlanes/60.0
      aattc(idir)=extcst+aatcst+(aatlt(1,idir)+aatxt(1,idir))*35.0+
     *float(aattoll(1,1)+aattoll(2,1))/2.0
      if(ibord.gt.0) then
        do 6982 i=1,3
          aatlt(i,idir)=aatlt(i,idir)+aatxt(1,idir)
          ibord=0
 6982   continue
      end if
      if(aattc(idir).gt.999999.) aattc(idir)=999999.
      if(aatfc(1).eq.10) go to 699
      jlmile(inc,ijur)=jlmile(inc,ijur)+xmile
      jcmile(inc,ijur)=jcmile(inc,ijur)+xdist*aathc(2,idir)
c	    August 4, 2009, modified by ZOU,
c     use AM period lane and AM period time,to avoid reversible lane with
c     abtmo = 999
      jrhour(inc,ijur)=jrhour(inc,ijur)+aatlt(2,idir)*xlanes/60.0
  699 continue
      aatcc=aatfc(1)
      call whca
      idir=1
c      frmile(aatfc(1))=frmile(aatfc(1))+xdist
c      if(aatfc(1).ne.10)
c     *jrmile(inc,ijur)=jrmile(inc,ijur)+xdist
c      flmile(1,aatfc(1))=flmile(1,aatfc(1))+xdist
c      frhour(aatfc(1))=frhour(aatfc(1))+
c     *aatlt(1,idir)/60.0
c
c     check to see whether link aatfc(1),jur,and gpa has been selected
c     for printing.
c
      if(pfc(1).eq.9999) go to 864
      do 863 i=1,15
      if(pfc(i).eq.0) go to 878
      if(pfc(i).eq.aatfc(1)) go to 864
  863 continue
      go to 878
  864 if(pjur(1).eq.9999) go to 866
      do 865 i=1,4
      if(pjur(i).eq.0) go to 878
      if(pjur(i).eq.aatjur(1)) go to 866
  865 continue
      go to 878
  866 if(psph(1).eq.9999) go to 870
      do 867 i=1,20
      if(psph(i).eq.0) go to 878
      if(psph(i).eq.snode(aatarn(2))) go to 870
      if(psph(i).eq.snode(aatarn(1))) go to 870
      if(psph(i).eq.1400.and.isph.eq.14) go to 870
      if(psph(i).eq.1400.and.jsph.eq.14) go to 870
      if(psph(i).eq.1900.and.isph.eq.19) go to 870
      if(psph(i).eq.1900.and.jsph.eq.19) go to 870
  867 continue
      go to 878
c
c     print out from-to data
c
  870 ift=1
      if(first) go to 872

      if(iline.lt.60) go to 875
      iline=6
      write(lunpr,20000) eject,cdate,ipage,cheado
      eject = char(12)
      write(lunpr,20003)
      ipage=ipage+1
      go to 875
  872 if(iline.lt.52) go to 873
      write(lunpr,20000) eject,cdate,ipage,cheado
      eject = char(12)
      ipage=ipage+1
      iline=5
  873 write(lunpr,20001)
     *aatrt,aatnm,nway(aatway(1)),nrdir(aatdir),aatxnm(2)
      iline=iline+3
      first=.false.
  875 xop=aatlt(3,1)
      xpk=aatlt(1,1)
      write(lunpr,20002) aatrec,aatid,aatxnm(1),
     *nfc(aatfc(1)),nhov(aathov(1)),njur(aatjur(1)),ispd,
     *nmed(aatmed(1)),(nln(aatln(idir,1,1)+1),idir=1,3),
     *aataux(1,1),ncnt(aatcnt(1,1)+1),nxl(aattl(1,1)+1),
     *nxl(aatrl(1,1)+1),nxl(aatll(1,1)+1),
     *aatgc(1),xdist,xop,xpk,
     *(aathc(idir,1),idir=1,3)
      iline=iline+1
c
c     store tf data for printing at end of route
c
      krec=krec+1
      if(krec.lt.mxrlk) go to 877
      write(lunerr,19875) mxrlk,aatnm
      errf=.true.
      krec=mxrlk
  877 krno(krec)=aatrec
      kid(krec)=aatid
      kdist(krec)=idist
      kname(krec)=aatxnm(2)

      jur(krec)=aatjur(1)
      fc(krec)=aatfc(1)
      hov(krec)=aathov(1)
      spd(krec)=ispd
      med(krec)=aatmed(1)
      tfln(1,krec)=aatln(1,2,1)
      tfln(2,krec)=aatln(2,2,1)
      tfln(3,krec)=aatln(3,2,1)
      tfaux(krec)=aataux(2,1)
      tfcnt(krec)=aatcnt(2,1)
      tftl(krec)=aattl(2,1)
      tfrl(krec)=aatrl(2,1)
      tfll(krec)=aatll(2,1)
      tfgc(krec)=aatgc(2)
      tfotm(krec)=aatlt(3,2)
      tfptm(krec)=aatlt(1,2)
      tfcap(1,krec)=aatlc(1,2)
      tfcap(2,krec)=aatlc(2,2)
      tfcap(3,krec)=aatlc(3,2)
      name1=aatxnm(1)
  878 iaat=iaat+1
      if(iaat.gt.naat) go to 879
      lrtno=aatrt
      irtno=rlkarr(iaat)/1000
      ilkno=rlkarr(iaat)-irtno*1000
      aatrec=srec(iaat)
      if(irtno.ne.lrtno) go to 880
      go to 501

  879 endf=.true.
  880 first=.true.
      if(aatway(1).eq.1) go to 889
      if(krec.lt.1) go to 889
      if(iline.lt.52) go to 882
      write(lunpr,20000) eject,cdate,ipage,cheado
      ipage=ipage+1
      iline=6
  882 if(aatdir.eq.1) jdir=3
      if(aatdir.eq.2) jdir=4
      if(aatdir.eq.3) jdir=1
      if(aatdir.eq.4) jdir=2
      ift=2
      write(lunpr,20001) aatrt,aatnm,nway(aatway(1)),nrdir(jdir),name1
      iline=iline+3
      do 888 i=1,krec
      ii=krec-i+1
      if(iline.lt.60) go to 883
      iline=6
      write(lunpr,20000) eject,cdate,ipage
      write(lunpr,20003)
      ipage=ipage+1
  883 aatrec=krno(ii)
      aatid=kid(ii)
      xdist=float(kdist(ii))/100.0
      aatxnm(1)=kname(ii)
      aatjur(1)=jur(ii)
      aatfc(1)=fc(ii)
      aathov(1)=hov(ii)
      ispd=spd(ii)
      aatmed(1)=med(ii)
      aatln(1,1,1)=tfln(1,ii)
      aatln(2,1,1)=tfln(2,ii)
      aatln(3,1,1)=tfln(3,ii)
      aataux(1,1)=tfaux(ii)
      aatcnt(1,1)=tfcnt(ii)
      aattl(1,1)=tftl(ii)
      aatrl(1,1)=tfrl(ii)
      aatll(1,1)=tfll(ii)
      aatgc(1)=tfgc(ii)
      xop=float(tfotm(ii))
      xpk=float(tfptm(ii))
      aatlc(1,1)=tfcap(1,ii)
      aatlc(2,1)=tfcap(2,ii)
      aatlc(3,1)=tfcap(3,ii)
      write(lunpr,20002) aatrec,aatid,aatxnm(1),
     *nfc(aatfc(1)),nhov(aathov(1)),njur(aatjur(1)),ispd,
     *nmed(aatmed(1)),(nln(aatln(idir,1,1)+1),idir=1,3),
     *aataux(1,1),ncnt(aatcnt(1,1)+1),nxl(aattl(1,1)+1),
     *nxl(aatrl(1,1)+1),nxl(aatll(1,1)+1),
     *aatgc(1),xdist,xop,xpk,
     *(aathc(idir,1),idir=1,3)
      iline=iline+1
  888 continue
  889 if(endf) go to 890
      go to 500
  890 write(0,11011) naat
      close(lunin)

c     write out tdz zone connector generate records

      print *, mmzrt
      do itdz=1,mxtdz !loop through tdzs
       mzrt=tdzmrt(itdz)
        if(mzrt.lt.1) then !make sure at lest one connection was found for tdz
         write(lunerr,19891) itdz
         errf=.true.
        else

         do irt=1,mzrt !loop through route connections for this tdz
          in=tdzrtnode(itdz,irt)
          id=tdzrtid(itdz,irt)
           if(.not.nused(in)) then !check to see if tdz-node connection was already made for previous route
C	Added by Ziying Ouyang, Oct 29, 2009 for error checking
	      if (xtdz(itdz).gt.0.and.ytdz(itdz).gt.0) then
               write(lunxy,20401)
     *         id,xtdz(itdz),ytdz(itdz),xnode(in),ynode(in)
               nused(in)=.true.
	      else
               write(lunerr,19915) id,itdz !invalid x y coordinates
	     endif
	   endif
         end do !end of route connection loop

	 do in=1,mxhcn !reset node used to zero
          nused(in)=.false.
         end do
       end if !end of check fo tdz connections
      end do ! end of tdz loop
      write(lunxy,20409)
c
c     write out turn prohibitor records
c
c
c     open turnssec file
c
  900 endf=.false.
      call ohctus
      if(secio.ne.0) go to 9000
      secrec=1
      call rhctus
      if(secio.ne.0) go to 9000
      if(alink.lt.1.or.alink.gt.mxhca) go to 9910
      aatid=lbid(alink)
      ifc=lbfc(alink)
      go to 917
c
c     read section attribute table saving aatlbs used as prohibitors
c
  911 call rhctus
      if(secio.ne.0) go to 919
      if(alink.lt.1.or.alink.gt.mxhca) go to 9910
      aatid=lbid(alink)
      ifc=lbfc(alink)
      if(rlink.ne.lrlink) go to 915
      id2=aatid
      if(ifc.ne.lfc) go to 912
      go to 918
  912 write(luno,20925) lid,aatid
      used=.true.
      lfc=ifc
      lid=aatid
      go to 918
  915 if(used) go to 917
      if(id1.gt.0.and.id2.gt.0) go to 916
c      write(lunerr,19920) id1,id2
      go to 917
  916 write(luno,20925) id1,id2
  917 id1=aatid
      lrlink=rlink
      lfc=ifc
      lid=aatid
      id2=0
      used=.false.
  918 if(endf) go to 980
      secrec=secrec+1
      go to 911
  919 endf=.true.
      go to 915
  980 close(luno)
      write(lunsum,20980) ctime,cdate,cheado
      frmile(1)=frmile(1)/2.0
      jrmile(1,1)=jrmile(1,1)/2.0
      jrmile(2,1)=jrmile(2,1)/2.0
      do 981 ifc=1,9
      frmile(11)=frmile(11)+frmile(ifc)
      flmile(1,11)=flmile(1,11)+flmile(1,ifc)
      flmile(2,11)=flmile(2,11)+flmile(2,ifc)
      fcmile(11)=fcmile(11)+fcmile(ifc)
      frhour(11)=frhour(11)+frhour(ifc)
  981 continue
      ifc=10
      frmile(12)=frmile(11)+frmile(ifc)
      flmile(1,12)=flmile(1,11)+flmile(1,ifc)
      flmile(2,12)=flmile(2,11)+flmile(2,ifc)
      fcmile(12)=fcmile(11)+fcmile(ifc)
      frhour(12)=frhour(11)+frhour(ifc)
      do 983 ihov=1,2
      do 982 ifc=1,12
      flmile(3,ifc)=flmile(3,ifc)+flmile(ihov,ifc)
  982 continue
  983 continue
      do 984 ifc=1,9
      if(frhour(ifc).lt.0.01) go to 984
      frhour(ifc)=flmile(3,ifc)/frhour(ifc)
      write(lunsum,20981)
     *nfc(ifc),frmile(ifc),flmile(3,ifc),fcmile(ifc),frhour(ifc)
  984 continue
      ifc=11
      frhour(ifc)=flmile(3,ifc)/frhour(ifc)
      write(lunsum,20981)
     *nfc(ifc),frmile(ifc),flmile(3,ifc),fcmile(ifc),frhour(ifc)
      ifc=10
      frhour(ifc)=flmile(3,ifc)/frhour(ifc)
      write(lunsum,20981)
     *nfc(ifc),frmile(ifc),flmile(3,ifc),fcmile(ifc),frhour(ifc)
      ifc=12
      frhour(ifc)=flmile(3,ifc)/frhour(ifc)
      write(lunsum,20981)
     *nfc(ifc),frmile(ifc),flmile(3,ifc),fcmile(ifc),frhour(ifc)
      write(lunsum,20982) eject,ctime,cdate,cheado
       do inc=1,2
      do ijur=1,9
      jrmile(inc,10)=jrmile(inc,10)+jrmile(inc,ijur)
      jlmile(inc,10)=jlmile(inc,10)+jlmile(inc,ijur)
      jcmile(inc,10)=jcmile(inc,10)+jcmile(inc,ijur)
      jrhour(inc,10)=jrhour(inc,10)+jrhour(inc,ijur)
      end do
      end do
      do inc=1,2
      do ijur=1,10
      jrmile(3,ijur)=jrmile(3,ijur)+jrmile(inc,ijur)
      jlmile(3,ijur)=jlmile(3,ijur)+jlmile(inc,ijur)
      jcmile(3,ijur)=jcmile(3,ijur)+jcmile(inc,ijur)
      jrhour(3,ijur)=jrhour(3,ijur)+jrhour(inc,ijur)
      end do
      end do
      do inc=1,3
      do ijur=1,10
      if(jrhour(inc,ijur).gt.0.0) then
      jrhour(inc,ijur)=jlmile(inc,ijur)/jrhour(inc,ijur)
      write(lunsum,20983) nminc(inc),nmjur(ijur),jrmile(inc,ijur),
     *jlmile(inc,ijur),jcmile(inc,ijur),jrhour(inc,ijur)
      endif
      end do
      write(lunsum,20003)
      end do
      close(lunsum)
      open (unit=lunsum,file='summary.csv',access='append')
      ix=nint(flmile(3,1))
      write(lunsum,20901) ialt,cheadi,cdate,ctime,ix
      ix=nint(flmile(2,1))
      write(lunsum,20902) ialt,cheadi,cdate,ctime,ix
      close(lunsum)
      fnamo='complete'
      lunze=0
      do 992 i=1,mzone
      if(zoneo(i)) go to 992
      if(lunze.ne.0) go to 991
      write(lunerr,19991) i
      errf=.true.
      lunze=15
      open (unit=lunze,file='zone.err')
  991 write(lunze,10001) i
  992 continue
      if(lunze.ne.0) close(lunze)

c     if toll facilities or hov3+ facilities found then write out flag files

      fnami='hov3'
      call opendata(lunin)
      if(istat.eq.0) close(lunin,status='delete')
       if(hov3) then
        open(lunin,file='hov3')
        write(lunin,20003)
        close(lunin)
       endif

      fnami='hot3'
      call opendata(lunin)
      if(istat.eq.0) close(lunin,status='delete')
       if(hot3) then
        open(lunin,file='hot3')
        write(lunin,20003)
        close(lunin)
       endif

      fnami='toll'
      call opendata(lunin)
      if(istat.eq.0) close(lunin,status='delete')
       if(toll) then
        open(lunin,file='toll')
        write(lunin,20003)
        close(lunin)
       endif

      go to 9999

 9000 write(lunerr,19000) fnamo
      errf=.true.
      go to 9999
 9001 write(lunerr,19001) fnamo
      errf=.true.
      go to 9999
 9030 write(lunerr,19030) aatadt
      errf=.true.
      go to 30
 9070 write(lunerr,19070) fnamo,ista
      errf=.true.
      go to 9999
 9130 write(lunerr,19130)
      errf=.true.
      go to 9999
 9140 write(lunerr,19140)
      errf=.true.
      go to 9999
 9502 write(lunerr,19502)
      errf=.true.
      go to 9999
 9910 write(lunerr,19910) alink,rlink
      errf=.true.
      go to 917
10000 format(80i1,t1,80a1)
10001 format(20i4)
10002 format(i2,80a1)
10003 format(80a1)
10009 format(a1)
10030 format(5x,9(3x,i2))
10033 format(i7,29(f7.0,2x))
10040 format(11x,6f6.1)
10060 format(i8,a2)
10070 format(2i5,24f5.2)
11002 format(' ** reading and storing hwycov data ** ')
11004 format(' ** ',i6,' records read - - initial reading of aat',
     *' complete **')
11005 format(' ** finding cross street names **')
11006 format(' ** sorting records end-to-end by name **')
11008 format(' ** reading and writing node attribute table **')
11010 format(' ** reading and writing arc attribute table **')
11011 format(' ** ',i5,' records written - - successful program',
     *' completion **')
19030 format(' data problem with histfill file:',i10)
20000 format(a1,1x,a8,t57,'highway coverage arc data',
     *t130,'page',i4,/,t30,80a1,//,
     *'   rec   arc                      functional                  ',
     *'--lanes--         lanes           ---minutes---',
     *' ------hourly-----'/,
     *'    no    id cross street name    class       hov jur spd med ',
     *' main aux control t r l gc    miles offpeak  peak',
     *'      capacity')
20001 format(/,t36,'route number: ',i4,' name: ',a20,1x,a7,1x,a12,/,
     *13x,a20)
20002 format(2i6,1x,a20,1x,a11,1x,a4,1x,a3,i4,1x,a3,1x,2(a1,'/'),a1,
     *i4,2x,a6,3(1x,a1),i3,1x,f6.2,f8.2,f6.2,1x,2(f6.0,'/'),f6.0)
20003 format(' ')
20401 format(i10,/,f8.0,',',f8.0,/,f8.0,',',f8.0,/,'END')
20409 format('END')
20901 format(i2,','80a1,',47,total freeway lane miles,"',
     *a7,'","',a8,'",',i10,',')
20902 format(i2,','80a1,',48,hov freeway lane miles,"',
     *a7,'","',a8,'",',i10,',')
20920 format('from_id,to_id,penalty')
20925 format(i5,',',i5)
20980 format(1x,a8,t29,'highway network summary',t72,a8,/,80a1,//,
     *' functional',/,
     *' classification    route miles    lane miles',
     *'     capacity miles    average speed',/)
20981 format(1x,a11,t20,f12.0,f14.0,f19.0,f16.1)
20982 format(a1,a8,t37,'highway network summary',t78,a8,/,80a1,//,
     *'location            jurisdiction            route miles',
     *'    lane miles     capacity miles    average speed',/)
20983 format(a19,1x,a17,f19.0,f14.0,f19.0,f16.1)
30001 format(i5,i5,i1,i4,'t',2i4,4i2,i6,i1,i5,'1')
30002 format(i5,i5,i1,i4,'t',i4,4x,4i2,i6,i1,i5,'2')
19000 format(a50,' not opened')
19001 format(' data problem with file: ',a80/,80a1)
19070 format(' data problem with file: ',a80/,i10)
19100 format(' invalid node in arc attribute table: ',/,
     *' record=',i5,'node = ',i5,' name=',a20,'xname = ',a20)
19101 format(' invalid node in arc attribute table: ',/,
     *' record=',i5,'from node = ',i5,'to node =',i5,
     *'name=',a20,'frname = ',a20,'toname = ',a20)
19104 format(' increase size of mxnrt')
19128 format(' increase size of mxhca')
19130 format(' hwycov.trn not found in arc.dir file')
19140 format(' node number mis-match')
19399 format(' record not sorted',i6)
19411 format('naterr#1 - invalid node in node attribute table: ',/,
     *'hwycov# = ',i5,
     *'1st cross street=',a20,'2nd cross street = ',a20)
19412 format('naterr#2 -  invalid tranplan node attribute table: ',/,
     *'hwycov# = ',i5,'hnode = ',i5,
     *'1st cross street=',a20,'2nd cross street = ',a20)
19413 format('naterr#3 -  tranplan node at more than one location: ',/,
     *'hwycov# = ',i5,'hnode = ',i5,
     *'  1st cross street=',a20,'2nd cross street = ',a20)
19414 format('naterr#4 -  more than four cross streets: ',/,
     *'hwycov# = ',i5,
     *'1st cross street=',a20,'2nd cross street = ',a20)
19415 format('naterr#5 -  two-way stop with 3+ unsigned streets: ',/,
     *'hwycov# = ',i5,
     *'1st cross street=',a20,'2nd cross street = ',a20)
19502 format(' no unused id's)
19505 format('aaterr#1 - entry/exit problem: ',/,
     *'id = ',i5,' name=',a20,' from = ',a20,
     *' to = ',a20,' nodes = ',2i6)
19510 format('aaterr#2 - invalid functional class: ',/,
     *'id = ',i5,' name=',a20,' from = ',a20,' to = ',a20,' fc = ',i10)
19526 format('aaterr#5 - duplicate arc: ',/,

     *'id = ',i5,' name=',a20,' from = ',a20,
     *' to = ',a20,' nodes = ',2i6)
19580 format('aaterr#6 - zone connector with both ends at zone: ',/,
     *'id = ',i5,' nodes=',2i5,' zone = ',i4)
19581 format('aaterr#7 - zone connector with neither at zone: ',/,
     *'id = ',i5,' nodes=',2i5,' zone = ',i4)
19582 format(' increase size of mxzrt')
19589 format('aaterr#8 - zone connector with neither end at street: ',/,
     *'id = ',i5,' nodes=',2i5,' zone = ',i4)
19698 format('problem with station hour %s: station=',i4,' ppf=',f5.1)
19875 format(' more than',i6,' links in route:',a21)
19891 format(' missing zone connectors for tdz',i6)
19902 format(' mis-matching nodes on hov ramp links :',3i10)
19907 format(' no tranplan node at hov nodes:',5i10)
19909 format(' hov ramp link not used:',i10)
19910 format(' data problem with hwycov2.turnssec file:',2i10)
19915 format(' hwycovtdz zone connector
     * invalid x, y coordinate for link id ',i8,'for tdz ',i8)
19920 format(' more than 3 arcs on turn route :',4i10)
19912 format(' more than 3 arcs on turn route :',i10)
19922 format(' no matching nodes on turn route :',5i10)
19991 format(' missing zone connector(s)',i5)
20130 format('info/arc',4a1,'.dat')
39999 format('[',a7,'] [',a8,'] [s9.10/tchc] [',a<ic1>,
     *'] [route miles=',i<ic2>,
     *'] [lane miles=',i<ic3>,
     *'] [averge mph=',f<ic4>.1,']')
 9999 if(errf)  go to 99991
      tpstat='ok'
      ic1=2
      close(lunerr,status='delete')
      go to 99992
99991 close(lunerr,status='keep')
      tpstat='not'
      ic1=3
99992 if(inff)  go to 99993
      close(luninf,status='delete')
      go to 99994
99993 close(luninf,status='keep')
99994 open (unit=lunerr,file='tplog',access='append')
      i1=nint(frmile(16))
      ic2=1
      if(i1.gt.9) ic2=2
      if(i1.gt.99) ic2=3
      if(i1.gt.999) ic2=4
      if(i1.gt.9999) ic2=5
      if(i1.gt.99999) ic2=6
      i2=nint(flmile(3,16))
      ic3=1
      if(i2.gt.9) ic3=2
      if(i2.gt.99) ic3=3
      if(i2.gt.999) ic3=4
      if(i2.gt.9999) ic3=5
      if(i2.gt.99999) ic3=6
      ic4=3
      if(frhour(16).gt.9.9) ic4=4
      if(frhour(16).gt.99.9) ic4=5
      call dattim
      write(lunerr,39999)  cdate,ctime,tpstat,i1,i2,frhour(16)
      close(lunerr)
      close(lunsta)
      close(lunin)
      close(lunpr)
      stop
      end
      subroutine recsrt
      include 'sandag.inc'
      common /reccom/ srec,rlkarr
      integer*4 srec(mxhca),rlkarr(mxhca),tt,t
      dimension iu(21),il(21)
      jj=mxhca
      ii=1
      m=1
      i=ii
      j=jj
5     if(i.ge.j) go to 70
10    k=i
      ij=(j+i)/2
      t=rlkarr(ij)
      if(rlkarr(i).le.t) go to 20
      nt=srec(ij)
      rlkarr(ij)=rlkarr(i)
      srec(ij)=srec(i)
      rlkarr(i)=t
      srec(i)=nt
      t=rlkarr(ij)
20    l=j
      if(rlkarr(j).ge.t)go to 40
      nt=srec(ij)
      rlkarr(ij)=rlkarr(j)
      srec(ij)=srec(j)

      rlkarr(j)=t
      srec(j)=nt
      t=rlkarr(ij)
      if(rlkarr(i).le.t) go to 40
      nt=srec(ij)
      rlkarr(ij)=rlkarr(i)
      srec(ij)=srec(i)
      rlkarr(i)=t
      srec(i)=nt
      t=rlkarr(ij)
      go to 40
30    ntt=srec(l)
      rlkarr(l)=rlkarr(k)
      srec(l)=srec(k)
      rlkarr(k)=tt
      srec(k)=ntt
40    l=l-1
      if(rlkarr(l).gt.t) go to 40
      tt=rlkarr(l)
50    k=k+1
      if(rlkarr(k).lt.t) go to 50
      if(k.le.l) go to 30
      if(l-i.le.j-k) go to 60
      il(m)=i
      iu(m)=l
      i=k
      m=m+1
      go to 80
60    il(m)=k
      iu(m)=j
      j=l
      m=m+1
      go to 80
70    m=m-1
      if(m.lt.1) return
      i=il(m)
      j=iu(m)
80    if(j-i.ge.11) go to 10
      if(i.eq.ii) go to 5
      i=i-1
90    i=i+1
      if(i.eq.j) go to 70
      t=rlkarr(i+1)
      if(rlkarr(i).le.t) go to 90
      nt=srec(i+1)
      k=i
100   rlkarr(k+1)=rlkarr(k)
      srec(k+1)=srec(k)
      k=k-1
      if(t.lt.rlkarr(k)) go to 100
      rlkarr(k+1)=t
      srec(k+1)=nt
      go to 90
      end


!##############################################################################
! PROGRAM VarDec
!
! ## Shows how to declare variables
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program VarDec

    ! declaration of variables
    implicit none
    logical :: logic
    integer :: a, b
    real*8 :: x, y1
    character :: one_char
    character(len=20) :: long_char

    real*8, parameter :: pi = 3.14d0
    integer, parameter :: n = 56

end program


* Date: Mon, 4 May 1998 13:22:30 +0200 (MET DST)
* From: Bengt Edvardsson <be@astro.uu.se>
* To: Plez@Ferrum.fysik.lu.se
************************************************************************
*
      subroutine makeabund(overall,alpha,helium,rabund,sabund,fixabund,
     &                  abund,amass,aname,isotopfrac)
*
* Create a formatted abundance file
* The programme scales groups of elements automatically
* The input solar abundances are Grevesse et al. logarithmic
*     number abundances on a scale where N(Hydrogen) == 12.00
* The output abundances are on the same scale (there has to be some H)
* A null abundance is signalled as -29.0
* STD?=1 indicates than no abundances have been fiddeled and
* that the first line describes the whole list
* STD?=0 mean that some abundance(s) has been modified by hand
*
* small changes by BPz 04/05-1998 for inclusion in MARCS35
* more changes (isotopfrac inclusion), for SPECTRUM version (BPz 010798)
*
      implicit none
*
      integer natom,nelalpha,i,j
      parameter (natom = 92)
      parameter (nelalpha = 8)
      real amass(natom,0:250),abund(natom),sunabund(natom),
     &     rfract(31:92),tempmass,
     &     fixabund(natom),damass(natom),isotopfrac(natom,0:250),
     &     sunabund_1998(natom),sunabund_2007(natom),checkiso
      real overall,alpha,helium,rabund,sabund,abundr,abunds,hfactor
      integer iel,ialpha,ielalpha(nelalpha)
      character*2 aname(natom),daname(natom)
      logical abund_2007
*
* isotopfrac(22,48) is isotopic fraction of 48Ti
* sum_over_i>0{ isotopfrac(x,i) } = 1.000
* isotopfrac(x,0)==1.0; this is used in the case of no isotopes wanted
* in calculation. It will ensure that the total abundance of the species
* will be used.(if for example isotopic factors were included in gf-values)
*

*
CCCC before 24/03-2004*                     C  O  Ne  Mg  Si   S  Ar  Ca  Ti
CCCC before 24/03-2004      data ielalpha / 6, 8, 10, 12, 14, 16, 18, 20, 22 /
*                      O  Ne  Mg  Si   S  Ar  Ca  Ti
      data ielalpha /  8, 10, 12, 14, 16, 18, 20, 22 /

*
      data daname /                                                      | atomic nr
     &           'H ','He','Li','Be','B ','C ','N ','O ','F ',          |  1 -  9
     &           'Ne','Na','Mg','Al','Si','P ','S ','Cl','Ar',          | 10 - 18
     &           'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co',          | 19 - 27
     &           'Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',          | 28 - 36
     &           'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh',          | 37 - 45
     &           'Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe',          | 46 - 54
     &           'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu',          | 55 - 63
     &           'Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf',          | 64 - 72
     &           'Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl',          | 73 - 81
     &           'Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',          | 82 - 90
     &           'Pa','U '/                                             | 91 - 92
*
      data damass /                                                      | atomic mass
     &   1.008, 4.003, 6.940, 9.010, 10.81, 12.01, 14.01, 16.00, 19.00, |  1 -  9
     &   20.18, 22.99, 24.31, 26.98, 28.08, 30.97, 32.06, 35.45, 39.95, | 10 - 18
     &   39.10, 40.08, 44.96, 47.90, 50.94, 52.00, 54.94, 55.85, 58.93, | 19 - 27
     &   58.70, 63.54, 65.37, 69.72, 72.59, 74.92, 78.96, 79.90, 83.80, | 28 - 36
     &   85.47, 87.62, 88.91, 91.22, 92.91, 95.94, 98.91, 101.0, 102.9, | 37 - 45
     &   106.4, 107.9, 112.4, 114.8, 118.7, 121.8, 127.6, 126.9, 131.3, | 46 - 54
     &   132.9, 137.3, 138.9, 140.1, 140.9, 144.2, 146.0, 150.4, 152.0, | 55 - 63
     &   157.3, 158.9, 162.5, 164.9, 167.3, 168.9, 170.0, 175.0, 178.5, | 64 - 72
     &   180.9, 183.9, 186.0, 190.0, 192.2, 195.1, 197.0, 200.6, 204.4, | 73 - 81
     &   207.2, 209.0, 210.0, 210.0, 222.0, 223.0, 226.0, 227.0, 232.0, | 82 - 90
     &   230.4, 238.0 /                                                 | 91 - 92
*
* Solar abundances ref: Grevesse Sauval 1998, Space Science Rev, in press
      data sunabund_1998 /
CCCC before 19/01-2004 changed to agree with Asplund 2003, and Uppsala MARCS version and GRID
CCCC     & 12.00, 10.93,  1.10,  1.40,  2.55,  8.52,  7.92,  8.83,  4.56,   |  1 -  9
CCCC     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.50,  6.40,   | 10 - 18
CCCC
CCCC
CCCC
CCCC     &  1.69,  0.94,  1.77,  1.66,  2.00,  1.00,  2.24,  1.51,  2.17,   | 46 - 54
CCCC
CCCC     &  1.12, -0.10,  1.14,  0.26,  0.93,  0.00,  1.08,  0.06,  0.88,   | 64 - 72
CCCC     & -0.13,  1.11,  0.28,  1.45,  1.35,  1.80,  1.01,  1.13,  0.90,   | 73 - 81
CCCC
CCCC     & -99.0, -0.47 /                                                   | 91 - 92
     & 12.00, 10.93,  1.10,  1.40,  2.79,  8.41,  7.80,  8.66,  4.48,   |  1 -  9
     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.28,  6.40,   | 10 - 18
     &  5.12,  6.36,  3.17,  5.02,  4.00,  5.67,  5.39,  7.50,  4.92,   | 19 - 27
     &  6.25,  4.21,  4.60,  2.88,  3.41,  2.37,  3.41,  2.63,  3.31,   | 28 - 36
     &  2.60,  2.97,  2.24,  2.60,  1.42,  1.92, -99.0,  1.84,  1.12,   | 37 - 45
     &  1.69,  1.24,  1.77,  0.82,  2.00,  1.00,  2.24,  1.51,  2.17,   | 46 - 54
     &  1.13,  2.13,  1.17,  1.58,  0.71,  1.50, -99.0,  1.01,  0.51,   | 55 - 63
     &  1.12,  0.35,  1.14,  0.51,  0.93,  0.15,  1.08,  0.06,  0.88,   | 64 - 72
     & -0.13,  0.69,  0.28,  1.45,  1.35,  1.80,  0.85,  1.13,  0.83,   | 73 - 81
     &  1.95,  0.71, -99.0, -99.0, -99.0, -99.0, -99.0, -99.0,  0.09,   | 82 - 90
     & -99.0, -0.50 /                                                   | 91 - 92
*
      data sunabund_2007 /
     & 12.00, 10.93,  1.05,  1.38,  2.70,  8.39,  7.78,  8.66,  4.56,   |  1 -  9
     &  7.84,  6.17,  7.53,  6.37,  7.51,  5.36,  7.14,  5.50,  6.18,   | 10 - 18
     &  5.08,  6.31,  3.17,  4.90,  4.00,  5.64,  5.39,  7.45,  4.92,   | 19 - 27
     &  6.23,  4.21,  4.60,  2.88,  3.58,  2.29,  3.33,  2.56,  3.25,   | 28 - 36
     &  2.60,  2.92,  2.21,  2.58,  1.42,  1.92, -99.0,  1.84,  1.12,   | 37 - 45
     &  1.66,  0.94,  1.77,  1.60,  2.00,  1.00,  2.19,  1.51,  2.24,   | 46 - 54
     &  1.07,  2.17,  1.13,  1.70,  0.58,  1.45, -99.0,  1.00,  0.52,   | 55 - 63
     &  1.11,  0.28,  1.14,  0.51,  0.93,  0.00,  1.08,  0.06,  0.88,   | 64 - 72
     & -0.17,  1.11,  0.23,  1.25,  1.38,  1.64,  1.01,  1.13,  0.90,   | 73 - 81
     &  2.00,  0.65, -99.0, -99.0, -99.0, -99.0, -99.0, -99.0,  0.06,   | 82 - 90
     & -99.0, -0.52 /                                                   | 91 - 92
*
*
* Fractional r-process abundance for Ga-Bi (r+s simply assumed == 100%) | Date 2000-01-18
* (Note: Ga-Sr (31-38) was just copied from Kaeppeler et al. 1989, below)
* s-process from Stellar models: Arlandini C., Kaeppeler F., Wisshak K.,
* Gallino R., Busso M., Straniero O., 1999, Astrophys J. 525, 886-900
*   Fractions corrected to the revised meteoritic abundances
*   of Grevesse N., Sauval A.J. 1998, Space Science Review 85, 161-174
      data rfract /
*    & H  - F                                                           |  1 -  9
*    & Ne - Ar                                                          | 10 - 18
*    & K  - Co                                                          | 19 - 27
     &                       .43, .47, .81, .85, .39, .47,              | 28 - 36
     &        .41, .11, .08, .17, .15, .50,-.99, .68, .86,              | 37 - 45
     &        .54, .80, .48, .65, .35, .75, .83, .80, .80,              | 46 - 54
     &        .85, .19, .38, .23, .51, .44,-.99, .71, .93,              | 55 - 63
     &        .85, .93, .85, .92, .83, .87, .67, .80, .44,              | 64 - 72
     &        .59, .44, .91, .91, .99, .95, .94, .41, .24,              | 73 - 81
     &        .54, .95,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82 - 90
     &       -.99, 1.0 /                                                | 91 - 92

c* fractional r-process abundance for Cu-U (r+s simply assumed == 100%)
c* r-process from Kaeppeler F., Beer H., Wisshak K. 1989, Reports on
c*   Progress in Physics 52, 945. Fraction found by division by the
c*   total meteoritic abundances given by Anders Grevesse 1989, Geochim.
c*   Cosmochim. Acta 53, 197. Th+U guess 1.0
c* (Perhaps some more data in Beer et al 1997, ApJ 474,843)
c* (Sneden et al 1998 ApJ 496,235: Sm 76%, Eu 97%)
c      data rfract /
c*    & H  - F                                                           |  1 -  9
c*    & Ne - Ar                                                          | 10 - 18
c*    & K  - Co                                                          | 19 - 27
c     &             .21, .35, .43, .47, .81, .85, .39, .47,              | 28 - 36
c     &        .41, .11, .28, .18, .16, .25,-.99, .50, .83,              | 37 - 45
c     &        .56, .88, .57, .64, .36, .99, .82, .93, .84,              | 46 - 54
c     &        .85, .12, .25, .23, .56, .51,-.99, .68, .93,              | 55 - 63
c     &        .81, .91, .90, .92, .84, .84, .65, .83, .53,              | 64 - 72
c     &        .35, .46, .90, .96, .98, .96, .92, .42, .28,              | 73 - 81
c     &        .20, .64,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82 - 90
c     &       -.99, 1.0 /                                                | 91 - 92
*
*
*
cc* Solar abundances ref: Grevesse Noels Sauval 1996 ASP Conf 99, 117:
cc      data sunabund /
cc     & 12.00, 10.93,  1.16,  1.15,  2.60,  8.55,  7.97,  8.87,  4.56,   |  1 -  9
cc     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.50,  6.52,   | 10 - 18
cc     &  5.12,  6.36,  3.17,  5.02,  4.00,  5.67,  5.39,  7.50,  4.92,   | 19 - 27
cc     &  6.25,  4.21,  4.60,  2.88,  3.41,  2.37,  3.38,  2.63,  3.23,   | 28 - 36
cc     &  2.60,  2.97,  2.24,  2.60,  1.42,  1.92, -29.0,  1.84,  1.12,   | 37 - 45
cc     &  1.69,  0.94,  1.77,  1.66,  2.00,  1.00,  2.24,  1.51,  2.23,   | 46 - 54
cc     &  1.13,  2.13,  1.17,  1.58,  0.71,  1.50, -29.0,  1.01,  0.51,   | 55 - 63
cc     &  1.12, -0.10,  1.14,  0.26,  0.93,  0.00,  1.08,  0.76,  0.88,   | 64 - 72
cc     & -0.13,  1.11,  0.28,  1.45,  1.35,  1.80,  1.01,  1.17,  0.90,   | 73 - 81
cc     &  1.95,  0.71, -29.0, -29.0, -29.0, -29.0, -29.0, -29.0,  0.09,   | 82 - 90
cc     & -29.0, -0.47 /                                                   | 91 - 92
cc*
cc* fractional r-process abundance for Cu-U (r+s assumed == 100%)
cc* r-process from Kaeppeler F., Beer H., Wisshak K. 1989, Reports on
cc*   Progress in Physics 52, 945. Fraction found by division by the
cc*   total meteoritic abundances given by Anders Grevesse 1989, Geochim.
cc*   Cosmochim. Acta 53, 197 (Xe=1.34 Dy=1.08 Lu=1.69 !) Th+U guess 1.0
cc*   Isotopic fractions from nuclide chart U.S. Dept of Energy 1988
cc*   Ba r-process=1.46 from McWilliam et al. 1998, AJ 115, 1640
cc* (Perhaps some more data in Beer et al 1997, ApJ 474,843)
cc      data rfract /
cc*    & H  - F                                                           |  1- 9
cc*    & Ne - Ar                                                          | 10-18
cc*    & K  - Co                                                          | 19-27
cc     &             .21, .25, .43, .50, .81, .78, .39, .59,              | 28-36
cc     &        .41, .11, .28, .18, .16, .34,-.99, .55, .83,              | 37-45
cc     &        .73, .88, .54, .64, .37, .50, .75, .93, .50,              | 46-54
cc     &        .85, .21, .25, .11, .56, .61,-.99, .85, .93,              | 55-63
cc     &        .82, .91, .50, .92, .84, .84, .59, .50, .53,              | 64-72
cc     &        .35, .46, .90, .96, .98, .90, .92, .67, .28,              | 73-81
cc     &        .20, .64,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82-90
cc     &       -.99, 1.0 /                                                | 91-92
*
cc      print *,'Overall metallicity? (-1.0 = Solar/10)'
cc      read(*,*) overall
cc      print *,'Helium abundance? (0.0 = Solar)'
cc      read(*,*) helium
cc      print *,'Alpha element scaling [alpha/Fe]? (+0.3 = Solar*2)'
cc      read(*,*) alpha
cc      print *,'r-element abundance [r/Fe]? (0.0 = Solar)'
cc      read(*,*) rabund
cc      print *,'s-element abundance [s/Fe]? (0.0 = Solar)'
cc      read(*,*) sabund
*
* chose set of abundances
      abund_2007=.true.
      if (abund_2007) then
        do iel=1,natom
          sunabund(iel)=sunabund_2007(iel)
        enddo
      else
        do iel=1,natom
          sunabund(iel)=sunabund_1998(iel)
        enddo
      endif
*
      do iel=1,92
        aname(iel)=daname(iel)
* mass of the default isotopic mix
* This is superseded by the getisotopmass.f routine below.
* BPz 18/06-2012
        amass(iel,0)=damass(iel)
      enddo
      abund(1)=sunabund(1)
      abund(2)=sunabund(2)
* overall metallicity
      do iel=3,natom
        if(sunabund(iel).gt.-29.0) then
          abund(iel)=sunabund(iel)+overall
        else
          abund(iel)=-29.0
        endif
      enddo
*
      if(alpha.ne.0.0) then
* alpha element abundance [alpha/Fe]
        do ialpha=1,nelalpha
          abund(ielalpha(ialpha))=abund(ielalpha(ialpha))+alpha
        enddo
      endif
*
* helium deficient?
      if(helium.ne.0.0) then
        abund(2)=abund(2)+helium
      endif
*
* r-element or s-element anomaly?
      if(rabund.ne.0.0 .or. sabund.ne.0.0) then
      print*,aname(33),sunabund(33),abund(33),rfract(33)
        do iel=31,92
cc        do iel=29,92
          if(sunabund(iel).gt.-29.0) then
            abundr=10.**rabund*rfract(iel)*10.**abund(iel)
            abunds=10.**sabund*(1.-rfract(iel))*10.**abund(iel)
      if(iel.eq.33) print*,rabund,sabund,abundr,abunds,abund(iel),iel
            abund(iel)=alog10(abundr+abunds)
          endif
        enddo
      endif
*
* If applicable, overrides any prescription by specific input value
      do iel=1,92
cc        abund(iel)=max(abund(iel),fixabund(iel))
        if (fixabund(iel).gt.-98.) then
          abund(iel)=fixabund(iel)
        endif
      enddo
*
* normalize to H=12.00
      hfactor=12.00-abund(1)
      if(hfactor.ne.0.0) then
        do iel=1,natom
          abund(iel)=abund(iel)+hfactor
        enddo
      endif
*
* isotopic ratios
      do i=1,250
        do j=1,92
          isotopfrac(j,i)=0.0
        enddo
      enddo
      do j=1,92
        isotopfrac(j,0)=1.0
      enddo
*
      isotopfrac(1,1)=0.999966
      isotopfrac(1,2)=0.000034
      isotopfrac(2,3)=0.000142
      isotopfrac(2,4)=0.999858
      isotopfrac(3,6)=0.075
      isotopfrac(3,7)=0.925
      isotopfrac(4,9)=1.0
      isotopfrac(5,10)=0.199
      isotopfrac(5,11)=0.801
      isotopfrac(6,12)=0.9890
      isotopfrac(6,13)=0.0110
      isotopfrac(7,14)=0.99634
      isotopfrac(7,15)=0.00366
      isotopfrac(8,16)=0.99762
      isotopfrac(8,17)=0.00038
      isotopfrac(8,18)=0.00200
      isotopfrac(9,19)=1.00
      isotopfrac(10,20)=0.9299
      isotopfrac(10,21)=0.00226
      isotopfrac(10,22)=0.0679
      isotopfrac(11,23)=1.00
      isotopfrac(12,24)=0.7899
      isotopfrac(12,25)=0.1000
      isotopfrac(12,26)=0.1101
      isotopfrac(13,27)=1.00
      isotopfrac(14,28)=0.9223
      isotopfrac(14,29)=0.0467
      isotopfrac(14,30)=0.0310
      isotopfrac(15,31)=1.00
      isotopfrac(16,32)=0.9502
      isotopfrac(16,33)=0.0075
      isotopfrac(16,34)=0.0421
      isotopfrac(16,36)=0.0002
      isotopfrac(17,35)=0.7577
      isotopfrac(17,37)=0.2423
      isotopfrac(18,36)=0.842
      isotopfrac(18,38)=0.158
      isotopfrac(19,39)=0.932581
      isotopfrac(19,40)=0.0001167
      isotopfrac(19,41)=0.067302
      isotopfrac(20,40)=0.96941
      isotopfrac(20,42)=0.00647
      isotopfrac(20,43)=0.00135
      isotopfrac(20,44)=0.02086
      isotopfrac(20,46)=0.00004
      isotopfrac(20,48)=0.00187
      isotopfrac(21,45)=1.00
      isotopfrac(22,46)=0.080
      isotopfrac(22,47)=0.073
      isotopfrac(22,48)=0.738
      isotopfrac(22,49)=0.055
      isotopfrac(22,50)=0.054
      isotopfrac(23,50)=0.00250
      isotopfrac(23,51)=0.99750
      isotopfrac(24,50)=0.04345
      isotopfrac(24,52)=0.83789
      isotopfrac(24,53)=0.09501
      isotopfrac(24,54)=0.02365
      isotopfrac(25,55)=1.00
      isotopfrac(26,54)=0.058
      isotopfrac(26,56)=0.9172
      isotopfrac(26,57)=0.022
      isotopfrac(26,58)=0.0028
      isotopfrac(27,59)=1.00
      isotopfrac(28,58)=0.6827
      isotopfrac(28,60)=0.2610
      isotopfrac(28,61)=0.0113
      isotopfrac(28,62)=0.0359
      isotopfrac(28,64)=0.0091
      isotopfrac(29,63)=0.6917
      isotopfrac(29,65)=0.3083
      isotopfrac(30,64)=0.4863
      isotopfrac(30,66)=0.2790
      isotopfrac(30,67)=0.0410
      isotopfrac(30,68)=0.1875
      isotopfrac(30,70)=0.0062
      isotopfrac(31,69)=0.60108
      isotopfrac(31,71)=0.39892
      isotopfrac(32,70)=0.205
      isotopfrac(32,72)=0.274
      isotopfrac(32,73)=0.078
      isotopfrac(32,74)=0.365
      isotopfrac(32,76)=0.078
      isotopfrac(33,75)=1.00
      isotopfrac(34,74)=0.0088
      isotopfrac(34,76)=0.090
      isotopfrac(34,77)=0.076
      isotopfrac(34,78)=0.236
      isotopfrac(34,80)=0.497
      isotopfrac(34,82)=0.092
      isotopfrac(35,79)=0.5069
      isotopfrac(35,81)=0.4931
      isotopfrac(36,78)=0.00339
      isotopfrac(36,80)=0.0222
      isotopfrac(36,82)=0.1145
      isotopfrac(36,83)=0.1147
      isotopfrac(36,84)=0.5711
      isotopfrac(36,86)=0.1742
      isotopfrac(37,85)=0.72165
      isotopfrac(37,87)=0.27835
      isotopfrac(38,84)=0.0056
      isotopfrac(38,86)=0.0986
      isotopfrac(38,87)=0.0700
      isotopfrac(38,88)=0.8258
      isotopfrac(39,89)=1.00
      isotopfrac(40,90)=0.5145
      isotopfrac(40,91)=0.1122
      isotopfrac(40,92)=0.1715
      isotopfrac(40,94)=0.1738
      isotopfrac(40,96)=0.0280
      isotopfrac(41,93)=1.00
      isotopfrac(42,92)=0.1484
      isotopfrac(42,94)=0.0925
      isotopfrac(42,95)=0.1592
      isotopfrac(42,96)=0.1668
      isotopfrac(42,97)=0.0955
      isotopfrac(42,98)=0.2413
      isotopfrac(42,100)=0.0963
      isotopfrac(44,96)=0.0552
      isotopfrac(44,98)=0.0188
      isotopfrac(44,99)=0.127
      isotopfrac(44,100)=0.126
      isotopfrac(44,101)=0.170
      isotopfrac(44,102)=0.316
      isotopfrac(44,104)=0.187
      isotopfrac(45,103)=1.00
      isotopfrac(46,102)=0.01020
      isotopfrac(46,104)=0.1114
      isotopfrac(46,105)=0.2233
      isotopfrac(46,106)=0.2733
      isotopfrac(46,108)=0.2646
      isotopfrac(46,110)=0.1172
      isotopfrac(47,107)=0.51839
      isotopfrac(47,109)=0.48161
      isotopfrac(48,106)=0.0125
      isotopfrac(48,108)=0.0089
      isotopfrac(48,110)=0.1249
      isotopfrac(48,111)=0.1280
      isotopfrac(48,112)=0.2413
      isotopfrac(48,113)=0.1222
      isotopfrac(48,114)=0.2873
      isotopfrac(48,116)=0.0749
      isotopfrac(49,113)=0.043
      isotopfrac(49,115)=0.957
      isotopfrac(50,112)=0.00973
      isotopfrac(50,114)=0.00659
      isotopfrac(50,115)=0.00339
      isotopfrac(50,116)=0.14538
      isotopfrac(50,117)=0.07672
      isotopfrac(50,118)=0.24217
      isotopfrac(50,119)=0.08587
      isotopfrac(50,120)=0.32596
      isotopfrac(50,122)=0.04632
      isotopfrac(50,124)=0.05787
      isotopfrac(51,121)=0.57362
      isotopfrac(51,123)=0.42638
      isotopfrac(52,120)=0.0009
      isotopfrac(52,122)=0.0257
      isotopfrac(52,123)=0.0089
      isotopfrac(52,124)=0.0476
      isotopfrac(52,125)=0.0710
      isotopfrac(52,126)=0.1889
      isotopfrac(52,128)=0.3173
      isotopfrac(52,130)=0.3397
      isotopfrac(53,127)=1.00
      isotopfrac(54,124)=0.00121
      isotopfrac(54,126)=0.00108
      isotopfrac(54,128)=0.0219
      isotopfrac(54,129)=0.2734
      isotopfrac(54,130)=0.0435
      isotopfrac(54,131)=0.2169
      isotopfrac(54,132)=0.2650
      isotopfrac(54,134)=0.0976
      isotopfrac(54,136)=0.0794
      isotopfrac(55,133)=1.00
      isotopfrac(56,130)=0.00106
      isotopfrac(56,132)=0.00101
      isotopfrac(56,134)=0.02417
      isotopfrac(56,135)=0.06592
      isotopfrac(56,136)=0.07854
      isotopfrac(56,137)=0.1123
      isotopfrac(56,138)=0.7170
      isotopfrac(57,138)=0.00089
      isotopfrac(57,139)=0.99911
      isotopfrac(58,136)=0.0019
      isotopfrac(58,138)=0.0025
      isotopfrac(58,140)=0.8848
      isotopfrac(58,142)=0.1108
      isotopfrac(59,141)=1.00
      isotopfrac(60,142)=0.2713
      isotopfrac(60,143)=0.1218
      isotopfrac(60,144)=0.2380
      isotopfrac(60,145)=0.0830
      isotopfrac(60,146)=0.1719
      isotopfrac(60,148)=0.0576
      isotopfrac(60,150)=0.0564
      isotopfrac(62,144)=0.031
      isotopfrac(62,147)=0.150
      isotopfrac(62,148)=0.113
      isotopfrac(62,149)=0.138
      isotopfrac(62,150)=0.074
      isotopfrac(62,152)=0.267
      isotopfrac(62,154)=0.227
      isotopfrac(63,151)=0.478
      isotopfrac(63,153)=0.522
      isotopfrac(64,152)=0.0020
      isotopfrac(64,154)=0.0218
      isotopfrac(64,155)=0.1480
      isotopfrac(64,156)=0.2047
      isotopfrac(64,157)=0.1565
      isotopfrac(64,158)=0.2484
      isotopfrac(64,160)=0.2186
      isotopfrac(65,159)=1.00
      isotopfrac(66,156)=0.00056
      isotopfrac(66,158)=0.00096
      isotopfrac(66,160)=0.0234
      isotopfrac(66,161)=0.1891
      isotopfrac(66,162)=0.2551
      isotopfrac(66,163)=0.2490
      isotopfrac(66,164)=0.2819
      isotopfrac(67,165)=1.00
      isotopfrac(68,162)=0.0014
      isotopfrac(68,164)=0.0161
      isotopfrac(68,166)=0.336
      isotopfrac(68,167)=0.2295
      isotopfrac(68,168)=0.268
      isotopfrac(68,170)=0.149
      isotopfrac(69,169)=1.00
      isotopfrac(70,168)=0.0013
      isotopfrac(70,170)=0.0305
      isotopfrac(70,171)=0.143
      isotopfrac(70,172)=0.219
      isotopfrac(70,173)=0.1612
      isotopfrac(70,174)=0.318
      isotopfrac(70,176)=0.127
      isotopfrac(71,175)=0.9741
      isotopfrac(71,176)=0.0259
      isotopfrac(72,174)=0.00162
      isotopfrac(72,176)=0.05206
      isotopfrac(72,177)=0.18606
      isotopfrac(72,178)=0.27297
      isotopfrac(72,179)=0.13629
      isotopfrac(72,180)=0.35100
      isotopfrac(73,180)=0.00012
      isotopfrac(73,181)=0.99988
      isotopfrac(74,180)=0.0013
      isotopfrac(74,182)=0.263
      isotopfrac(74,183)=0.143
      isotopfrac(74,184)=0.3067
      isotopfrac(74,186)=0.286
      isotopfrac(75,185)=0.3740
      isotopfrac(75,187)=0.6260
      isotopfrac(76,184)=0.00018
      isotopfrac(76,186)=0.0158
      isotopfrac(76,187)=0.016
      isotopfrac(76,188)=0.133
      isotopfrac(76,189)=0.161
      isotopfrac(76,190)=0.264
      isotopfrac(76,192)=0.410
      isotopfrac(77,191)=0.373
      isotopfrac(77,193)=0.627
      isotopfrac(78,190)=0.000127
      isotopfrac(78,192)=0.0078
      isotopfrac(78,194)=0.329
      isotopfrac(78,195)=0.338
      isotopfrac(78,196)=0.252
      isotopfrac(78,198)=0.0719
      isotopfrac(79,197)=1.00
      isotopfrac(80,196)=0.001534
      isotopfrac(80,198)=0.09968
      isotopfrac(80,199)=0.16873
      isotopfrac(80,200)=0.23096
      isotopfrac(80,201)=0.13181
      isotopfrac(80,202)=0.29863
      isotopfrac(80,204)=0.06865
      isotopfrac(81,203)=0.29524
      isotopfrac(81,205)=0.70476
      isotopfrac(82,204)=0.0194
      isotopfrac(82,206)=0.1912
      isotopfrac(82,207)=0.2062
      isotopfrac(82,208)=0.5831
      isotopfrac(83,209)=1.00
      isotopfrac(90,232)=1.00
      isotopfrac(92,235)=0.007200
      isotopfrac(92,238)=0.992745

* get the mass of each isotope
* and recompute the default mix mass
* BPz 12/06-2012
      call getisotopmass(amass)
      do i=1,92
        tempmass=amass(i,0)
        amass(i,0)=0.
        do j=1,250
          amass(i,0)=amass(i,0)+isotopfrac(i,j)*amass(i,j)
        enddo
        if (amass(i,0).eq.0.) then
          amass(i,0)=tempmass
        endif
      enddo

*      print*,' Atomic masses are masses of the default terrestrial',
*     & ' isotopic mixture. Cf makeabund.f.'
*
*
* print out

c      open(90,file='abundances.tmp',status='unknown',form='formatted')
c      write(90,1020) overall,alpha,helium,rabund,sabund
c 1020 format('* STD? [Fe/H] [He/Fe] [alpha/Fe] [r/Fe] [s/Fe]',/,
c     &      '   1 ', 6f8.2)
c      write(90,1000) (aname(iel),iel= 1,10)
c      write(90,1010) (abund(iel),iel= 1,10)
c      write(90,1000) (aname(iel),iel=11,20)
c      write(90,1010) (abund(iel),iel=11,20)
c      write(90,1000) (aname(iel),iel=21,30)
c      write(90,1010) (abund(iel),iel=21,30)
c      write(90,1000) (aname(iel),iel=31,40)
c      write(90,1010) (abund(iel),iel=31,40)
c      write(90,1000) (aname(iel),iel=41,50)
c      write(90,1010) (abund(iel),iel=41,50)
c      write(90,1000) (aname(iel),iel=51,60)
c      write(90,1010) (abund(iel),iel=51,60)
c      write(90,1000) (aname(iel),iel=61,70)
c      write(90,1010) (abund(iel),iel=61,70)
c      write(90,1000) (aname(iel),iel=71,80)
c      write(90,1010) (abund(iel),iel=71,80)
c      write(90,1000) (aname(iel),iel=81,90)
c      write(90,1010) (abund(iel),iel=81,90)
c      write(90,1000) (aname(iel),iel=91,92)
c      write(90,1010) (abund(iel),iel=91,92)
c 1000 format('*   ',10(3x,a2,2x))
c 1010 format(2x,10f7.2)
c*
c      print *,'makeabund; check Output in file abundances.tmp'
      return
      end


**==nquil.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      SUBROUTINE NQUIL(T,N,Dene,Jcont,Iphot,Idens,Icx)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL abhe , ABUnd , ABUnj , ALFLO , ALPHADI , apple , AUTOIN , b ,
     &     be , beta , BINmin , BINsyz , C1 , C2 , c5 , c6 , CA , cd1 ,
     &     cd2 , chi
      REAL CION , CONce , CTH , CTHEI , CTHER , CTHI , CTHR , dd , dei ,
     &     Dene , denh , DIMET , DNE , E , E3 , EA , EFFN , EFFNEW ,
     &     ei , eion
      REAL em , emet , emetj , F , fmet , fplus , GND , GREC , HENeut ,
     &     HEPlus , orange , over , P , PCOol , PHOT , plum , PM ,
     &     POPMET , POT , POU
      REAL POWer , prod , qm , rat , RE , recn , rgnd , rho , RHY , S2 ,
     &     S3 , S4 , S5 , SEATON , sec , st , starn , sum , T , t6
      REAL TU , WAVe , worl , zeff , zf
      INTEGER i , Icx , Idens , imet , imeta , Iphot , ix , iy , j ,
     &        Jcont , jlow , jmax , jp , jtop , jump , k , kmax , ktop ,
     &        l , lion
      INTEGER LL , ln , N , NBIn , NJ , nn , nqm , nval
C*** End of declarations inserted by SPAG
C   ************************  METASTABLE POPULATION DATA

      DIMENSION emetj(30,4) , cd1(28) , cd2(28)
      DIMENSION rat(30) , prod(30) , c5(30) , c6(30) , over(30) ,
     &          imeta(30)
      DIMENSION sec(30)

      COMMON /DAT   / E(30) , EA(30) , S2(30) , WAVe(220) , E3(220) ,
     &                F(220) , LL(30) , S3(30) , S4(30) , S5(30)
      COMMON /PARAMS/ NJ(12) , ABUnj(12) , ABUnd , BINmin , BINsyz ,
     &                NBIn
      COMMON /RATES / C1(30) , C2(30) , CTH
      COMMON /RESULT/ CONce(30) , CA(30) , POWer(220) , RHY , HENeut ,
     &                HEPlus , DNE , PCOol , POU , POT , RE , TU , PM(4)

      DATA emetj/5*0. , 6.5 , 8.35 , 10.2 , 0. , 14. , 0. , 17.6 , 0. ,
     &     21.6 , 0. , 25.3 , 0. , 29.0 , 0. , 32.7 , 5*0. , 47.0 , 0. ,
     &     51.8 , 0. , 0. , 5*0. , 5.34 , 7.10 , 8.87 , 0. , 12.5 , 0. ,
     &     16.0 , 0. , 19.8 , 0. , 24.0 , 0. , 28.6 , 0. , 34.2 , 5*0. ,
     &     57.1 , 0. , 64.8 , 0. , 0. , 5*0. , 4.18 , 5.78 , 7.48 , 0. ,
     &     11.0 , 0. , 14.7 , 0. , 18.6 , 0. , 23.0 , 0. , 28.0 , 0. ,
     &     33.9 , 5*0. , 60.4 , 0. , 69.2 , 0. , 0. , 11*0. , 2.72 ,
     &     0. , 6.55 , 0. , 10.4 , 0. , 14.2 , 0. , 18.1 , 5*0. , 29.7 ,
     &     0. , 38.9 , 2*0./
C
      DATA imeta/0 , 0 , 0 , 1 , 2 , 3 , 5*0 , 4 , 18*0/
      DATA cd1/.0024 , -.0005 , .00 , .061 , .027 , .011 , .005 , .005 ,
     &     0. , .0107 , .09 , .13 , .11 , .081 , .075 , .066 , .051 ,
     &     11*0./
      DATA cd2/0. , .01485 , .300 , .108 , .107 , .024 , .075 , .051 ,
     &     .054 , .0167 , .36 , 17*0./
      DATA sec/4*1. , .9 , .9 , 6*1. , .6 , .5 , 1. , .7 , .9 , 13*1./

      fmet=0
      nval=0
      ix = 0
      abhe = 10.**(ABUnj(1)-12.)
      DO 100 i = 1 , 4
         PM(i) = 0.
 100  CONTINUE
      orange = 1.
      c5(1) = 0.
      c5(N+1) = 0.
      jlow = 1
      jmax = N + 1
      jtop = N + 1
      c6(1) = 0
      t6 = T*1.0E-6
      st = SQRT(T)
      DO 200 j = 1 , N
C  IONIZATION RATE FROM YOUNGER
         eion = E(j)
         C1(j) = CION(N,j,eion,T)
         IF ( N-j.GT.1 ) THEN
C  IONIZATION FROM METASTABLE LEVEL : BE,B,C,MG SEQUENCES
            IF ( Idens.NE.0 ) THEN
               imet = imeta(N-j+1)
               IF ( imet.NE.0 ) THEN
                  emet = emetj(N,imet)
                  fmet = POPMET(N,imet,emet,Dene,T)
                  PM(imet) = fmet
                  em = E(j) - emet
                  C1(j) = C1(j)*(1.-fmet) + fmet*CION(N,j,em,T)
               ENDIF
            ENDIF
C  INNERSHELL IONIZATION
            IF ( N-j.GT.1 ) THEN
               eion = EA(j)
               jp = N - 1
               IF ( N-j.GE.10 ) jp = N - 9
               C1(j) = C1(j) + CION(N,jp,eion,T)
            ENDIF
         ENDIF
C  IONIZATION FOLLOWING INNERSHELL EXCITATION  :  COWAN AND MANN
C  INCREASED FOR FE
         C1(j) = C1(j) + AUTOIN(N,j,T)
C  ****************      PHOTOIONIZATION
         IF ( Iphot.NE.0 ) C1(j) = C1(j) + PHOT(N,j,E(j),T,Dene)/Dene
C  ****************      RADIATIVE RECOMBINATION
         zeff = j
         beta = zeff*zeff/(6.34*t6)
         C2(j+1) = 2.07E-11*zeff*zeff*(0.4288+0.5*ALOG(beta)
     &             +0.469*(beta**(-1./3.)))/SQRT(T)
         apple = C2(j+1)
         plum = 0
         recn = 0.
         rgnd = 0.
         IF ( N.NE.j ) THEN
            nval = INT(GND(N-j) + 0.1)
            starn = SQRT(13.6/E(j))*zeff
            DO 120 nqm = 1 , nval
               qm = nqm
               be = beta/(qm*qm)
               C2(j+1) = C2(j+1) - 5.197E-14*j*SQRT(be)*SEATON(be,qm)
 120        CONTINUE
            IF ( C2(j+1).LT.0 ) C2(j+1) = 0
            i = N - j
C  RECOMBINATION TO GROUND STATE
            IF ( i.LE.17 ) rgnd = GREC(N,j,E(j),T)
            IF ( i.GT.1 ) THEN
               IF ( i.LT.4 .OR. i.GT.9 ) THEN
                  ei = E(j)
                  IF ( i.LT.17 ) THEN
C  RECOMBINATION TO OTHER STATES IN SAME SHELL
                     lion = 1
                     IF ( i.EQ.12 ) lion = 3
                     ei = ei - E3(ix+lion)
                  ENDIF
                  starn = SQRT(13.595/ei)*zeff
                  be = beta/(starn*starn)
                  recn = EFFNEW(N-j,T,zeff,N)*SEATON(be,starn)
     &                   *2.599E-14*j*SQRT(ei*11590./T)/(starn*starn)
               ENDIF
            ENDIF
         ENDIF
         C2(j+1) = C2(j+1) + recn + rgnd
         IF ( beta.GE.0.5 ) THEN
            chi = 0.5*(0.735+ALOG(beta)+1./(3.*beta))
         ELSE
            chi = 1.2*beta + (0.55+1.04*ALOG(beta))*beta*beta +
     &            (-0.43+1.01*ALOG(beta))*beta**3
         ENDIF
         DO 150 nqm = 1 , nval
            qm = nqm
            chi = chi - P(beta,qm)
 150     CONTINUE
         chi = chi + EFFN(N-j,zeff,T)*P(beta,starn)/(2.*starn*starn)
         c6(j+1) = E(j)*1.6027E-12*(C2(j+1)+4.22E-22*SQRT(T/1.037E-11)
     &             *chi)
C  DIELECTRONIC RECOMBINATION ***** DENSITY DEPENDENCE AND SECONDARY
C                             ***** AUTOIONIZATION
         iy = LL(j)*3
         IF ( j.NE.1 ) THEN
            zeff = j - 1
            rho = (Dene/zeff**7.)**.2
            dd = 1.
            IF ( rho.GE.3 ) dd = 1./(1.+(cd1(N-j+1)+cd2(N-j+1)/zeff)
     &                           *rho)
            DO 160 l = 1 , iy
               ln = ix + l
               plum = plum + ALPHADI(N,j,l,ln,T)*AMIN1(dd,sec(N-j+1))
 160        CONTINUE
C  DIELECTRONIC RECOMBINATION FOR METASTABLE LEVELS OF BE,B,C,MG ISO
            imet = imeta(N-j+1)
            IF ( imet.NE.0 ) THEN
               zf = j - 1
               b = SQRT(zf)*(zf+1.)**2.5/SQRT(zf*zf+13.4)
               plum = plum*(1.-fmet)
               plum = plum + fmet*DIMET(N,j,T,b,dd)
            ENDIF
C   *************** ADD DIELECTRONIC RECOMB AND STOREY'S LOW T DIELEC REC
            C2(j) = C2(j) + plum + ALFLO(N,j,T)
         ENDIF
         over(j) = plum/orange
         IF ( j.NE.1 ) c5(j) = plum*E(j-1)*10.**(ABUnd-1.)*1.6027
         ix = ix + iy
         orange = apple
 200  CONTINUE
      IF ( Icx.NE.0 ) THEN
C  CHARGE TRANSFER CONTRIBUTION
         fplus = RHY/(1.+RHY)
         denh = 1./(.003+fplus+abhe*HEPlus+abhe*2.*(1.-HENeut-HEPlus))
         C1(N+1) = 0.
         C2(1) = 0.
         nn = N + 1
C  **********************************  S. Butler Charge Transfer Rates
         DO 250 j = 1 , N
            C1(j) = C1(j) + CTHI(N,j,T)*denh*fplus + CTHEI(N,j,T,Dene)
     &              *HEPlus*abhe
            C2(j+1) = C2(j+1) + CTHR(N,j+1,T)*denh*(1.-fplus)
     &                + CTHER(N,j+1,T)*HENeut*abhe
 250     CONTINUE
      ENDIF
C  AUGER IONIZATION
      IF ( Iphot.EQ.2 ) CALL APHOT(N,Dene,Jcont)
      IF ( Jcont.EQ.1 ) GOTO 700
      DO 300 j = 1 , N
         C2(j+1) = ABS(C2(j+1))
         IF ( C1(j)/C2(j+1).LE.0. ) THEN
            rat(j) = 1.0E+6
         ELSE
            rat(j) = C2(j+1)/C1(j)
            IF ( j.EQ.1 .AND. T.GE.1.0E8 ) rat(j) = AMIN1(rat(j),1.0E4)
         ENDIF
         IF ( rat(j).LT.1.0E-5 ) jlow = j + 1
         IF ( rat(j).GE.1.0E+5 ) THEN
            jmax = j
            GOTO 400
         ENDIF
 300  CONTINUE
      IF ( jlow.EQ.jmax ) THEN
         sum = 1.0000
         GOTO 500
      ENDIF
 400  jump = jmax - 1
      prod(jump) = rat(jump)
      ktop = jump - jlow
      sum = 1.00000 + prod(jump)
      IF ( ktop.NE.0 ) THEN
         DO 450 k = 1 , ktop
            prod(jump-k) = rat(jump-k)*prod(jmax-k)
            prod(jump-k) = AMIN1(prod(jump-k),1.0E30)
            sum = sum + prod(jump-k)
 450     CONTINUE
      ENDIF
 500  DO 600 j = 1 , jtop
         CONce(j) = 0
         c5(j) = 0.
 600  CONTINUE
      CONce(jmax) = 1.000/sum
      kmax = jmax - jlow
      IF ( kmax.NE.0 ) THEN
         DO 650 k = 1 , kmax
            CONce(jmax-k) = prod(jmax-k)*CONce(jmax)
 650     CONTINUE
      ENDIF
 700  IF ( N.EQ.2 ) DNE = 0.
      worl = 0.
      dei = 0.
      DO 800 j = 1 , jtop
         DNE = (j-1)*CONce(j)*10.**(ABUnd-12.) + DNE
         c6(j) = c6(j)*CONce(j)*10.0**(11.+ABUnd)
         RE = RE + c6(j)
         c5(j) = c5(j)*CONce(j)
         PCOol = PCOol + c5(j)
         PCOol = PCOol + c6(j)
 800  CONTINUE
      RETURN
      END


PROGRAM test_cycle
INTEGER :: i
DO i = 1, 5
   IF ( i == 3 ) CYCLE
   WRITE (*,*) i
END DO
WRITE (*,*) 'End of loop!'
END PROGRAM test_cycle


program loop
    implicit none
    integer n;
    integer i;

    print *, "Enter value of n : ";
    read *, n;
    i = 0;

    ! This loop is similar to while loop
    do while(i .le. n)
       print *, i;
       i = i + 1;
    end do

    end program loop


!******************************************************************************
! OpenMP Example - Hello World - Fortran Version
! FILE: hello.f90
! DESCRIPTION:
!   In this simple example, the master thread forks a parallel region.
!   All threads in the team obtain their unique thread number and print it.
!   The master thread only prints the total number of threads.  Two OpenMP
!   library routines are used to obtain the number of threads and each
!   thread's number.
! SOURCE: Blaise Barney  5/99
! LAST REVISED: Thomas Hauser 09/09/04
!******************************************************************************

PROGRAM hello

  use OMP_LIB , only : omp_get_thread_num, omp_get_num_threads

  IMPLICIT NONE

  INTEGER :: nthreads, tid

  !$OMP PARALLEL private(tid, nthreads)
  tid = omp_get_thread_num()
  WRITE(*,*) 'Hello World from thread = ', tid
  !$OMP BARRIER
  IF (tid == 0) THEN
     nthreads = omp_get_num_threads()
     WRITE(*,*) 'Number of threads = ', nthreads
  END IF
  !$OMP END PARALLEL

END PROGRAM hello


module stdlib_experimental_error
implicit none
private
public :: assert, error_stop

contains

subroutine assert(condition)
! If condition == .false., it aborts the program.
!
! Arguments
! ---------
!
logical, intent(in) :: condition
!
! Example
! -------
!
! call assert(a == 5)

if (.not. condition) call error_stop("Assert failed.")
end subroutine

subroutine error_stop(msg)
! Aborts the program with nonzero exit code
!
! The statement "stop msg" will return 0 exit code when compiled using
! gfortran. error_stop() uses the statement "stop 1" which returns an exit code
! 1 and a print statement to print the message.
!
! Example
! -------
!
! call error_stop("Invalid argument")

character(len=*) :: msg ! Message to print on stdout
print *, msg
stop 1
end subroutine

end module


program test
    ! This is a comment.

    ! The decleartion statement must be in the front.
    ! declear test
    integer a ! declear a integer variable named 'a'(default: long integer with 4 byte)
    real b ! declear a real variable named 'b'(default: single real with 4 byte)
    complex c ! declear a complex variable named 'c'(default: single complex with two single real value)
    character d ! declear a character variable named 'd'(default: one character)
    logical e ! declear a logical variable named 'e'(default value is false)
    integer(kind=4) aa ! declear a long integer variable with 4 byte after F90
    integer*2 ab ! declear a short integer variable with 2 byte in F77
    integer(1) ac ! declear a integer variable with 1 byte(shorter than short integer) in F77
    real(kind=8) ba ! declear a double real variable with 8 byte have 15 effective numbers
    complex*8 ca ! declear a double complex variable with two double real value
    character(len=10) da ! declear a string with 10 characters after F90
    character*10 db ! declear a string with 10 characters in F77
    logical :: ea = .true. ! declear a variable with '::' and assign a value after F90
    print *, 'ea=', ea

    ! print test (output)
    print *, 'print test!' ! print is a write which set UNIT is '*'(screen)

    ! write test (output)
    write (*,*) 'write test!' ! the frist '*' is UNIT(6), and the second '*' is FMT(nothing special)
    write ( UNIT=6, FMT=* ) 'full write test', '!' ! there is no ',' in the book.It will wrong with my compiler.

    ! assign test
    print *, 'a =', a
    a = 1
    print *, 'a =', a
    print *, 'b =', b
    b = 3.14159265358979 ! The single real variable only hava 6 effective number after dot. It seems the assign numbers is a single real variable.
    print *, 'b =', b
    print *, 'c =', c
    c = (1.0,0.1)
    print *, 'c =', c
    print *, 'd =', d
    d = "a" ! Only """ can use to assign a character variable in F77
    print *, 'd =', d
    d = 'ab' ! Only the frist character will be assigned.
    print *, 'd =', d
    print *, 'e =', e
    e = .true. ! two dots must in two sides of 'true' or 'false'
    print *, 'e =', e

    ! read test (input)
    print *, 'please input a integer'
    read (*,*) a ! read a integer from keyboard
    print *, 'your number =', a

    ! stop program (unnecessary)
    stop

end program test


MODULE arraymod
  IMPLICIT NONE
  CONTAINS
  SUBROUTINE test_array(array_in)
    INTEGER, DIMENSION(:), ALLOCATABLE, INTENT(OUT) :: array_in

    PRINT *, 'In function, is array allocated :', ALLOCATED(array_in)
    ALLOCATE(array_in(-10:10))

  END SUBROUTINE test_array
END MODULE arraymod

PROGRAM test

  USE arraymod
  IMPLICIT NONE

  INTEGER, DIMENSION(:), ALLOCATABLE :: array
  ALLOCATE(array(0:9))
  CALL test_array(array)
  PRINT *,'After array is array allocated :', ALLOCATED(array)
  PRINT *,'Shape is', SIZE(array), LBOUND(array), UBOUND(array)

END PROGRAM test