c**********************************************************************
c**********************************************************************
c
c          Formatfreie Dateneingabe (Fortran,Cray-compatibel)
c          ==================================================
c
c                          Horst Hollatz
c
c
c  Die hier vorgestellte formatfreie Dateneingabe soll die 
c  Anwendung der formatierten Eingabe nicht ersetzen; 
c  sie soll vielmehr den Datentransfer bei numerischen Algorithmen 
c  erleichtern.
c
c  Das formatfreie Einlesen von Daten ist durch 
c   
c       call readin(lun,datei,ac)
c        
c  zu initialisieren. 
c  Dabei haben die Parameter folgende Bedeutung:
c
c  lun:   (integer*4) logische Nummer des Eingabemediums;
c         bei lun=0  wird die Standardeingabe verwendet.
c         Nach dem Öffnen ist die Variable lun reserviert und darf 
c         insbesondere nicht überschrieben werden. Bei jedem Aufruf
c         einer der nachfolgenden Routinen ist lun als 1. Parameter
c         anzugeben.
c  datei: (character*) Name der Eingabedatei.
c  ac     (character*) Zugriffsart
c         ac='BACKSPACE': Rücksetzen um einen Satz.
c         ac='REWIND': Rücksetzen auf den Dateianfang.
c         sonst: Ohne Wirkung.
c
c  Wiederholtes Öffnen einer unter einer logischen Nummer bereits
c  geöffneten Datei führt zu folgenden Aktionen:
c  - Löschen des Fehlerwertes und des Fehlertextes (siehe rdcode),
c  - Hochzählen eines Öffnungszählers, sofern der Parameter ac keine 
c    Wirkung hatte.
c  Mit
c
c       call readae(lun,anfang,ende)
c
c  werden eine Daten-Anfangs- und eine Daten-Endemarke gesetzt.
c  Es wird in der Datei bis zur ersten Zeile gegangen, die mit 
c  der Daten-Anfangsmarke beginnt; das formatfreie Einlesen beginnt
c  nach dieser Zeile und endet mit der nächsten Zeile, die mit der 
c  Endemarke beginnt. Danach werden beide Marken werden auf ' ' 
c  gesetzt. Im Falle anfang = ' ' oder ende = ' ' werden die Marken 
c  als nicht gesetzt betrachtet.
c  Bei
c   
c      call readcl(lun)
c   
c  wird der Öffnungszähler reduziert; ist er 0, wird die Datei
c  geschlossen. Zum erneuten bzw. weiteren Einlesen ist der 
c  Einlesevorgang durch erneuten Aufruf von readin zu initialisieren.
c
c  Die einzulesenden Daten werden identifiziert. Um ganze Zahlen von
c  reellen unterscheiden zu können, müssen reelle Zahlen einen Punkt 
c  oder einen Exponenten (durch E/e oder D/d eingeleitet) enthalten.
c  Anstelle eines Punktes wird auch ein Komma akzeptiert. 
c  Für Zahlen ist ein Wiederholungsfaktor in der Form l*Zahl möglich.
c  Sollte sich eine anliegende Information nicht als ganze oder 
c  reelle Zahl bzw. Wiederholungsfaktor interpretieren lassen, wird 
c  sie als Zeichenkette gedeutet.
c  Folgende Daten sind einlesbar.
c  Mit
c   
c      call readCC(lun,feld,n)
c   
c  werden n Daten auf das Feld feld eingelesen; 
c  sie müssen den Typ haben, der durch CC characterisiert wird:
c  CC darf einen der Werte ch, i2, i4, r4, r8 haben; dabei bedeutet ch
c  das alphanumerische Einlesen, i2 das Einlesen von integer*2-Zahlen 
c  usw. Für Zahlen ist ein Wiederholungsfaktor in der Form l*Zahl 
c  möglich.
c  Bei alphanumerischem Einlesen werden n Zeichenketten gelesen. 
c  Falls ein Feldelement l>1 Zeichen aufnehmen kann, werden l Zeichen 
c  pro Feldelement gelesen; der eventuell vorhandene Reststring wird 
c  übersprungen.
c  Mit
c   
c      inread(lun,i4,r8,ch)
c   
c  wird die nächste Information identifiziert. Die Routine prüft die 
c  nächste anliegende Information, ob es sich um eine ganze oder 
c  reelle Zahl handelt (in dieser Reihenfolge) und speichert sie auf 
c  i4 bzw. r8 ab. Sollte die Prüfung nicht erfolgreich sein, wird die 
c  Information als Zeichenkette auf dem Feld ch abgelegt. 
c  In Abhängigkeit von der Interpretation hat die Funktion einen der 
c  Werte -1, 0, 1.
c  Mit
c 
c      call rdcode(lun,irc,fehler)
c
c  wird auf irc der letzte Fehlerwert und auf fehler (character*64)
c  ein Fehlertext zurückgegeben.
c  Es gibt die folgenden Fehlerwerte:
c   
c  -1 Information zu lang
c  -2 negativer Wiederholungsfaktor
c  -3 Wiederholungsfaktor zu groß
c  -4 die geforderte Information liegt nicht an
c     (z. B. Zahl enthält ein falsches Zeichen)
c  1  Dateiöffnung nicht erfolgreich
c  2  Einlesefehler
c  3  Dateiende erreicht
c  4  Daten-Endemarke gelesen
c
c
c  Längen-Beschränkungen:
c
c  -  Reelle Zahlen dürfen aus höchstens 32 Ziffern bestehen (rzahl).
c  -  Ganze Zahlen dürfen aus höchstens 9 Ziffern bestehen (izahl).
c  -  Von der Daten-Anfangs- und Endemarke sind die ersten 8 Bytes 
c     signifikant (lcanf,lcende).
c  -  Die maximale Satzlänge beträgt 256 (lmax).
c  -  Die maximale Dateinamenslänge beträgt 64 (ldatei).
c
c  Alle Längenbeschränkungen sind durch Parameter festgelegt, deren
c  Werte geändert werden dürfen.
c
c**********************************************************************
c**********************************************************************

      subroutine readin(lun,datei,ac)
      character null,neun,leer
      integer rzahl
      parameter(rzahl=32,izahl=9,lmax=256,ldatei=64,lfehler=64,
     f          lcanf=8,lcende=8)
      parameter(null='0',neun='9',leer=' ')
      parameter(lstruct=lmax+ldatei+lfehler+lcanf+lcende+24)
      integer*4 i4(*),last/0/
      integer*2 i2(*)
      real*4 r4(*)
      real*8 r8(*),rr
      character*(*) datei,ch(*),fehler,anfang,ende,ac
      structure /a/
        integer*4 next,count,lun,irc,la,isp
        character datei*(ldatei),canf*(lcanf),cende*(lcende),
     f            a*(lmax),fehler*(lfehler)
      endstructure
      record /a/ a
      pointer(a_,a)
      character aa,axa*(lcanf),axe*(lcende),d*50,
     f          form5*5/'(i  )'/,form7*7/'(D  .0)'/,
     f          form8*8/'(a    )'/
      logical vorz,ip,ziff,ird
      
      save last,form5,form7,form8,inull,ineun
c
      inull = ichar(null)
      ineun = ichar(neun)
      write(form8(3:6),'(i4)') lmax
      iun=max(lun,0)
      if(iun.eq.0)datei=' '
      if(iun.gt.99)then
        a_=iun
        a.count=a.count+1
        a.irc=0
        a.fehler=' '
        if(ac.eq.'BACKSPACE')then
          if(a.la.gt.0)then
            if(a.isp.eq.1) then
              a.la=0
            else
              a.isp=1
            endif
          endif
          backspace a.lun
          a.count=a.count-1
        endif
        if(ac.eq.'REWIND')then
          a.la=0
          a.isp=1
          rewind a.lun
          a.count=a.count-1
        endif
        return
      endif
      a_=inew1a_(last,lstruct)
      a.fehler=' '
      a.irc=0
      a.la=0
      a.isp=1
      lch=0
      a.canf=' '
      a.cende=' '
      a.a=' '
      a.lun=iun
      if(iun.gt.0)then
        open(iun,file=datei,iostat=ios,form='FORMATTED')
        if (ios.ne.0) then
          a.irc = 1
          a.fehler = 'Dateieröffnung nicht erfolgreich'
        endif
      endif
      a.count=1
      a.datei=datei
      lun=a_
      last=a_
      return
c
c/////////////////////////////////////////
      entry readae(lun,anfang,ende)
c
      a_=lun
      a.canf = anfang
      a.cende = ende
      a.irc = 0
      a.fehler=' '
      a.la = 0
      a.isp = 1
      iun=a.lun
      if (a.canf .ne. ' ') then
  50    if (iun.gt.0) then
          read(iun,form8,end=52,err=51) a.a
        else
          read(*,form8,end=52,err=51) a.a
        endif
        axa=a.a
        if (anfang .ne. axa) goto 50
        return
  51    a.irc = 2
        a.fehler = 'Einlesefehler'
        return
  52    a.irc = 3
        a.fehler = 'Datei-Ende erreicht'
        return
      endif       
      return
c     
c////////////////////////////////////////
      entry rdcode(lun,jrc,fehler)
c
      a_=lun
      jrc = a.irc
      fehler=a.fehler
      return
c
c////////////////////////////////////////
      entry readi2(lun,i2,n)
c
      a_=lun
      mi = 1
      inrd = -1
      goto 1
c
c////////////////////////////////////////
      entry readi4(lun,i4,n)
c
      a_=lun
      mi = 2
      inrd = -1
      goto 1
c
c////////////////////////////////////////
      entry readr4(lun,r4,n)
c
      a_=lun
      mi = 3
      inrd = 0
      goto 1
c
c////////////////////////////////////////
      entry readr8(lun,r8,n)
c
      a_=lun
      mi = 4
      inrd = 0
      goto 1
c
c////////////////////////////////////////
      entry readch(lun,ch,n)
c
      a_=lun
      mi = 5
      inrd = 1
      lch = len(ch(1))
    1 if (a.irc.eq.4) return
      a.fehler = ' '
      a.irc = 0
    2 nn = n
      ird = .false.
    3 ii = 1
    4 iw = 1
      if (ii.gt.nn) then
        goto (5,5,6,6,7),mi
    5   inrd = -1
        goto 8
    6   inrd = 0
        goto 8
    7   inrd = 1
    8   if (ird) goto 32
        return
      endif
c
c neue Zeile einlesen
c
    9 if (a.irc.ne.0) then
        if (ird) goto (30,30,31,31,32),mi
        goto 32
      endif
      if (a.isp.gt.a.la) then
        if (a.lun.gt.0) then
          read(a.lun,form8,end=99,err=11) a.a
        else
          read(*,form8,end=99,err=11) a.a
        endif
        goto 12
  99    a.irc = 3
        a.fehler = 'Datei-Ende erreicht'
        return
  11    a.irc = 2
        a.fehler = 'Einlesefehler'
        return
  12    a.isp = 1
        a.la = 0
        do i=lmax,1,-1
          if (a.a(i:i).ne.leer) then
            a.la = i
            goto 13
          endif
        enddo
        goto 9
   13   axe=a.a
        if (a.cende .ne. ' ' .and. a.cende .eq. axe) then
          a.irc = 4
          a.fehler = 'Daten-Endemarke gelesen'
          a.canf=' '
          a.cende=' '
          return
        endif
        a.isp = 1
      endif
c
c Leerzeichen übergehen
c
      do i=a.isp,a.la
        if (a.a(i:i).ne.leer) goto (16,16,19,19,28),mi
        a.isp = i+1
      enddo
      goto 9
c
c ganze Zahl identifizieren
c
   16 ia = a.isp
      ksp = 0
      vorz = .false.
      if (a.a(ia:ia).eq.'+') then
        ia = ia+1
      else
        if (a.a(ia:ia).eq.'-') then
          vorz = .true.
          ia = ia+1
        endif
      endif
      do i=ia,a.la
        j = ichar(a.a(i:i))
        if (j.lt.inull .or. j.gt.ineun) goto 17
        ksp = ksp+1
        d(ksp:ksp) = a.a(i:i)
      enddo
   17 ia = ia+ksp
      if (ksp.eq.0) then
        a.irc = -4
        a.fehler = 'geforderte Information liegt nicht an'
        goto 9
      endif
c
c Wiederholungsfaktor
c
      if (ia.le.a.la .and. a.a(ia:ia).eq.'*') then
        ia = ia+1
        if (vorz) then
          a.irc = -2
          a.fehler = 'negativer Wiederholungsfaktor'
          goto 32
        endif
        if (ksp.gt.izahl) then
          a.irc = -1
          a.fehler = 'zu viele Ziffern'
          goto 32
        else
          write(form5(3:4),'(i2)') ksp
          read(d(1:ksp),form5) iw
        endif
        if (iw.gt.nn-ii+1) then
          a.irc = -3
          a.fehler = 'Wiederholungsfaktor zu groß'
          goto 32
        else
          a.isp = ia
        endif
        goto 9
      endif
c
c prüfen, ob Leerzeichen vorliegt
c
      if (ia.le.a.la .and. a.a(ia:ia).ne.leer) then
        a.irc = -4
        a.fehler = 'geforderte Information liegt nicht an'
        goto 9
      endif
c
c Einlesen
c
   18 if (ksp.gt.izahl) then
        a.irc = -1
        a.fehler = 'zu viele Ziffern'
        goto 32
      endif
      write(form5(3:4),'(i2)') ksp
      read(d(1:ksp),form5) mm
      a.isp = ia
      if (vorz) mm = -mm
      ie = min(ii+iw-1,nn)
      if (mi.eq.2) then
        do i=ii,ie
          i4(i) = mm
        enddo
      else
        do i=ii,ie
          i2(i) = mm
        enddo
      endif
c
c nächste Zahl
c
      ii = ii+iw
      inrd = -1
      goto 4

c
c reelle Zahl identifizieren
c
   19 ia = a.isp
      msp = 0
      vorz = .false.
      ziff = .false.
      ksp = 0
      ja = ia
      if (a.a(ia:ia).eq.'+'.or.a.a(ia:ia).eq.'-') then
        ksp = ksp+1
        if (a.a(ia:ia).eq.'-') vorz = .true.
        d(1:1) = a.a(ia:ia)
        ja = ja+1
      endif
      ip = .false.
      do i=ja,a.la
        j = ichar(a.a(i:i))
        if (j.lt.inull. or. j.gt.ineun) then
          if (a.a(i:i).eq.'.' .or. a.a(i:i).eq.',') then
            if (ip) then
              a.irc = -4
              a.fehler = 'falsches Zeichen in der Zahl'
              goto 9
            else
              ip = .true.
              a.a(i:i) = '.'
              goto 20
            endif
          else
            ia = i
            goto 22
          endif
        else
          ziff = .true.
        endif
   20   ksp = ksp+1
        if (.not.ip) msp = msp+1
        d(ksp:ksp) = a.a(i:i)
      enddo
      if (ziff) goto 21
      a.irc = -4
      a.fehler = 'falsches Zeichen in der Zahl'
      goto 9
   21 ia = ia+ksp
c
c Wiederholungsfaktor
c
   22 if (ia.le.la .and. a.a(ia:ia).eq.'*') then
        ia = ia+1
        if (vorz.or.ip) then
          a.irc = -2
          a.fehler = 'keinen Wiederholungsfaktor erwartet'
          goto 32
        endif
        if (ksp.gt.izahl) then
          a.irc = -1
          a.fehler = 'zu viele Ziffern'
          goto 32
        else
          write(form5(3:4),'(i2)') ksp
          read(d(1:ksp),form5) iw
        endif
        if (iw.gt.nn-ii+1) then
          a.irc = -3
          a.fehler = 'Wiederholungsfaktor zu groß'
          goto 32
        else
          a.isp = ia
        endif
        goto 9
      endif
c
c prüfen, ob Exponent vorliegt
c
      aa = a.a(ia:ia)
      jsp = 0
      ja = 0
      if(aa.eq.'E'.or.aa.eq.'e'.or.aa.eq.'D'.or.aa.eq.'d')then
        ksp = ksp+1
        d(ksp:ksp) = aa
        ia = ia+1
        if (a.a(ia:ia).eq.'+' .or. a.a(ia:ia).eq.'-') then
          ksp = ksp+1
          d(ksp:ksp) = a.a(ia:ia)
          ia = ia+1
        endif
        ja = ia
        je = min(a.la,ia+2)
        jsp = ksp+1
        do i=ja,je
          j = ichar(a.a(i:i))
          if (j.lt.inull .or. j.gt.ineun) goto 23
          ksp = ksp+1
          d(ksp:ksp) = a.a(i:i)
          ia = ia+1
        enddo
      endif
   23 if (ja.eq.ia) then
        a.irc = -4
        a.fehler = 'Exponenten-Fehler'
        goto 9
      endif
c
c prüfen, ob Leerzeichen vorliegt
c
      if (ia.le.a.la .and. a.a(ia:ia).ne.leer) then
        a.irc = -4
        a.fehler = 'Leerzeichen erwartet'
        goto 9
      endif
c
c Exponent 
c
   24 if (jsp.gt.0) then
        write(form5(3:4),'(i2)') ksp-jsp+1
        read(d(jsp:ksp),form5) mm
        mm = mm+msp
      endif
c
c Einlesen
c
      if (ksp.gt.rzahl) then
        a.irc = -1
        a.fehler = 'zu viele Ziffern'
        goto 32
      endif
      write(form7(3:4),'(i2)') ksp
      read(d(1:ksp),form7) rr
      if (rr.gt.0. .and. vorz) rr = -rr
      a.isp = ia
      ie = min(ii+iw-1,nn)
      goto (27,27,25,26,27),mi
   25 do i=ii,ie
        r4(i) = rr
      enddo
      goto 27
   26 do i=ii,ie
        r8(i) = rr
      enddo
c      
c nächste Zahl
c
   27 ii = ii+iw
      inrd = 0
      goto 4

c
c Einlesen
c
   28 ch(ii) = ' '
      ch(ii)=a.a(a.isp:a.isp+lch-1)
      a.isp=a.isp+lch
      ii = ii+1
      inrd = 1
      goto 4
c
c////////////////////////////////////////
      entry readcl(lun)
c
      a_=lun
      a.count=a.count-1
      if(a.count.eq.0.)then
        if(a.lun.gt.0)close(a.lun)
        lun=a.lun
        a_=ifree1a_(a_)
      endif
      return
c
c///////////////////////////////////////
      entry readxx(lun,i4,r8,ch,jnrd)
c
      a_=lun
      ird = .true.
      nn = 1
      mi = 2
      goto 3
   30 a.irc = 0
      a.fehler=' '
      mi = 4
      goto 3
   31 a.irc = 0
      a.fehler=' '
      lch = len(ch(1))
      mi = 5
      goto 3
c
   32 if (a.irc.eq.0) a.fehler = ' '
      jnrd = inrd
      return 
      end
c
      integer*4 function inread(lun,i4,r8,ch)
      real*8 r8(*)
      integer i4(*),lun
      character*(*) ch(*)
      call readxx(lun,i4,r8,ch,inrd)
      inread = inrd
      return
      end
c
c: $x_fc -c wrtout.f
c*************************************************************************
c*************************************************************************
c
c           Formatfreie Datenausgabe (Fortran, Cray-compatibel)
c           ===================================================
c
c                       (horst.hollatz.de)
c
c
c  Die hier vorgestellte formatfreie Datenausgabe soll die 
c  Anwendung der formatierten Ausgabe nicht ersetzen; 
c  sie soll vielmehr den Datentransfer bei numerischen Algorithmen 
c  erleichtern. Während die Fortran-übliche Datenausgabe mittels Format-
c  Anweisungen das sequentielle Bechreiben eines Ausgabesatzes fördert,
c  wird hier das direkte Beschreiben eines Datensatzes unterstützt.

c  Mit 
c
c        call wrtout(lun,datei,ac)
c
c  wird die formatfreie Datenausgabe initialisiert.
c  
c  lun:   (integer*4) logische Nummer des Ausgabemediums;
c         im Falle einer falschen Zahl wird die Standardausgabe 
c         verwendet. Nach dem Öffnen ist die Variable lun reserviert 
c         und darf nicht verändert werden.
c         Bei jedem Aufruf einer Routine ist lun als erster Parameter
c         anzugeben. 
c  datei: (character*) Name der Ausgabedatei; Standardausgabe = ' ';
c  ac:    (character*) Zugriffsart
c         ac='APPEND': Eine sequentielle Datei wird fortgeschrieben;
c         ac='BACKSPACE': Zurücksetzen um einen Satz;
c         ac='REWIND': Zurücksetzen auf den Dateianfang.
c         sonst: Ohne Wirkung.
c
c  Wiederholtes Öffnen einer unter einer logischen Nummer bereits
c  geöffneten Datei führt zu folgenden Aktionen:
c  - Löschen des Fehlerwertes und des Fehlertextes (siehe wrcode),
c  - Hochzählen eines Öffnungszählers, sofern der Parameter ac keine 
c    Wirkung hatte.
c  Mit 
c        
c       call wrtCC(lun,m,feld,n,is,js,ms)
c
c  werden n Feldelemente des Feldes feld gedruckt. 
c  Die Parameter haben dabei die folgende Bedeutung:
c  (Die angegebene Klammerwerte treten ein, falls der betreffende
c  Parameter einen nichtpositiven Wert hat.)
c
c  m:    Anzahl der Vorschubzeilen; im Falle m=0 wird in die aktuelle,
c        im Falle m=1 in die nächste Zeile gedruckt,
c  CC:   Typ des folgenden Feldes;
c        es sind die Typen ch, i2, i4, r4, r8 zugelassen.
c        Im Falle 'ch' erfolgt alphanumerische Ausgabe,
c  feld: zu druckende Feldelemente,
c  n:    Anzahl der zu druckenden Feldelemente, (n=1)
c  is:   Spaltennummer, ab der das 1. zu druckende Element beginnen 
c        soll,(is=1)
c  js:   Schrittweite zum nächsten Element; (js=ls+2)
c        dabei muß js>ls+1 sein, wobei ls die Anzahl der Druckspalten
c        ist:
c        ch: ls= Länge eines Feldelementes
c        i2: ls= 5
c        i4: ls= 5
c        r4: ls= 9
c        r8: ls= 17
c  ms:   Anzahl der zu druckenden Feldelemente pro Zeile; (ms=n)
c        im Falle ms=0 werden beim Typ ch Endleerzeichen weggelassen.
c
c  Für den Fall, daß nur eine Information auszugeben ist, wählt man
c
c      call wrt1CC(lun,m,feld,is)
c
c  Mit
c      call wrtcl(lun)
c
c  wird der Öffnungszähler für die zugeordnete Datei reduziert;
c  ist er Null, wird die Datei geschlossen.
c     
c  Durch 
c  
c      call wrcode(lun,irc,fehler)
c
c  wird auf irc der letzte Fehlerwert und auf fehler (character*80)
c  ein Fehlertext geliefert.
c  Es gibt die folgenden Fehlerwerte:
c
c   1:  Ausgabedatei konnte nicht geöffnet werden,
c  -1:  Daten passen nicht in den Ausgabesatz 
c       (max. Satzlänge überschritten),
c
c  Längen-Beschränkungen durch änderbare Parameter:
c
c  -  lmax: maximale Satzlänge (256).
c  -  ldatei: maximale Dateinamenslänge (64).
c  -  lsi2: Anzahl der Druckspalten bei integer*2-Zahlen (5).
c  -  lsi4: Anzahl der Druckspalten bei integer*4-Zahlen (5).
c
c  Das Programm wurde unter HP-UX (f77) getestet.
c

      subroutine wrtout(lun,datei,ac)
      parameter (lmax=256,ldatei=64,lfehler=80)
      parameter (lsi2=5,lsi4=5)
      parameter (lstruct=lmax+ldatei+lfehler+24)
      character form8*8,form9*9,formi2*5,formi4*5
      character*(*) datei,ac,ch(*),fehler
      integer*2 i2(*)
      integer*4 i4(*),last/0/
      real*4 r4(*)
      real*8 r8(*),rr
      structure /a/
        integer*4 next,count,lun,irc,la
        Logical isp
        character datei*(ldatei),fehler*(lfehler),a*(lmax)
      endstructure
      record /a/ a
      pointer(a_,a)
      save last,formi2,formi4
c
      if(lun.gt.99)then
        a_=lun
        if(.not.a.isp)goto 30
        lm=1
        assign 30 to mi
       goto 1
      endif
  30  formi2='(i  )'
      write(formi2(3:4),'(i2)') lsi2
      formi4='(i  )'
      write(formi4(3:4),'(i2)') lsi4
      iun=max(lun,0)
      if(iun.eq.0)then
        datei=' '
        ac=' '
      endif
      if(iun.gt.99)then
        a_=iun
        a.count=a.count+1
        a.irc=0
        a.fehler=' '
        if(ac.eq.'BACKSPACE')then
          if(a.isp)then
            a.isp=.false.
            a.a=' '
          else
            backspace a.lun
          endif
          a.count=a.count-1
        else if(ac.eq.'REWIND')then
          a.isp=.false.
          a.a=' '
          rewind a.lun
          a.count=a.count-1
        endif
        return
      endif
      last=inew1a_(last,lstruct)
      a_=last
      a.irc = 0
      a.fehler = ' '
      a.a=' '
      a.isp=.false.
      a.lun=iun
      a.datei=datei
      if (iun.gt.0)then
        ios=0
        if(ac.ne.'APPEND')then
          open(iun,file=datei,iostat=ios)
        else
          open(iun,file=datei,iostat=ios,ACCESS=ac)
        endif
        if (ios.ne.0) then
          a.irc = 1
          print *,datei,': Dateieröffnung nicht erfolgreich'
          last=ifree1a_(last)
          a_=lun
        else
          a.count=1
        endif
      endif
      lun=a_
      return
c
      entry wrtch(lun,m,ch,n,is,js,ms)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 4 to mi
      goto 1
   4  assign 5 to mi
      goto 3
   5  lls = len(ch(1))
      ljs = max(js,lls+2)
  41  nn = ln
      if (lis+lls+ljs*(lms-1).gt.lmax) goto 111
      ia = 1
      ie = lms
   6  if (nn.gt.0) then
        a.isp = .true.
        if (nn.lt.lms) lms = nn
        iis = lis
        do i=ia,ie
          a.a(iis:iis+lls-1) = ch(i)
          iis = iis+ljs
        enddo
        nn = nn-lms
        if (nn.le.0) return
        ia = ia+lms
        if (nn.lt.lms) lms=nn
        ie = ie+lms
        assign 6 to mi
        goto 1
      endif
      return
c
      entry wrt1ch(lun,m,ch,is)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 40 to mi
      goto 1
  40  lis = is
      lls = len(ch(1))
      ljs = lls
      lms = 1
      ln = 1
      goto 41
c
      entry wrtcl(lun)
c
      a_=lun
      if(lun.lt.100)return
      lm = 1
      assign 7 to mi
      goto 1
   7  if(a.lun.gt.0)then
        a.count=a.count-1
        if(a.count.eq.0)then
          close(a.lun)
          last=ifree1a_(a_)
        endif
      endif
      continue
      return
c
      entry wrcode(lun,jrc,fehler)
c
      a_=lun
      if(lun.lt.100)return
      jrc = a.irc
      fehler=a.fehler
      return
c
      entry wrt1i2(lun,m,i2,is)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 80 to mi
      goto 1
  80  ljs = lsi2+2
      lis = is
      lms = 1
      ln = 1
      goto 81
c
      entry wrti2(lun,m,i2,n,is,js,ms)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 8 to mi
      goto 1
   8  assign 9 to mi
      goto 3
   9  ljs =max(js,lsi2+2)
  81  if (lis+lsi2+ljs*(lms-1).gt.lmax) goto 111
      nn = ln
      ia = 1
      ie = lms
  10  if (nn.gt.0) then
        a.isp = .true.
        iis = lis
        do i=ia,ie
          write(a.a(iis:iis+lsi2-1),formi2) i2(i)
          iis = iis+ljs
        enddo
        nn = nn-lms
        if (nn.le.0) return
        ia = ia+lms
        if (nn.lt.lms) lms = nn
        ie = ie+lms
        assign 10 to mi
        goto 1
      endif
      return
c
      entry wrt1i4(lun,m,i4,is)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 110 to mi
      goto 1
 110  ljs = lsi4+2
      lis = is
      lms = 1
      ln = 1
      goto 121
c
      entry wrti4(lun,m,i4,n,is,js,ms)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 11 to mi
      goto 1
   11 assign 12 to mi
      goto 3
   12 ljs = max(js,lsi4+2)
  121 if (lis+lsi4+ljs*(lms-1).gt.lmax) goto 111
      nn = ln
      ia = 1
      ie = lms
   13 if (nn.gt.0) then
        a.isp = .true.
        iis = lis
        do i=ia,ie
          write(a.a(iis:iis+lsi4-1),formi4) i4(i)
          iis = iis+ljs
        enddo
        nn = nn-lms
        if (nn.le.0) return
        ia = ia+lms
        if (nn.lt.lms) lms = nn
        ie = ie+lms
        assign 13 to mi
        goto 1
      endif
      return
c
      entry wrt1r4(lun,m,r4,is)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 140 to mi
      goto 1
 140  ljs = 11
      lis = is
      lms = 1
      ln = 1
      goto 141
c
      entry wrtr4(lun,m,r4,n,is,js,ms)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 14 to mi
      goto 1
   14 assign 15 to mi
      goto 3
   15 ljs = max(js,11)
  141 if (lis+9+ljs*(lms-1).gt.lmax) goto 111
      nn = ln
      ia = 1
      ie = lms
   16 if (nn.gt.0) then
        a.isp = .true.
        iis = lis
        do i=ia,ie
          r = abs(r4(i))
          if (r.lt.1.e0) then
            form8 = '(f9.6)'
          else if (r.lt.1.e1) then
              form8 = '(F9.5)'
          else if (r.lt.1.e2) then
            form8 = '(F9.4)'
          else if (r.lt.1.e3) then
            form8 = '(F9.3)'
          else if (r.lt.1.e4) then
            form8 = '(F9.2)'
          else if (r.lt.1.e5) then
            form8 = '(F9.1)'
          else if (r.lt.1.e6) then
            form8 = '(F9.0)'
          else if (r.ge.1.e6) then
            form8 = '(E9.0)'
          endif
          write(a.a(iis:iis+8),form8) r4(i)
          iis = iis+ljs
        enddo
        nn = nn-lms
        if (nn.le.0) return
        ia = ia+lms
        if (nn.lt.lms) lms = nn
        ie = ie+lms
        assign 16 to mi
        goto 1
      endif
      return
c
      entry wrt1r8(lun,m,r8,is)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 170 to mi
      goto 1
 170  ljs = 19
      lis = is
      lms = 1
      ln = 1
      goto 171
c
      entry wrtr8(lun,m,r8,n,is,js,ms)
c
      a_=lun
      if(lun.lt.100)return
      lm = m
      assign 17 to mi
      goto 1
   17 assign 18 to mi
      goto 3
   18 ljs = max(js,19)
  171 if (lis+17+ljs*(lms-1).gt.lmax) goto 111
      nn = ln
      ia = 1
      ie = lms
   19 if (nn.gt.0) then
        a.isp = .true.
        iis = lis
        do i=ia,ie
          rr = dabs(r8(i))
          if (rr.lt.1.d0) then
            form8 = '(F17.14)'
          else if (rr.lt.1.d1) then
            form8 = '(F17.13)'
          else if (rr.lt.1.d2) then
            form8 = '(F17.12)'
          else if (rr.lt.1.d3) then
            form8 = '(F17.11)'
          else if (rr.lt.1.d4) then
            form8 = '(F17.10)'
          else if (rr.lt.1.d5) then
            form8 = '(F17.9)'
          else if (rr.lt.1.d6) then
            form8 = '(F17.8)'
          else if (rr.lt.1.d7) then
            form8 = '(F17.7)'
          else if (rr.lt.1.d8) then
            form8 = '(F17.6)'
          else if (rr.lt.1.d9) then
            form8 = '(F17.5)'
          else if (rr.lt.1.d10) then
            form8 = '(F17.4)'
          else if (rr.lt.1.d11) then
            form8 = '(F17.3)'
          else if (rr.lt.1.d12) then
            form8 = '(F17.2)'
          else if (rr.lt.1.d13) then
            form8 = '(F17.1)'
          else if (rr.lt.1.d14) then
            form8 = '(F17.0)'
          else if (rr.ge.1.d14) then
            form8 = '(D17.0)'
          endif
          write(a.a(iis:iis+16),form8) r8(i)
          iis = iis+ljs
        enddo
        nn = nn-lms
        if (nn.le.0) return
        ia = ia+lms
        if (nn.lt.lms) lms = nn
        ie = ie+lms
        assign 19 to mi
        goto 1
      endif
      return
c
   1  if (lm .lt.0) lm = 1
      if (lm.gt.0) then
        if (a.isp) then
          a.la = 0
          do i=lmax,1,-1
            if (a.a(i:i).ne.' ') then
              a.la = i
              goto 2 
            endif 
          enddo
   2      if (a.la.gt.0) then
            form9='(     a1)'
            write(form9(2:6),'(i5)') a.la
            if (a.lun.gt.0) then
              write(a.lun,form9) (a.a(i:i),i=1,a.la)
            else
              write(*,form9) (a.a(i:i),i=1,a.la)
            endif
            a.a=' '
            a.isp = .false.
          endif
        endif
        if (a.lun.gt.0) then
          do i=1,lm-1
            write(a.lun,'(1x)')
          enddo
        else
          do i=1,lm-1
            write(*,'(1x)')
          enddo
        endif
      endif
      goto mi
   3  ln = max(n,1)
      lms = ms
      if (lms.le.0 .or. lms.gt.ln) lms = ln
      lis = max(is,1)
      goto mi
c
  111 a.irc = -1
      a.fehler = 'zu viele Daten pro Zeile'
      return
c
      end
c
      integer*4 function inew1a_(ianf,l)
      integer*4 ianf,l,i
      structure /a/
        integer*4 next
      endstructure
      record /a/ a
      pointer(a_,a)
c
      if(ianf.eq.0)then
        a_=malloc(l)
        a.next=a_
      else
        a_=ianf
        i=a.next
        a.next=malloc(l)
        a_=a.next
        a.next=i
      endif
      inew1a_=a_
      return
      end      
      integer*4 function ifree1a_(ianf)
      integer*4 ianf,i
      structure /a/
        integer*4 next
      endstructure
      record /a/ a
      pointer(a_,a)
c
      if(ianf.ne.0)then
        a_=ianf
        i=a.next
        if(a.next.eq.ianf)then
          call free(ianf)
          ifree1a_=0
        else
          do while(a.next.ne.ianf)
            a_=a.next
          enddo
          call free(ianf)
          a.next=i
          ifree1a_=i
        endif
      else
        ifree1a_=0
      endif
      return
      end
