program upd
c     ******************************************************************
c
c     A Simple Update Program                            vers: 1.2
c     for Maintaining FORTRAN Codes                      date: 6 may 92
c     -------------------------------
c
c     This program is loosely based on the UPDATE program that runs on
c     CDC and Cray machines.  It allows you to keep a record of
c     consecutive changes to a FORTRAN program that is useful for
c     history and quality assurance purposes.  The changes are
c     specified with simple commands that are easy to exchange
c     between various users of a code being maintained with upd.
c     This is a stripped-down adaptation with only basic capabilities,
c     but because of that, it is easy to install on any computer system.
c
c     The original FORTRAN source code is stored in the file "src".
c     It is divided up into separate named parts by "*deck name" lines.
c     In each named part, the first line after the "*deck" line
c     is numbered "name.2", the next card is referred to using "name.3",
c     etc.  The "src" files can also contain "*if", "*elseif", "*else",
c     and "*endif" lines as described below.  These lines are numbered
c     just like any other lines in the "src" file.
c
c     Changes to the FORTRAN code are given in an input file called
c     "upn".  This file is divided into separate named parts by
c     "*ident name".  Each "ident" can contain a mixture of upd direc-
c     tives and new FORTRAN statements. The directives are as follows:
c
c      *i ref
c          insert the lines between the "*i" directive and the
c          next upd directive after the location "ref".
c
c      *b ref
c          insert the lines between the "*b" directive and the
c          next upd directive before the location "ref".
c
c      *d ref1,ref2
c          delete the lines between "ref1" and "ref2, and
c          insert the lines between the "*d" directive and the
c          next upd directive (if any).
c
c     The line references can have the following forms:
c
c          name.5
c          name.5,7
c          name1.5,name2.6
c
c     Updates can be made on top of previous updates as long as
c     each line referenced is currently active.  Updates are
c     numbered so that the first line after the "*ident name" line
c     is labeled "name.2".
c
c     Update decks can also contain comments of the form
c
c          */ text
c
c     Comments are numbered just like other lines in the ident.
c     They are not written to the output files.  It is recommended
c     that "*/" comments be used to explain the purpose of each ident
c     and to give the date of the modification.
c
c     Both decks and update "idents" can contain conditional
c     statements.  Only the following very basic form is supported:
c
c          *if condition
c          ...
c          *elseif condition
c          ...
c          *else
c          ...
c          *endif
c
c     The condition consists of a single word that has been "set"
c     true with a "*set word" command at the beginning of the upd
c     input deck.  All words not set are assumed to be false.  These
c     "if" statements cannot be nested.
c
c     There are several upd commands that can appear at the
c     beginning of the upd input deck "upn".  They are as follows:
c
c       *cpl name1,name2,name3,.....
c          request that the named deck(s) be included in a partial
c          "cpl" file.  More than one "*cpl" command can be included.
c          Each line on the "cpl" file will have a label of the
c          form "name.number" starting in column 73.  The name will
c          be either a deck name or an ident name.  If no deck names
c          are given, all decks are written to the "cpl" file.
c
c       *noid
c          request that the card identifiers in colums 73-84 be
c          omitted from all lines of the cpl file.  This is required
c          for some compilers that cannot handle more than 80 chars
c          per line.  Use the lst file to determine card labels.
c
c       *npl
c          request that a new "src" file called "npl" be created
c          with all the corrections applied.  The "*deck" lines and
c          the "*if" constructs are included in the file.  No line
c          number identifiers are given.
c
c       *lst name1,name2,name3,.....
c          request that a special "lst" file be prepared containing
c          a listing of the modified file.  This listing has the line
c          identifier labels on the left and program, subroutine, or
c          function names on the right.  If there are no names
c          all decks are written to the "lst" file.  Otherwise only named
c          decks are written.  All branches of "*if" constructs are
c          listed.
c
c       *set word1,word2,.....
c          set a word or words for a "*if" construction to the "true"
c          state.
c
c     Running upd with the files "src" and "upn" present can generate
c     a file "cpl" containing the updated FORTRAN code ,an "npl" file
c     suitable for use as a new "src" file , "lst" file, or any combin-
c     ation of these three files depending on which directives appear in
c     "upn".  Note that "npl" is not a binary file as in CDC of CRAY
c     UPDATE and that no binary "OLDPL" is used in UPD.
c
c     history...
c
c     1.1     Increased number of active lines allowed to 5000.
c             Minor cleanup work.
c     1.2     Fixed a problem in deleting a range that started
c               inside one block and ended inside another.
c             Added the noid option.
c
c     ******************************************************************
      common /upd1/ nid,nact,ndecks
      common /upd2/ iseq,iseq1
      common /upd3/ iupn,iout
      common /upd4/ iact(3,5000)
      character*10 id
      common /upd5/ id(1000)
      common /upd6/ lid(1000)
      character*72 iline,lline
      character*10 opr,opn
      character*10 id1,id2
      character*12 label
      character*6 vers
      character*10 cnames(100),swords(100),gettok,lnames(100)
      external gettok
      character*7 sname
      logical new,list,compl,noid
      logical cdeck
      logical on,skip
c
c     ***initialize
      iout=6
cctss open(iout,status='new',file='tty')
      vers='1.2'
      llen=72
      write(iout,'('' upd: vers: '',a)') vers
c
c     ***read in the src file
      nsrc=1
      open(nsrc,file='src',status='old')
      nid=0
      nact=0
      iseq=0
      isrc=0
  110 isrc=isrc+1
      read(nsrc,'(a)',end=120) iline
      if (iline(1:5).eq.'*deck') then
         if (nid.gt.0) then
            iact(3,nact)=iseq
            iseq=0
         endif
         nid=nid+1
         if (nid.gt.1000)
     1      call error('too many identifiers (1000 max)')
         id(nid)=iline(7:16)
         lid(nid)=isrc
         nact=nact+1
         if (nact.gt.5000)
     1      call error('too many active line entries (5000 max)')
         iact(1,nact)=nid
         iact(2,nact)=1
      endif
      iseq=iseq+1
      go to 110
  120 iact(3,nact)=iseq
      ndecks=nid
      jsrc=isrc
      write(iout,'('' upd: src:'',i6,'' cards '',i4,'' decks'')')
     1   jsrc,ndecks
c
c     ***read the upd input "upn" file,
c     ***copy the lines to a direct access file,
c     ***and make a table of active lines
      nupn=2
      open(nupn,file='upn',status='old')
      ndir=3
      open(ndir,status='scratch',access='direct',recl=llen)
      nnames=0
      nlistn=0
      nwords=0
      new=.false.
      list=.false.
      noid=.false.
      iupn=0
      opr=' '
      lupn=0
  140 iupn=iupn+1
      read(nupn,'(a)',end=150) iline
      write(ndir,rec=iupn) iline
      go to 160
  150 iline='*end'
c
c     ***is this an operation?
  160 if (iline(1:1).ne.'*') go to 175
      if (iline(1:2).eq.'*/') go to 175
      j=1
      call getopr(j,iline,opn)
      if (opn.ne.'*ident'.and.opn.ne.'*b'.and.opn.ne.'*d'
     1   .and.opn.ne.'*i'.and.opn.ne.'*end') go to 170
c
c     ***perform the pending operation
      if (opr.eq.'*ident') then
         nid=nid+1
         if (nid.gt.1000)
     1      call error('too many identifiers (1000 max)')
         id(nid)=lline(8:n)
         lid(nid)=lupn
         iseq=iupn-lupn+1
         iseq1=iseq
      else if (opr.eq.'*b') then
         call getadr(i,lline,id1,n1,id2,n2)
         call before(id1,n1)
      else if (opr.eq.'*d') then
         call getadr(i,lline,id1,n1,id2,n2)
         call delete(id1,n1,id2,n2)
      else if (opr.eq.'*i') then
         call getadr(i,lline,id1,n1,id2,n2)
         call insert(id1,n1)
      endif
c
c     ***get the new operation
      i=j
      opr=opn
      n=len(iline)
      if (opr.eq.'*end') go to 180
      lline=iline
      lupn=iupn
      iseq=iseq+1
      iseq1=iseq
      go to 140
c
c     ***is this a upd command?
  170 iseq=iseq+1
      nn=len(iline)
      if (opn.eq.'*npl') then
         new=.true.
         opr=opn
         go to 140
      else if (opn.eq.'*lst') then
         list=.true.
         idx=6
 172     lnames(nlistn+1)=gettok(iline,idx,nn)
         if(lnames(nlistn+1).ne.' ') then
           nlistn=nlistn+1
           if(idx.lt.nn) go to 172
         endif
         opr=opn
         go to 140
      else if (opn.eq.'*cpl') then
         compl=.true.
         idx=6
 173     cnames(nnames+1)=gettok(iline,idx,nn)
         if(cnames(nnames+1).ne.' ') then
           nnames=nnames+1
           if(idx.lt.nn) go to 173
         endif
         opr=opn
         go to 140
      else if (opn.eq.'*noid') then
         noid=.true.
         opr=opn
         go to 140
      else if (opn.eq.'*set') then
         idx=6
 174     swords(nwords+1)=gettok(iline,idx,nn)
         if(swords(nwords+1).ne.' ') then
           nwords=nwords+1
           if(idx.lt.nn) go to 174
         endif
         opr=opn
         go to 140
      else
         go to 140
      endif
c
c     ***data line
  175 iseq=iseq+1
      go to 140
c
c     ***finished up the "upn" file
 180  write(iout,'('' upd: upn:'',i6,'' cards '',i4,'' idents'')')
     1   iupn,nid-ndecks
      if(.not.compl) go to 300
c
c     ***write the "cpl" file
      ncpl=4
      icpl=0
      rewind nsrc
      isrc=0
      open(ncpl,file='cpl',status='unknown')
      cdeck=.true.
      on=.true.
      do 290 i=1,nact
c
c     ***get the parameters for this table entry
      k1=iact(1,i)
      id1=id(k1)
      i1=iact(2,i)
      i2=iact(3,i)
      do 190 j=1,nid
      k=j
      if (id1.eq.id(j)) go to 200
  190 continue
  200 l=lid(k)
      if (i1.gt.1) go to 205
      if (nnames.eq.0) go to 205
      cdeck=.false.
      do 204 j=1,nnames
      if (cnames(j).eq.id1) cdeck=.true.
  204 continue
  205 if (k.gt.ndecks) go to 240
c
c     ***take lines from "src" decks
      nskip=l+i1-isrc-2
      if (nskip.le.0) go to 220
      do 210 ii=1,nskip
      isrc=isrc+1
      read (nsrc,'(a)') iline
  210 continue
  220 nkeep=i2-i1+1
      do 230 ii=1,nkeep
      isrc=isrc+1
      read (nsrc,'(a)') iline
c
c     ***check whether this line is to be written
      if (.not.cdeck) go to 230
      if (iline(1:5).eq.'*deck') go to 230
      if (iline(1:3).eq.'*if') then
         skip=.false.
         on=.false.
         if (nwords.eq.0) go to 230
         do 225 j=1,nwords
         if (swords(j).eq.iline(5:n)) on=.true.
  225    continue
         if (on) skip=.true.
         go to 230
      elseif (iline(1:7).eq.'*elseif') then
         if (skip) then
            on=.false.
            go to 230
         endif
         on=.false.
         if (nwords.eq.0) go to 230
         do 226 j=1,nwords
         if (swords(j).eq.iline(9:n)) on=.true.
  226    continue
         if (on) skip=.true.
         go to 230
      elseif (iline(1:5).eq.'*else') then
         on=.not.skip
         go to 230
      elseif (iline(1:6).eq.'*endif') then
         on=.true.
         go to 230
      endif
      if (.not.on) go to 230
c
c     ***write the line with or without label
      if (noid) then
         write(ncpl,'(a)') iline
      else
         call packl(id1,isrc-l+1,label)
         write (ncpl,'(a72,a12)') iline,label
      endif
      icpl=icpl+1
  230 continue
      go to 290
 
c     ***take lines from "upn" input
  240 nkeep=i2-i1+1
      do 250 ii=1,nkeep
      read (ndir,rec=l+i1+ii-2) iline
c
c     ***check whether this line is to be written
      if (.not.cdeck) go to 250
      if (iline(1:3).eq.'*if') then
         skip=.false.
         on=.false.
         if (nwords.eq.0) go to 250
         do 245 j=1,nwords
         if (swords(j).eq.iline(5:n)) on=.true.
  245    continue
         if (on) skip=.true.
         go to 250
      elseif (iline(1:7).eq.'*elseif') then
         if (skip) then
            on=.false.
            go to 250
         endif
         on=.false.
         if (nwords.eq.0) go to 250
         do 246 j=1,nwords
         if (swords(j).eq.iline(9:n)) on=.true.
  246    continue
         if (on) skip=.true.
         go to 250
      elseif (iline(1:5).eq.'*else') then
         on=.not.skip
         go to 250
      elseif (iline(1:6).eq.'*endif') then
         on=.true.
         go to 250
      endif
      if (.not.on) go to 250
      if (iline(1:2).eq.'*/') go to 250
c
c     ***write the line with or without label
      if (noid) then
         write(ncpl,'(a)') iline
      else
         call packl(id1,i1+ii-1,label)
         write (ncpl,'(a72,a12)') iline,label
      endif
      icpl=icpl+1
  250 continue
c
c     ***continue loop over entries in table of active lines
  290 continue
      write(iout,'('' upd: cpl:'',i6,'' lines written'')') icpl
      close (ncpl)
c
c     ***write the "npl" file
 300  if(.not.new) go to 400
      nnpl=4
      inpl=0
      rewind nsrc
      isrc=0
      open(nnpl,file='npl',status='unknown')
      do 390 i=1,nact
c
c     ***get the parameters for this table entry
      k1=iact(1,i)
      id1=id(k1)
      i1=iact(2,i)
      i2=iact(3,i)
      do 310 j=1,nid
      k=j
      if (id1.eq.id(j)) go to 320
  310 continue
  320 l=lid(k)
      if (k.gt.ndecks) go to 360
c
c     ***take lines from "src" decks
      nskip=l+i1-isrc-2
      if (nskip.le.0) go to 340
      do 330 ii=1,nskip
      isrc=isrc+1
      read (nsrc,'(a)') iline
  330 continue
  340 nkeep=i2-i1+1
      do 350 ii=1,nkeep
      isrc=isrc+1
      read (nsrc,'(a)') iline
      if (iline(1:2).eq.'*/') go to 350
      inpl=inpl+1
      write (nnpl,'(a72)') iline
  350 continue
      go to 390
 
c     ***take lines from "upn" input
  360 nkeep=i2-i1+1
      do 370 ii=1,nkeep
      read (ndir,rec=l+i1+ii-2) iline
      if (iline(1:2).eq.'*/') go to 370
      inpl=inpl+1
      write (nnpl,'(a72)') iline
  370 continue
c
c     ***continue loop over entries in table of active lines
  390 continue
      write(iout,'('' upd: npl:'',i6,'' lines written'')') inpl
      close (nnpl)
c
c     ***write the "lst" file
 400  if(.not.list) go to 500
      nlst=4
      ilst=0
      rewind nsrc
      isrc=0
      open(nlst,file='lst',status='unknown')
      do 490 i=1,nact
c
c     ***get the parameters for this table entry
      k1=iact(1,i)
      id1=id(k1)
      i1=iact(2,i)
      i2=iact(3,i)
      do 410 j=1,nid
      k=j
      if (id1.eq.id(j)) go to 420
  410 continue
  420 l=lid(k)
      if (i1.gt.1) go to 425
      cdeck=.true.
      if(nlistn.ne.0) then
        cdeck=.false.
        do 424 j=1,nlistn
        if (lnames(j).eq.id1) cdeck=.true.
  424   continue
      endif
  425 if (k.gt.ndecks) go to 460
c
c     ***take lines from "src" decks
      nskip=l+i1-isrc-2
      if (nskip.le.0) go to 440
      do 430 ii=1,nskip
      isrc=isrc+1
      read (nsrc,'(a)') iline
  430 continue
  440 nkeep=i2-i1+1
      do 450 ii=1,nkeep
      isrc=isrc+1
      read (nsrc,'(a)') iline
      j=0
      if(iline(1:1).ne.'c') then
         jj=7
         call skipb(iline,jj)
         if (iline(jj:jj+6).eq.'program') then
            j=jj+8
         elseif (iline(jj:jj+9).eq.'subroutine') then
            j=jj+11
         elseif (iline(jj:jj+7).eq.'function') then
            j=jj+9
         else
            do 441 jk=jj,nn
            if(iline(jk:jk).eq.' ') go to 442
  441       continue
            go to 443
  442       call skipb(iline,jk)
            if (iline(jk:jk+6).eq.'program') j=jk+8
            if (iline(jk:jk+9).eq.'subroutine') j=jk+11
            if (iline(jk:jk+7).eq.'function') j=jk+9
         endif
      endif
  443 if (j.eq.0) go to 447
      call skipb(iline,j)
      nn=len(iline)
      do 445 jj=j,nn
      k=jj
      if (iline(jj:jj).eq.'(') go to 446
  445 continue
  446 k=k-1
      sname=iline(j:k)
  447 if (.not.cdeck) go to 450
      if (iline(1:5).eq.'*deck') go to 450
      if (iline(1:2).eq.'*/') go to 450
      call packl(id1,isrc-l+1,label)
      ilst=ilst+1
      write (nlst,'(a12,'' --- '',a72,'' '',a7)') label,iline,sname
  450 continue
      go to 490
 
c     ***take lines from "upn" input
  460 nkeep=i2-i1+1
      do 470 ii=1,nkeep
      read (ndir,rec=l+i1+ii-2) iline
      j=0
      if(iline(1:1).ne.'c') then
         jj=7
         call skipb(iline,jj)
         if (iline(jj:jj+6).eq.'program') then
            j=jj+8
         elseif (iline(jj:jj+9).eq.'subroutine') then
            j=jj+11
         elseif (iline(jj:jj+7).eq.'function') then
            j=jj+9
         else
            do 461 jk=jj,nn
            if(iline(jk:jk).eq.' ') go to 462
  461       continue
            go to 463
  462       call skipb(iline,jk)
            if (iline(jk:jk+6).eq.'program') j=jk+8
            if (iline(jk:jk+9).eq.'subroutine') j=jk+11
            if (iline(jk:jk+7).eq.'function') j=jk+9
         endif
      endif
  463 if (j.eq.0) go to 467
      call skipb(iline,j)
      do 465 jj=j,nn
      k=jj
      if (iline(jj:jj).eq.'(') go to 466
  465 continue
  466 k=k-1
      sname=iline(j:k)
  467 if (.not.cdeck) go to 470
      if (iline(1:2).eq.'*/') go to 470
      call packl(id1,i1+ii-1,label)
      ilst=ilst+1
      write (nlst,'(a12,'' --- '',a72,'' '',a7)') label,iline,sname
  470 continue
c
c     ***continue loop over entries in table of active lines
  490 continue
      write(iout,'('' upd: lst:'',i6,'' lines written'')') ilst
      close (nlst)
c
  500 write(iout,'('' upd: complete'')')
      end
c
      subroutine getopr(i,iline,opr)
c     ******************************************************************
c     parse the upd command line for the operation
c     ******************************************************************
      character*(*) iline,opr
c
      n=len(iline)
  110 if (i.gt.n) go to 120
      if (iline(i:i).eq.' ') go to 120
      i=i+1
      go to 110
  120 opr=iline(1:i-1)
      return
      end
c
      subroutine getadr(i,iline,id1,n1,id2,n2)
c     ******************************************************************
c     parse the upd command line for addresses
c     ******************************************************************
      common /upd1/ nid,nact,ndecks
      character*(*) iline,id1,id2
      integer n1,n2
c
      if(nid-ndecks.eq.0) call error('ident directive missing')
      n=len(iline)
      k=0
      do 100 j=1,n
      if (iline(j:j).ne.' ') k=j
  100 continue
      n=k
      j=i
      if (j.gt.n) go to 180
  110 if (iline(j:j).eq.'.') go to 120
      if (iline(j:j).eq.' ') i=i+1
      j=j+1
      go to 110
  120 id1=iline(i:j-1)
      j=j+1
      i=j
      n1=0
  130 if (j.gt.n) go to 190
      m=ichar(iline(j:j))-ichar('0')
      if (m.lt.0.or.m.gt.9) go to 140
      n1=10*n1+m
      j=j+1
      go to 130
  140 j=j+1
      i=j
      m=ichar(iline(j:j))-ichar('0')
      if (m.lt.0.or.m.gt.9) go to 150
      id2=id1
      n2=0
      go to 170
  150 if (iline(j:j).eq.'.') go to 160
      if (iline(j:j).eq.' ') i=i+1
      j=j+1
      go to 150
  160 id2=iline(i:j-1)
      j=j+1
      i=j
      n2=0
  170 m=ichar(iline(j:j))-ichar('0')
      if (m.lt.0.or.m.gt.9) go to 200
      n2=10*n2+m
      j=j+1
      go to 170
  180 id1=' '
      n1=0
  190 id2=id1
      n2=n1
  200 return
      end
c
      subroutine before(id1,n1)
c     ******************************************************************
c     insert lines before the specified line
c     ******************************************************************
      character*(*) id1
      integer n1
      common /upd1/ nid,nact,ndecks
      common /upd2/ iseq,iseq1
      common /upd4/ iact(3,5000)
      character*10 id
      common /upd5/ id(1000)
      common /upd6/ lid(1000)
c
c     ***check the insert id string
      i1=0
      do 110 i=1,nid
      if (id1.eq.id(i)) i1=i
  110 continue
      if (i1.eq.0) call error('unknown identifier for before')
c
c     ***check the insert line number
      k1=1
  120 if (i1.eq.iact(1,k1)
     1  .and.n1.ge.iact(2,k1).and.n1.le.iact(3,k1)) go to 130
      k1=k1+1
      if (k1.le.nact) go to 120
      call error('line is not active for before')
c
c     ***special case for before the first line in a block
  130 if (n1.gt.iact(2,k1)) go to 160
      n=nact-k1+1
      do 150 j=1,n
      k=nact-j+1
      do 140 l=1,3
      iact(l,k+1)=iact(l,k)
  140 continue
  150 continue
      nact=nact+1
      if (nact.gt.5000)
     1   call error('too many active line entries (5000 max)')
      iact(1,k1)=nid
      iact(2,k1)=iseq1
      iact(3,k1)=iseq-1
      go to 190
c
c     ***open up space in the active lines table
c     ***and fix up the active line data
  160 n=nact-k1
      do 180 j=1,n
      k=nact-j+1
      do 170 l=1,3
      iact(l,k+2)=iact(l,k)
  170 continue
  180 continue
      nact=nact+2
      if (nact.gt.1000)
     1   call error('too many active line entries (1000 max)')
      iact(1,k1+2)=iact(1,k1)
      iact(2,k1+2)=n1
      iact(3,k1+2)=iact(3,k1)
      iact(1,k1+1)=nid
      iact(2,k1+1)=iseq1
      iact(3,k1+1)=iseq-1
      iact(3,k1)=n1-1
  190 continue
      return
      end
c
      subroutine delete(id1,n1,id2,n2)
c     ******************************************************************
c     delete lines, and insert following text (if any)
c     ******************************************************************
      character*(*) id1,id2
      integer n1,n2
      common /upd1/ nid,nact,ndecks
      common /upd2/ iseq,iseq1
      common /upd4/ iact(3,5000)
      character*10 id
      common /upd5/ id(1000)
      common /upd6/ lid(1000)
      character*10 id3
      integer n3
      logical after
c
c     ***check the two id strings
      i1=0
      i2=0
      do 110 i=1,nid
      if (id1.eq.id(i)) i1=i
      if (id2.eq.id(i)) i2=i
  110 continue
      if (i1.eq.0) call error('unknown identifier for delete')
      if (i2.eq.0) call error('unknown identifier for delete')
c
c     ***check the two line numbers
      k1=1
  120 if (i1.eq.iact(1,k1)
     1   .and.n1.ge.iact(2,k1).and.n1.le.iact(3,k1)) go to 130
      k1=k1+1
      if (k1.le.nact) go to 120
      call error('first line for delete is not active')
  130 k2=k1
  140 if (i2.eq.iact(1,k2)
     1   .and.n2.ge.iact(2,k2).and.n2.le.iact(3,k2)) go to 150
      k2=k2+1
      if (k2.le.nact) go to 140
      call error('second line for delete is not active')
c
c     ***do all the special cases
  150 if (n1.gt.iact(2,k1)) go to 220
      if (n2.lt.iact(3,k2)) go to 180
c
c     ***delete entire blocks
      m=k2-k1+1
      n=nact-k1
      if (n.le.0) go to 175
      do 170 i=1,n
      k=k1+i-1
      do 160 j=1,3
      iact(j,k)=iact(j,k+m)
  160 continue
  170 continue
  175 nact=nact-m
      if (k1.le.nact) then
         after=.false.
      else
         after=.true.
         k1=k1-1
      endif
      go to 350
c
c     ***break occurs in second block only
  180 m=k2-k1
      n=nact-k1
      if (m.eq.0.or.n.eq.0) go to 210
      do 200 i=1,n
      k=k1+i-1
      do 190 j=1,3
      iact(j,k)=iact(j,k+m)
  190 continue
  200 continue
  210 nact=nact-m
      iact(2,k1)=n2+1
      after=.false.
      go to 350
c
c     ***break occurs in first block only
  220 if (k1.ne.k2.or.n2.ne.iact(3,k1)) go to 270
      m=k2-k1
      n=nact-k1-1
      if (m.eq.0.or.n.eq.0) go to 250
      do 240 i=1,n
      k=k1+i
      do 230 j=1,3
      iact(j,k)=iact(j,k+m)
  230 continue
  240 continue
  250 nact=nact-m
      iact(3,k1)=n1-1
      after=.true.
      go to 350
c
c     ***breaks occcur in the middle of different blocks
  270 if (k2.eq.k1) go to 310
      m=k2-k1-1
      if (m.eq.0) go to 300
      n=nact-k1-m
      do 290 i=1,n
      k=k1+1+(i-1)
      do 280 j=1,3
  280 iact(j,k)=iact(j,k+m)
  290 continue
  300 nact=nact-m
      iact(3,k1)=n1-1
      iact(2,k1+1)=n2+1
      after=.true.
      go to 350
c
c     ***break occurs in the middle of a single block
  310 n=nact-k1
      if (n.eq.0) go to 340
      do 330 i=1,n
      k=nact-i+1
      do 320 j=1,3
      iact(j,k+1)=iact(j,k)
  320 continue
  330 continue
  340 nact=nact+1
      if (nact.gt.5000)
     1   call error('too many active line entries (5000 max)')
      iact(1,k1+1)=iact(1,k1)
      iact(2,k1+1)=n2+1
      iact(3,k1+1)=iact(3,k1)
      iact(3,k1)=n1-1
      after=.true.
  350 continue
c
c     ***insert the additional lines (if any)
      if (iseq.eq.iseq1) return
      if (after) then
         k=iact(1,k1)
         id3=id(k)
         n3=iact(3,k1)
         call insert(id3,n3)
      else
         k=iact(1,k1)
         id3=id(k)
         n3=iact(2,k1)
         call before(id3,n3)
      endif
c
c     ***finished with delete
      return
      end
c
      subroutine insert(id1,n1)
c     ******************************************************************
c     insert lines
c     ******************************************************************
      character*(*) id1
      integer n1
      common /upd1/ nid,nact,ndecks
      common /upd2/ iseq,iseq1
      common /upd4/ iact(3,5000)
      character*10 id
      common /upd5/ id(1000)
      common /upd6/ lid(1000)
c
c     ***check the insert id string
      i1=0
      do 110 i=1,nid
      if (id1.eq.id(i)) i1=i
  110 continue
      if (i1.eq.0) call error('unknown identifier for insert')
c
c     ***check the insert line number
      k1=1
  120 if (i1.eq.iact(1,k1)
     1  .and.n1.ge.iact(2,k1).and.n1.le.iact(3,k1)) go to 130
      k1=k1+1
      if (k1.le.nact) go to 120
      call error('line is not active for insert')
c
c     ***special case for insert after last line in block
  130 if (n1.lt.iact(3,k1)) go to 170
      n=nact-k1
      if (n.eq.0) go to 160
      do 150 j=1,n
      k=nact-j+1
      do 140 l=1,3
      iact(l,k+1)=iact(l,k)
  140 continue
  150 continue
  160 nact=nact+1
      if (nact.gt.5000)
     1   call error('too many active line entries (5000 max)')
      iact(1,k1+1)=nid
      iact(2,k1+1)=iseq1
      iact(3,k1+1)=iseq-1
      go to 200
c
c     ***open up space in the active lines table
c     ***and update the active line entries
  170 n=nact-k1+1
      do 190 j=1,n
      k=nact-j+1
      do 180 l=1,3
      iact(l,k+2)=iact(l,k)
  180 continue
  190 continue
      nact=nact+2
      if (nact.gt.5000)
     1   call error('too many active line entries (5000 max)')
      iact(1,k1+2)=iact(1,k1)
      iact(2,k1+2)=n1+1
      iact(3,k1+2)=iact(3,k1)
      iact(1,k1+1)=nid
      iact(2,k1+1)=iseq1
      iact(3,k1+1)=iseq-1
      iact(3,k1)=n1
  200 continue
c
      return
      end
c
      subroutine packl(name,number,label)
c     ******************************************************************
c     pack the name and number into an upd identifier
c     format= <7 chars right justified>.<4 digits left justified>
c     ******************************************************************
      character*(*) name
      integer number
      character*(*) label
      character*5 num
      character*6 blank
c
      blank='      '
      n=len(name)
      do 110 i=1,n
      j=i
      if (name(i:i).eq.' ') go to 120
  110 continue
  120 j=j-1
      write (num,'(i4)') number
      do 130 i=1,4
      k=i
      if (num(i:i).ne.' ') go to 140
  130 continue
  140 l=7-j
      if (l.eq.0) then
         label=name(1:7)//'.'//num(k:5)
      else
         label=blank(1:l)//name(1:j)//'.'//num(k:5)
      endif
      return
      end
c
      subroutine error(mess)
c     ******************************************************************
c     fatal error routine
c     ******************************************************************
      character*(*) mess
      common /upd3/ iupn,iout
c
      write (iout,'('' upd: fatal error''/
     1   '' upd: at upn line number '',i5/
     1   '' upd: '',a)') iupn,mess
      call abort
      return
      end
c
      character*10 function gettok(iline,idx,nn)
c     ******************************************************************
c     get next token from an input line
c     ******************************************************************
      character*72 iline
      character*1 ib,ic
      data ib,ic/' ',','/
c
      do 110 i=idx,nn
      if(iline(i:i).ne.ib.and.iline(i:i).ne.ic) go to 120
  110 continue
      gettok=' '
      return
  120 istrt=i
      do 130 i=istrt+1,nn
      if(iline(i:i).eq.ib.or.iline(i:i).eq.ic) go to 140
  130 continue
      gettok=iline(istrt:nn)
      idx=nn+1
      return
  140 gettok=iline(istrt:i-1)
      idx=i+1
      return
      end
c
      subroutine skipb(iline,j)
c     ******************************************************************
c     skip blanks
c     ******************************************************************
      character*72 iline
      nn=len(iline)
      do 110 jj=j,nn
      if (iline(jj:jj).eq.' ') go to 110
      j=jj
      return
  110 continue
      return
      end