                          PROGRAM INSHELL                               INSH001
C-----------------------------------------------------------------------INSH002
C     This smart program creates an input file for SEXIE                INSH003
C                        (B.Rupp, 1990)                                 INSH004
C                    Generic FORTRAN VERSION                            INSH005
C               (C) Copyright Bernhard Rupp 1990-1995                   INSH006
C-----------------------------------------------------------------------INSH007
C                    Version 3.0 as submitted to CPC                    INSH008
C          Uses the XLIB library (Vienna Air, Inc., Austria, D.E.)      INSH009
C-----------------------------------------------------------------------INSH010
c                                                                       INSH011
c             Version 5.0 - data base format updated                    INSH012
c             atom card (a2,2x,a4,5f8.4,i3)                             INSH013
C             elem(ic),seq(ic),(u(ic,i),i=1,3),foc(i),                  INSH014
c             charge(ic) or bf(ic),icalc(ic)                            INSH015
c             Version 4.2 - add iwater=0 as additional item line 2      INSH016
C             line 2 : format f,f,i,f,f,i                               INSH017
C             Version 4.1 - add query for disoct                        INSH018
C             control parameters include disoct now -                   INSH019
C             line 2 : format f,f,i,f,f                                 INSH020
C             Version 4.0 - add query for charge to atoms               INSH021
C             Format of atom line is now :                              INSH022
C             (a2,2x,a4,4f8.4,i3)                                       INSH023
C             elem(ic),seq(ic),(u(ic,i),i=1,3),charge(ic),icalc(ic)     INSH024
C                                                                       INSH025
C      versions 4.0 and up check for old data bases and request update  INSH026
C-----------------------------------------------------------------------INSH027
                                                                        INSH028
      parameter (iat=20,iidx=3200)                                      INSH029
                                                                        INSH030
      character answ,bra,seq*4,elem*2,infile*25,icomp*4,iver*3          INSH031
      character*8 xyz(3),dbname,nlbl,revdat                             INSH032
      character spcgrp*10,title*60, ans2 ,dbfile*25, idfile*25          INSH033
      character ili*60,junk*60                                          INSH034
      integer idx(iidx), icalc(iat)                                     INSH035
      real u(iat,3),uu(3),vv(3), charge(iat),foc(iat),newver            INSH036
      logical exists,convrt,open                                        INSH037
      dimension seq(iat),elem(iat),ili(5+iat)                           INSH038
                                                                        INSH039
c --- last revision date and computer version --                        INSH040
      revdat='08/21/95'                                                 INSH041
      iver='5.0'                                                        INSH042
      newver=5.0                                                        INSH043
                                                                        INSH044
c --- look for configuration file --                                    INSH045
      inquire (file='SEXIE.CFG',exist=exists)                           INSH046
      if (exists) then                                                  INSH047
         open (4,file='SEXIE.CFG',status='old')                         INSH048
         read(4,'(8x,a)') dbfile                                        INSH049
         read(4,'(8x,a)') idfile                                        INSH050
         read(4,'(8x,f8.4)') ddmax                                      INSH051
         read(4,'(8x,f8.4)') cconv                                      INSH052
         read(4,'(8x,f8.4)') ccona                                      INSH053
         read(4,'(8x,i8)')   iisear                                     INSH054
         read(4,'(8x,i8)')   ipr                                        INSH055
         read(4,'(8x,a4)')   icomp                                      INSH056
         call upstrg (icomp,4)                                          INSH057
         close(4,status='keep')                                         INSH058
      else                                                              INSH059
         print*,' Cannot find configuration file SEXIE.CFG'             INSH060
         print*,' Hit enter to resume with internal default set'        INSH061
         call inkey (answ)                                              INSH062
         dbfile = 'SEXIE.DBF'                                           INSH063
         idfile = 'SEXIE.IDX'                                           INSH064
         ddmax  = 10.0                                                  INSH065
         cconv  = 0.01                                                  INSH066
         ccona  = 0.5                                                   INSH067
         iisear = 1                                                     INSH068
         ipr    = 6                                                     INSH069
         ddisoc = 6.0                                                   INSH070
         icomp  = '7BIT'                                                INSH071
      end if                                                            INSH072
      ddisoc = 6.0                                                      INSH073
                                                                        INSH074
 8001 call clrscr (icomp)                                               INSH075
c --- call routine for header insert ---                                INSH076
      call inhead (revdat,icomp,iver)                                   INSH077
      call nulify (spcgrp,seq,elem,dbname,title,ili,u)                  INSH078
      do 6999 i=1,iat                                                   INSH079
         icalc(i)=0                                                     INSH080
 6999 continue                                                          INSH081
                                                                        INSH082
c --- check for right version of SEXIE database ---                     INSH083
      open(unit=4,file=dbfile, form='formatted', recl=60,               INSH084
     & access='direct', status='old',err=6003)                          INSH085
c --- read the first line extra to find version of database ---         INSH086
      read(4,'(a)') junk                                                INSH087
      read(junk,'(9x,f3.1)',err=6003) versio                            INSH088
      goto 6004                                                         INSH089
 6003 versio=1.0                                                        INSH090
 6004 if (versio.ne.newver) then                                        INSH091
        write(ipr,'(/a,f3.1,a,f3.1)') '  Old database version ',versio, INSH092
     &                         ' - MUST be updated to version ',newver  INSH093
        ifix=1                                                          INSH094
        write(ipr,*)' You MUST run MAKEDB first before you can continue'INSH095
      else                                                              INSH096
        write(ipr,'(a,f3.1)') '  Database is current version ', versio  INSH097
        ifix=0                                                          INSH098
      end if                                                            INSH099
      close(4,status='keep')                                            INSH100
                                                                        INSH101
c --- data base or interactive --                                       INSH102
 7000 write(ipr,'(/a)')'  Search (D)ata base      (D)'                  INSH103
      write(ipr,'( a)')'  Create a new (I)nput    (I)'                  INSH104
      write(ipr,'( a)')'  E(x)it to System        (X)'                  INSH105
      write(ipr,'(/a$)')'  Your choice > '                              INSH106
c --- terminate if database is old --                                   INSH107
      if (ifix.eq.1) then                                               INSH108
         write (ipr,'(/a/)')'  Have a nice day. See you again. '        INSH109
         goto 9999                                                      INSH110
      end if                                                            INSH111
      call inkey (answ)                                                 INSH112
      ierr=0                                                            INSH113
      ilabel=0                                                          INSH114
      index=0                                                           INSH115
      idata=0                                                           INSH116
      ifirst=0                                                          INSH117
      if (answ.eq.'D') then                                             INSH118
         call dbase (ili,ierr,index,iol,dbfile,idfile,idx,ndx,icomp)    INSH119
         if(ierr.eq.1) goto 7000                                        INSH120
         if(ierr.eq.9) then                                             INSH121
           close(4)                                                     INSH122
           goto 8001                                                    INSH123
         end if                                                         INSH124
         ilabel=1                                                       INSH125
         idata=1                                                        INSH126
         ifirst=1                                                       INSH127
         goto 2000                                                      INSH128
      elseif (answ.eq.'I') then                                         INSH129
         goto 1111                                                      INSH130
      elseif (answ.eq.'X') then                                         INSH131
         write (ipr,'(/a/)')'  Have a nice day. See you again. '        INSH132
         goto 9999                                                      INSH133
      else                                                              INSH134
         write(ipr,'(2x,a1,a)') answ,' ??'                              INSH135
         goto 7000                                                      INSH136
      end if                                                            INSH137
                                                                        INSH138
c --- get title - ENTRY point after satisfied with input --             INSH139
1111  if (ilabel.eq.1) then                                             INSH140
         read(ili(2),'(a60)') title                                     INSH141
      else                                                              INSH142
         call clrscr (icomp)                                            INSH143
         call intert (ipr,icomp)                                        INSH144
         write (ipr,'(/a)')'  Please enter a title for this input (eg., INSH145
     &Nickel Metal fcc) :'                                              INSH146
         write(ipr,'(a$)') '  > '                                       INSH147
         read(*,'(a60)') title                                          INSH148
      end if                                                            INSH149
                                                                        INSH150
c --- control parameters - default -                                    INSH151
      if (1.eq.1) then                                                  INSH152
         call clrscr (icomp)                                            INSH153
         call ctrtit (ipr,icomp)                                        INSH154
 1112   write(ipr,'(/a,i2,a,f6.4,a)')                                   INSH155
     &  '  (Y) Use default values : shells to ',                        INSH156
     &  int(ddmax),' A, shell width ', cconv,' A'                       INSH157
      write(ipr,'(a)')'  (I) Enter individual control parameters'       INSH158
      write(ipr,'(a)')'  (S) Space group decoding only (no shells calc)'INSH159
      write(ipr,'(/a$)')'  Your choice > '                              INSH160
         call inkey (ans2)                                              INSH161
c ---    valid answer --                                                INSH162
         if (ans2.ne.'Y'.and.ans2.ne.'I'.and.ans2.ne.'S') then          INSH163
            write(ipr,*)' Ehh ??'                                       INSH164
            goto 1112                                                   INSH165
         end if                                                         INSH166
         if (ans2.eq.'Y') then                                          INSH167
            dmax=ddmax                                                  INSH168
            cona=ccona                                                  INSH169
            conv=cconv                                                  INSH170
            isearc=iisear                                               INSH171
            disoct=6.0                                                  INSH172
            iwater=0                                                    INSH173
         elseif (ans2.eq.'S') then                                      INSH174
            dmax=0.0                                                    INSH175
            cona=0.0                                                    INSH176
            conv=0.0                                                    INSH177
            isearc=0                                                    INSH178
            disoct=0.0                                                  INSH179
            iwater=0                                                    INSH180
         else                                                           INSH181
            call clrscr (icomp)                                         INSH182
            call getctr (dmax,cona,conv,isearc,disoct,iwater)           INSH183
         end if                                                         INSH184
      end if                                                            INSH185
      write (ili(3),'(f6.2,f8.3,i4,2f8.3,i4)')                          INSH186
     &                     dmax,conv,isearc,cona,disoct,iwater          INSH187
                                                                        INSH188
c --- read spacegroup symbol --                                         INSH189
      if (ilabel.eq.1) then                                             INSH190
         read (ili(5),'(a10,1x,i3)') spcgrp,ispa                        INSH191
      else                                                              INSH192
         call clrscr (icomp)                                            INSH193
         call spctit (ipr,icomp)                                        INSH194
         call space (bra,nsy,spcgrp,ispa,icomp)                         INSH195
c ---    if a rhombohedral spacegroup were detected, we ask if convert -INSH196
         if (bra.eq.'R') then                                           INSH197
            call clrscr (icomp)                                         INSH198
            call rhotit (ipr,spcgrp,icomp)                              INSH199
            write(ipr,'(/a$)')'  Do you intend to use the rhombohedral sINSH200
     &etting of this space group (Y/N) : '                              INSH201
            call inkey (answ)                                           INSH202
            convrt=.false.                                              INSH203
            if (answ.eq.'Y') convrt=.true.                              INSH204
         end if                                                         INSH205
      end if                                                            INSH206
                                                                        INSH207
c --- now the crystal data are sufficient to inquire cell constants -   INSH208
      if (ilabel.eq.1) then                                             INSH209
         read(ili(4),'(6(f9.4))') alatta,alattb,alattc,alpha,beta,gamma INSH210
      else                                                              INSH211
         call clrscr (icomp)                                            INSH212
         call celinp (nsy,alatta,alattb,alattc,alpha,beta,gamma,convrt, INSH213
     &   ispa)                                                          INSH214
      end if                                                            INSH215
                                                                        INSH216
c --- assemble first part of input data if not from database --         INSH217
      if (ilabel.lt.1) then                                             INSH218
         write (ili(2),'(a60)') title                                   INSH219
         write (ili(3),'(f6.2,f8.3,i4,2f8.3,i4)') dmax,conv,isearc,cona,INSH220
     &         disoct,iwater                                            INSH221
         write(ili(4),'(6(f9.4))') alatta,alattb,alattc,alpha,beta,gammaINSH222
         write (ili(5),'(a10,1x,i3)') spcgrp,ispa                       INSH223
      end if                                                            INSH224
                                                                        INSH225
c --- read atom lines from database or start to inquire atom lines --   INSH226
      if (ilabel.eq.1) then                                             INSH227
         do 0003 ic=1,iol-5                                             INSH228
            read (ili(5+ic),'(a2,2x,a4,5f8.4)')                         INSH229
     &      elem(ic),seq(ic),(u(ic,i),i=1,3),foc(ic),charge(ic)         INSH230
 0003    continue                                                       INSH231
         ic=ic-1                                                        INSH232
      else                                                              INSH233
         call clrscr (icomp)                                            INSH234
         call atotit (ipr,icomp)                                        INSH235
         write(*,'(/a$)')'  Ready (Y/N) ? '                             INSH236
         call inkey(answ)                                               INSH237
         if (answ.eq.'N') then                                          INSH238
            print*,' '                                                  INSH239
            print*,' Maybe a cup of tea ??'                             INSH240
            call inkey (answ)                                           INSH241
         end if                                                         INSH242
                                                                        INSH243
c ---    here we loop over ic ATOM cards --                             INSH244
         ic=0                                                           INSH245
 0001    ic=ic+1                                                        INSH246
         call clrscr (icomp)                                            INSH247
         write(*,'(/a,i2,a)')' Atom number ',ic,':'                     INSH248
                                                                        INSH249
c ---    get the element symbol --                                      INSH250
 7006    write(*,'(/a$)')' Element symbol : '                           INSH251
         read (*,'(a2)') elem(ic)                                       INSH252
         call upstrg (elem(ic),2)                                       INSH253
c --     check, if symbol is ok --                                      INSH254
         iatom=ielect(elem(ic))                                         INSH255
         if (iatom.eq.0) then                                           INSH256
            write (ipr,'(a,a)')' Unable to interpret element symbol ',  INSH257
     &                           elem(ic)                               INSH258
            goto 7006                                                   INSH259
         end if                                                         INSH260
                                                                        INSH261
c ---    get mandatory label -                                          INSH262
 2812    write(*,'(/a$)')' Enter a unique atom label (up to four charactINSH263
     &ers, site from Tables) : '                                        INSH264
         read (*,'(a4)') seq(ic)                                        INSH265
         if ((seq(ic).eq.char(13)).or.(seq(ic).eq.' ')) goto 2812       INSH266
c ---    get atom coordinates ---                                       INSH267
         do 0721, i=1,3                                                 INSH268
 0721       call xyzko (i,xyz(i))                                       INSH269
                                                                        INSH270
c ---    check coordinate string & transform fractionals to rationals  -INSH271
         do 722 i=1,3                                                   INSH272
            call dslash (xyz(i),u(ic,i),ierr)                           INSH273
            if (ierr.eq.1) then                                         INSH274
               print*,' To repeat input of this card hit <cr>'          INSH275
               call inkey (answ)                                        INSH276
               ic=ic-1                                                  INSH277
               goto 0001                                                INSH278
            end if                                                      INSH279
 0722    continue                                                       INSH280
         write(ipr,'(/a,3(1x,f8.5))')'  Atom parameters are ok :'       INSH281
     &   ,(u(ic,i),i=1,3)                                               INSH282
                                                                        INSH283
c ---    transform, if rhombohedral --                                  INSH284
         if (bra.eq.'R'.and.convrt) then                                INSH285
            do 4001 j=1,3                                               INSH286
 4001          uu(j)=u(ic,j)                                            INSH287
            call potran (uu,vv,ierr)                                    INSH288
            if (ierr.eq.1) then                                         INSH289
               write(*,'(/a,a,3(1x,f8.5))')'  Error transforming atomic'INSH290
     &         , ' positions - ',(vv(i), i=1,3)                         INSH291
               print*,' To repeat input of this card hit <cr>'          INSH292
               call inkey (answ)                                        INSH293
               ic=ic-1                                                  INSH294
               goto 0001                                                INSH295
            else                                                        INSH296
               write(*,'(/a,3(1x,f8.5))')'  Transformed parameters :',  INSH297
     &         (vv(i),i=1,3)                                            INSH298
               do 0744 i=1,3                                            INSH299
                  call mslash (vv(i),xyz(i),ierr)                       INSH300
                  u(ic,i)=vv(i)                                         INSH301
 0744          continue                                                 INSH302
               write (*,'(a,3(1x,a8))') '  Fractional coordinates : ',  INSH303
     &         (xyz(i),i=1,3)                                           INSH304
            end if                                                      INSH305
         end if                                                         INSH306
                                                                        INSH307
c ---    inquire occupancy of atom - new in version 5.0                 INSH308
         write (*,'(a,a2,a,a4,a$)')'  Full occupancy (focc=1) for atom 'INSH309
     &   ,elem(ic),' ',seq(ic),' (Y/N) : '                              INSH310
         call inkey(answ)                                               INSH311
         if (answ.eq.'Y') then                                          INSH312
            foc(ic)=1.0                                                 INSH313
            write(*,'(a,f4.2)') '  Occupancy factor set to ',foc(i)     INSH314
         else                                                           INSH315
 4443       write (*,'(a,a2,a,a4,a$)')'  Occupancy factor for atom ',   INSH316
     &      elem(ic),' ',seq(ic),' (between 1.0 and 0.0) : '            INSH317
            read(*,*,err=4443) foc(ic)                                  INSH318
         end if                                                         INSH319
                                                                        INSH320
                                                                        INSH321
c ---    inquire optional charge of atom - new in version 4.0           INSH322
         write (*,'(a,a2,a,a4,a$)')'  Optional charge for atom ',       INSH323
     &   elem(ic),' ',seq(ic),' desired (N/Y, enter=no) : '             INSH324
         read(*,'(a1)') answ                                            INSH325
         call upstrg(answ,1)                                            INSH326
         if (answ.eq.'Y') then                                          INSH327
 4343       write (*,'(a,a2,a,a4,a$)')'  Formal charge for atom ',      INSH328
     &      elem(ic),' ',seq(ic),' (charge units, i.e. +2, -1.0) : '    INSH329
            read(*,*,err=4343) charge(ic)                               INSH330
         else                                                           INSH331
            charge(ic)=0.0                                              INSH332
         end if                                                         INSH333
                                                                        INSH334
c ---    ask if atom should be used as a central atom for shell calc    INSH335
         write (*,'(a,a,a2,a,a4,a$)')'  Calculate coordination',        INSH336
     &   ' shell around atom ',elem(ic),' ',seq(ic),' (Y/N) : '         INSH337
         call inkey (answ)                                              INSH338
         if (answ.eq.'Y') icalc(ic)=1                                   INSH339
                                                                        INSH340
c ---    we write each atom card now - with exception of icalc(ic)      INSH341
         write(ili(5+ic),'(a2,2x,a4,5f8.4)')                            INSH342
     &   elem(ic),seq(ic),(u(ic,i),i=1,3),foc(ic),charge(ic)            INSH343
                                                                        INSH344
c ---    another atom card ? --                                         INSH345
         write(*,'(/a$)')'  Does the unit cell contain another non equivINSH346
     &alent atom (Y/N) ? '                                              INSH347
         call inkey (answ)                                              INSH348
         if (answ.eq.'Y') goto 0001                                     INSH349
      end if                                                            INSH350
                                                                        INSH351
c --- if not new input, ask for charge and icalc only --                INSH352
      if (ilabel.eq.1) then                                             INSH353
         call clrscr (icomp)                                            INSH354
         write(*,*)' '                                                  INSH355
         do 1003 ic=1,iol-5                                             INSH356
c ---      new in version 5.0 - inquire if charge is ok :               INSH357
           read(ili(5+ic),'(40x,f8.4)') charge(ic)                      INSH358
           write (*,'(a,a2,a,a4,a,f5.2,a$)')'  Formal charge for atom ',INSH359
     &      elem(ic),' ',seq(ic),' ok (',charge(ic),') (Y/N) : '        INSH360
            call inkey(answ)                                            INSH361
            if (answ.ne.'Y') then                                       INSH362
 4344           write (*,'(a,a2,a,a4,a$)')'  Formal charge for atom ',  INSH363
     &          elem(ic),' ',seq(ic),' (charge units, i.e. +2, -1.0) : 'INSH364
                read(*,*,err=4344) charge(ic)                           INSH365
                write(ili(5+ic),'(a2,2x,a4,5f8.4)')                     INSH366
     &          elem(ic),seq(ic),(u(ic,i),i=1,3),foc(i),charge(ic)      INSH367
            end if                                                      INSH368
            write (*,'(a,a,a2,a,a4,a$)')'  Calculate coordination',     INSH369
     &      ' shell around atom ',elem(ic),' ',seq(ic),' (Y/N) : '      INSH370
            call inkey (answ)                                           INSH371
            if (answ.eq.'Y') icalc(ic)=1                                INSH372
 1003    continue                                                       INSH373
         ic=ic-1                                                        INSH374
         ilabel=0                                                       INSH375
      end if                                                            INSH376
                                                                        INSH377
c --- entry point for input listing --                                  INSH378
      iol=ic+5                                                          INSH379
 2000 call clrscr (icomp)                                               INSH380
      write(ipr,'(a/a)')'  Your input data : ',' Line#'                 INSH381
      if (ifirst.eq.0) then                                             INSH382
         do 0002 i=2,iol                                                INSH383
            if (i.lt.6) then                                            INSH384
               write (*,'(1x,i2,1x,a)') i-1,ili(i)                      INSH385
            else                                                        INSH386
c ---          changed from a32 to a48 in version 5.0                   INSH387
               write (*,'(1x,i2,1x,a48,i3)') i-1,ili(i),icalc(i-5)      INSH388
            end if                                                      INSH389
            if (mod(i,20).eq.0) then                                    INSH390
               print*,' Hit <cr> to continue'                           INSH391
               call inkey (answ)                                        INSH392
            end if                                                      INSH393
 0002    continue                                                       INSH394
         write (*,'(a)')'  atom site     x       y       z     occup   cINSH395
     &harge  icalc'                                                     INSH396
         write (*,'(/a$)')'  Satisfied with input data (Y/N) : '        INSH397
      else                                                              INSH398
c --- omit control parameters upon first listing from data base ----    INSH399
         do 0202 i=2,iol                                                INSH400
            if (i.eq.3) then                                            INSH401
               write (*,'(a)') '  2 Control parameters not yet defined' INSH402
            elseif (i.lt.6) then                                        INSH403
               write (*,'(1x,i2,1x,a)') i-1,ili(i)                      INSH404
            else                                                        INSH405
               write (*,'(1x,i2,1x,a48)') i-1,ili(i)                    INSH406
            end if                                                      INSH407
            if (mod(i,20).eq.0) then                                    INSH408
               print*,' Hit <cr> to continue'                           INSH409
               call inkey (answ)                                        INSH410
            end if                                                      INSH411
 0202    continue                                                       INSH412
         write (*,'(a)')'  atom site     x       y       z     occup   cINSH413
     &harge '                                                           INSH414
         write (*,'(/a$)')'  Satisfied with structure data (Y/N) : '    INSH415
      end if                                                            INSH416
      ifirst=0                                                          INSH417
      call inkey (answ)                                                 INSH418
c --- not ok block --                                                   INSH419
      if (answ.ne.'Y') then                                             INSH420
c ---    entry point for parser --                                      INSH421
 7700    write(ipr,'(/a)') '  Scrap this data and restart   (S)'        INSH422
         write(ipr,'( a)') '  or edit this input data       (E)'        INSH423
         write(ipr,'(a$)') '  Your choice > '                           INSH424
                                                                        INSH425
         call inkey (ans2)                                              INSH426
c ---    valid answer --                                                INSH427
         if (ans2.ne.'S'.and.ans2.ne.'E')   then                        INSH428
            write(ipr,*)' Huh ??'                                       INSH429
            goto 7700                                                   INSH430
         elseif (ans2.eq.'S') then                                      INSH431
            write(ipr,'(a$)') '  Are you sure (Y/N) : '                 INSH432
            call inkey (ans2)                                           INSH433
            if (ans2.ne.'Y') then                                       INSH434
               goto 2000                                                INSH435
            else                                                        INSH436
              inquire(file=dbfile,exist=exists,opened=open)             INSH437
              if (open) close (1,status='keep')                         INSH438
              inquire(file=idfile,exist=exists,opened=open)             INSH439
              if (open) close (2,status='keep')                         INSH440
              goto 8001                                                 INSH441
            end if                                                      INSH442
         else                                                           INSH443
            ichang=0                                                    INSH444
            iolold=iol                                                  INSH445
            call edit (ili,iol)                                         INSH446
            if(iolold.ne.iol) ichang=1                                  INSH447
            goto 2000                                                   INSH448
         end if                                                         INSH449
c --- input ok block ---                                                INSH450
      else                                                              INSH451
c ---    get the data from database if first run --                     INSH452
         if (ilabel.eq.1) goto 1111                                     INSH453
 7770    write(ipr,'(/a)')'  Save input into individual input file (I)' INSH454
         write(ipr,'( a)')'  Append input to current data base     (A)' INSH455
         write(ipr,'( a)')'  Start calculation             <cr> or (Y)' INSH456
         write(ipr,'(a$)')'  Your choice > '                            INSH457
         call inkey (ans2)                                              INSH458
c ---    write external sequential file ---                             INSH459
         if (ans2.eq.'I') then                                          INSH460
 9003       write(ipr,'(a)')'  Name for the output file (do not enter thINSH461
     &e default extension .INP)'                                        INSH462
            call filnam (infile,'.INP',1)                               INSH463
            open (unit=4,file=infile,err=9901,status='unknown')         INSH464
            goto 9902                                                   INSH465
 9901       print*,' Cannot open file ',infile                          INSH466
            goto 9003                                                   INSH467
 9902       continue                                                    INSH468
            write(ipr,*)' Writing input file ',infile                   INSH469
            do 5009 i=2,iol                                             INSH470
               if (i.lt.6) then                                         INSH471
                  write (4,'(a)') ili(i)                                INSH472
               else                                                     INSH473
c ---             changed to a40 in version 4.0                         INSH474
                  write (4,'(a40,i3)') ili(i),icalc(i-5)                INSH475
               end if                                                   INSH476
 5009       continue                                                    INSH477
            close (unit=4, status='keep')                               INSH478
                                                                        INSH479
c ---    append to data base ---                                        INSH480
         elseif (ans2.eq.'A') then                                      INSH481
c ---       check whether databases open and ok --                      INSH482
            inquire(file=dbfile,exist=exists,opened=open)               INSH483
            if (.not.exists) then                                       INSH484
               print*,' Can''t find the data base file ',dbfile,'in thisINSH485
     & directory'                                                       INSH486
               print*,' Please select another option'                   INSH487
               goto 7700                                                INSH488
            end if                                                      INSH489
            if (.not.open) then                                         INSH490
               open(unit=1,file=dbfile, form='formatted', recl=60,      INSH491
     &         access='direct', status='old')                           INSH492
            end if                                                      INSH493
 22         format (a60)                                                INSH494
 23         format (i6)                                                 INSH495
            inquire(file=idfile,exist=exists,opened=open)               INSH496
            if (.not.exists) then                                       INSH497
               print*,' Can''t find the index file ',idfile,    'in thisINSH498
     & directory'                                                       INSH499
               print*,' Please select another option'                   INSH500
               goto 7700                                                INSH501
            end if                                                      INSH502
c ---       read the index file, if not yet opened ---                  INSH503
            if (.not.open) then                                         INSH504
               open(unit=2,file=idfile, form='formatted', recl=6,       INSH505
     &         access='direct', status='old')                           INSH506
               do 2200 i=1,iidx                                         INSH507
                  read(2,23,rec=i,err=2209) idx(i)                      INSH508
 2200          continue                                                 INSH509
 2209          ndx=i-1                                                  INSH510
            end if                                                      INSH511
                                                                        INSH512
c ---       if not read from data base, inquire the a label             INSH513
            if (idata.ne.1) then                                        INSH514
               write(ipr,'(/a)') '  We need a label for this entry. The INSH515
     &compound name or any descriptive name '                           INSH516
               write(ipr,'(a)') '  up to 8 characters is acceptable (e.gINSH517
     &. LAF3, NIFCC, TI)'                                               INSH518
 7771          write(ipr,'(a$)')'  Enter the label for this entry : '   INSH519
               read(*,'(a)') dbname                                     INSH520
               call upstrg (dbname,8)                                   INSH521
c ---          need a label --                                          INSH522
               if (dbname.eq.' ') then                                  INSH523
                  goto 7771                                             INSH524
               endif                                                    INSH525
c ---          check, if exists ---                                     INSH526
               print*,' Checking for duplicate entry label.......'      INSH527
               ierr=0                                                   INSH528
               do 2600 i=1,ndx                                          INSH529
                  irec=abs(idx(i))                                      INSH530
                  read(1,'(2x,a8)',rec=irec,err=2600) nlbl              INSH531
                  if ((nlbl.eq.dbname).and.(idx(i).gt.0)) ierr=1        INSH532
 2600          continue                                                 INSH533
               if (ierr.gt.0) then                                      INSH534
                  print*, ' This label exists already - select another nINSH535
     &ame'                                                              INSH536
                  goto 7771                                             INSH537
               else                                                     INSH538
                  print*,' Label ok - appending new entry ',dbname      INSH539
                  write(ili(1),'(a2,a8,a2,67x)')'**',dbname,'**'        INSH540
               end if                                                   INSH541
c ---          find the end of the data base --                         INSH542
               do 2400 i=abs(idx(ndx)),abs(idx(ndx))+10+iat             INSH543
 2400              read(1,22,rec=i,err=2409) junk                       INSH544
 2409          continue                                                 INSH545
               nrec=i                                                   INSH546
c ---          write a new last index entry and append                  INSH547
               ndx=ndx+1                                                INSH548
               idx(ndx)=nrec                                            INSH549
               write(2,23,rec=ndx) idx(ndx)                             INSH550
               ibuf=0                                                   INSH551
               do 2410 i=nrec,nrec+iol-1                                INSH552
                  ibuf=ibuf+1                                           INSH553
 2410             write(1,22,rec=i) ili(ibuf)                           INSH554
c ---          done with that task --                                   INSH555
               goto 9990                                                INSH556
            end if                                                      INSH557
c ---       simple replace ---                                          INSH558
            if (ichang.eq.0) then                                       INSH559
               write(ipr,'(a)')'  Updating entry ......'                INSH560
               ibuf=0                                                   INSH561
               do 2300 i=idx(index),idx(index)+iol-1                    INSH562
                  ibuf=ibuf+1                                           INSH563
                  write(1,22,rec=i) ili(ibuf)                           INSH564
 2300          continue                                                 INSH565
            else                                                        INSH566
c ---       delete index, make new index, write records --              INSH567
c              find end of database                                     INSH568
c              print*,'index,ndx,idx(ndx)',index,ndx,idx(ndx)           INSH569
               do 2701 i=idx(ndx),idx(ndx)+5+iat                        INSH570
                  read(1,22,rec=i,err=2791) junk                        INSH571
 2701          continue                                                 INSH572
 2791          nrec=i                                                   INSH573
               write(ipr,'(a)')'  Appending entry ......'               INSH574
               idx(index)=-idx(index)                                   INSH575
               ndx=ndx+1                                                INSH576
               idx(ndx)=nrec                                            INSH577
               ibuf=0                                                   INSH578
               write(2,23,rec=ndx) idx(ndx)                             INSH579
               write(2,23,rec=index) idx(index)                         INSH580
               do 2330 i=idx(ndx),idx(ndx)+iol-1                        INSH581
                  ibuf=ibuf+1                                           INSH582
                  write(1,22,rec=i) ili(ibuf)                           INSH583
 2330          continue                                                 INSH584
            end if                                                      INSH585
         elseif (ans2.eq.'Y') then                                      INSH586
            answ=ans2                                                   INSH587
            goto 9912                                                   INSH588
         else                                                           INSH589
c ---       invalid answer --                                           INSH590
            write(ipr,*)' Say again, please ??'                         INSH591
            goto 7770                                                   INSH592
         end if                                                         INSH593
c ---    end of append block --                                         INSH594
      end if                                                            INSH595
c --- end of input ok block --                                          INSH596
                                                                        INSH597
c --- start calculation with current dataset ---                        INSH598
 9990 continue                                                          INSH599
 7009 write(ipr,'(/a )') '  Create another input                   (I)' INSH600
      write(ipr,'( a )') '  or start calculation with current data (Y)' INSH601
      write(ipr,'( a$)') '  Your choice > '                             INSH602
      call inkey (answ)                                                 INSH603
 9912 if (answ.eq.'I') then                                             INSH604
         inquire(file=dbfile,exist=exists,opened=open)                  INSH605
         if (open) close (1,status='keep')                              INSH606
         inquire(file=idfile,exist=exists,opened=open)                  INSH607
         if (open) close (2,status='keep')                              INSH608
         goto 8001                                                      INSH609
      elseif (answ.eq.'Y') then                                         INSH610
         open(4,file='sexie.inp',status='unknown')                      INSH611
         do 9911 i=2,iol                                                INSH612
            if (i.lt.6) then                                            INSH613
               write (4,'(a)') ili(i)                                   INSH614
            else                                                        INSH615
c ---          changed to a48 in version 5.0                            INSH616
               write (4,'(a48,i3)') ili(i),icalc(i-5)                   INSH617
            end if                                                      INSH618
 9911    continue                                                       INSH619
         close(4,status='keep')                                         INSH620
      else                                                              INSH621
         write(ipr,'(a)')'  Sorry ??'                                   INSH622
         goto 9990                                                      INSH623
      end if                                                            INSH624
c --- say good bye ---                                                  INSH625
      write(*,*) ' '                                                    INSH626
      write (*,'(/a/)')'  So long and good luck for your calculation'   INSH627
      if (icomp.eq.'IBM ') then                                         INSH628
         stop 9                                                         INSH629
c --- uncomment if using a VAX under VMS                                INSH630
c      elseif (icomp.eq.'VAX ') then                                    INSH631
c         call exit (3)                                                 INSH632
      else                                                              INSH633
         stop 9                                                         INSH634
      end if                                                            INSH635
                                                                        INSH636
 9999 end                                                               INSH637
