PROGRAM SCALE
C
C***********************************************************************
C                                                                      *  
C     Program to scale the co-ordinates by factors fx fy <fz>          *
C     and write out a ABAQUS Input file.                               *
C                                                                      * 
C***********************************************************************
C
c........1.........2.........3.........4.........5.........6.........7..
      LOGICAL LNODE,LINST,LSHEL
      character*1 inf(150),abain*25,abaout*35,c6*6,ans,infn*150
      EQUIVALENCE (INF,INFN)
C
      ninf=150
      IR5=5
      IR7=7
      IW8=8
      IW9=9
      lino=0
      abain='                         '
       KPREV=0
    4  print *,'Enter a ABAQUS Input file name (incl .inp)=>'
      read(ir5,'(a25)',err= 5)abain
C
      goto 6
    5 continue
C------------Error reading file name
      print*,'*** Error in Reading File Name. RE-enter ,'
      goto 4 
C
    6 continue
C
      do 7 ib=25,1,-1
      if(abain(ib:ib).ne.' ') goto 8
    7 continue
      ib=25
C      goto 9
    8 continue
C    9 continue
      kl=ib
      kln=kl+3
      abaout=abain(1:kl-4)//'new.inp'
      open(7,file=abain(1:kl))
      open(8,file=abaout(1:kln))
      open(9,file='aba.dbg')
      I2D=0
C
   10 continue
      lino=lino+1
      read(ir7,'(150a1)',end=800,err=700)(inf(kk),kk=1,ninf)
c
      call last(iw9,inf,il)
C----------Key word line or a comment line        
      if(inf(1).eq.'*') then
c
         if(inf(2).eq.'*') then
c--------------------comment line
            write(iw8,900)(inf(jk),jk=1,il)
         else
c           call last(iw9,inf,il)
            CALL KEYWD(iw9,C6,INF)                    
            call match(c6,icode,il)
c
            write(iw9,890)il,icode
 890        format(1x,'... il, icode ',2i6)
            if(icode.eq.1) then
               LNODE=.TRUE.
               LINST=.FALSE.
               LSHEL=.FALSE.
               write(iw8,900)(inf(jk),jk=1,il)
            else if(icode.eq.3) then 
               LNODE=.FALSE.
               LINST=.TRUE.
               LSHEL=.FALSE.
               write(iw8,900)(inf(jk),jk=1,il)
            else if(icode.eq.4) then
               LNODE=.FALSE.
               LINST=.FALSE.
               LSHEL=.TRUE.
               write(iw8,900)(inf(jk),jk=1,il)
            else
               LNODE=.FALSE.
               LINST=.FALSE.
               LSHEL=.FALSE.
               write(iw8,900)(inf(jk),jk=1,il)
            endif
         endif
      else 
         if(LNODE) then
c            print*,'reading data file. line no.= ',lino
c---------------------node statement found          
            if(i2d.eq.0) call findim(ir5,iw9,inf,i2d,ninf,xf,yf,zf)
c
            lstc=0 
            icmt=0
            do 25 i=1,ninf
            if(inf(i).eq.',') then
                 icmt=icmt+1
                 inf(i)=' '
            else if(lstc.eq.0) then
                 ib=ninf+1-i
                 if(inf(ib).ne.' ') then
                 lstc=ib
c                 print*,'lstc :',lstc
                endif
           endif 
  25        continue
c
c            print*,'lino icmt i2d lstc :',lino,icmt,i2d,lstc
            if(icmt.lt.i2d) then
                    inf(lstc+1)=' '
                    inf(lstc+2)=' '
                    inf(lstc+3)='0'
c                    infn(lstc+1:lstc+3)='  0'
c                    print*,'infn :',infn
            endif
            write(iw9,900)(inf(jk),jk=1,il)        
            if(i2d.eq.2) then
               read(infn,*,err=700,end=800)nodeno,x,y
               xn=x*xf
               yn=y*yf
               KPREV=1
               write(iw8,920)nodeno,xn,yn
c            else if(LNODE) then
             else
               read(infn,*,err=700,end=800)nodeno,x,y,z
               xn=x*xf
               yn=y*yf
               zn=z*zf
               KPREV=1
               write(iw8,930)nodeno,xn,yn,zn
             endif     
c---------------end of i2d=2 test---------
c         else
c            write(iw8,900)(inf(jk),jk=1,il)
c            goto 10
c         endif 
c s          endif
        else if(LINST) then
               IF(KPREV.NE.2) THEN
               read(infn,*,err=700,end=800)x,y,z
               xn=x*xf
               yn=y*yf
               zn=z*zf
               write(iw8,934)xn,yn,zn
 934           format(e16.6,',',e16.6,',',e16.6)
               KPREV=2
               else
               read(infn,*,err=700,end=800)x1,y1,z1,x2,y2,z2,ang
               x1n=x1*xf
               y1n=y1*yf
               z1n=z1*zf
               x2n=x2*xf
               y2n=y2*yf
               z2n=z2*zf
               write(iw8,936)x1n,y1n,zn,x2n,y2n,z2n,ang
 936           format(e16.6,',',e16.6,',',e16.6,','e16.6,',',e16.6,',',
     +     e16.6,',',e16.6)
               endif
         else if(LSHEL) then
C
               read(infn,*,err=700,end=800)t,n
               tn=t*xf
                write(iw8,938)tn,n
 938            format(F12.3,',',2X,I4)
               KPREV=0
         else
            write(iw8,900)(inf(jk),jk=1,il)
  
         endif
            goto 10
c---------------end of i2d=2 test---------
c         else
c            write(iw8,900)(inf(jk),jk=1,il)
c            goto 10
c         endif
c--------------end of inf(1)='*' test---
c         goto 10
      endif
      goto 10
  900 format(150a1)
c
  920 format(i8,',',e16.6,',',e16.6)
  930 format(i8,',',e16.6,',',e16.6,',',e16.6)
c
  700 continue
      print*,'**** Errors :, line number :',lino
      print*,'Line : ',lino, (inf(jj),jj=1,ninf)
      write(iw8,900)(inf(jk),jk=1,il)
      goto 10
  800 continue
      print*,'*** End of file reached  ***'
      print*,'Line : ',lino, (inf(jj),jj=1,ninf)
      print*,' ABAQUS Input file : ',abaout,' has been created.'
      print*,'  ***** Conversion Completed ***** '           
      stop
      end
      subroutine match(nodel,icode,il)
C
C***********************************************************************
C     IF NODE set ICODE = 1
C     IF ELEMENT set ICODE = 2
C     IF NODE PRINT or NODE FILE and anything else set ICODE = 0
C***********************************************************************
C
      character nodel*6
c
      ICODE=0
C
C      print*,'nodel :',nodel
      if(nodel(1:6).eq.'NODE P') then
                 icode=0
                 return
      else if(nodel(1:6).eq.'NODE F') then
                 icode=0
                 return
      else if(nodel(1:6).eq.'NODE O') then
                 icode=0
                 return
      else if(nodel(1:4).eq.'NODE') then
                 icode=1
                 return
      else if(nodel(1:4).eq.'ELEM') then
                 icode=2
                 return
      else if(nodel(1:4).eq.'INST') then
                 icode=3
                 return
      else if(nodel(1:4).eq.'SHEL') then
                 icode=4
                 return
      endif
      return
      end
      subroutine last(iw9,c,ib)
c
C***********************************************************************
C
C     Detect the end of each line.  ib - last character postionn.
C
C***********************************************************************
C
      character*1 c(150)
C
      do 100 il=1,150
      ib=151-il 
      if(c(ib).ne.' ') goto 200
c      ik=1
c      kNO=ICHAR(C(IB))
c      write(iw9,870)ik,il,ib,kNO,C(IB),achar(kno)
  870 format(1x,'ik il ib IChar c(ib) ACHAR',3I5,3X,i4,2x,a1,2x,a1)
C
  100 continue
c
      ik=2
      IB=150
      KNO=ICHAR(C(IB))
      write(iw9,870)ik,il,ib,KNO,C(IB),achar(kno)
      return
  200 continue
      ik=3
      kNO=ICHAR(C(IB))
      write(iw9,870)ik,il,ib,kNO,C(IB),achar(kno)
      return
      end
      SUBROUTINE KEYWD(iw9,C6,inf)
C
C********************************************************************
C
C     Convert all lower case characters of the into upper case.
C
C********************************************************************
C                    
C     character*1 cl(26),cu(26),ch,C6*6,inf(100)
      character*1 cu(26),ch,C6*6,inf(150)
c     data (cl(j),j=1,26)/'a','b','c','d','e','f','g','h','i','j','k',
c    +    'l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'/
      data (cu(k),k=1,26)/'A','B','C','D','E','F','G','H','I','J','K',
     +    'L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
C
C--------------------copy next 6 characters into c6
      DO 20 I=1,6
      noch=ichar(inf(i+1))
      if(noch.gt.96.and.noch.lt.123) then
         iclno=noch-96
c                 c6(i:i)=achar(noch-32)
         c6(I:I)=CU(iclno)
      else
         c6(i:i)=inf(i+1)  
      endif
  20  continue
c
      write(iw9,890)c6
 890  format(1x,'c6 : ',a6)
      return
      end
      subroutine findim(ir5,iw9,inf,i2d,ninf,xf,yf,zf)
C
C********************************************************************
C
C     work out the dimension and read scale factors
C
C********************************************************************
C     
      character*1 inf(ninf)
c
            do 25 i=1,ninf
            if(inf(i).eq.',') then
                 i2d=i2d+1
                 inf(i)=' '
            endif
 25         continue
c
      if(i2d.eq.2) then
      print*,'Enter the scale factors for X and Y Co-ords (xf, yf) =>'
      read(ir5,*)xf,yf
      write(iw9,950)xf,yf
      zf=0.
  950 format(/1x,'xf =',e15.5,3x,'yf =',e15.5)
      else
c
c........1.........2.........3.........4.........5.........6.........7..
      print*,'Enter scale factors for X Y Z Co-ords (xf, yf, zf) =>'
      read(ir5,*)xf,yf,zf
      write(iw9,960)xf,yf,zf
  960 format(/1x,'xf =',e15.5,3x,'yf =',e15.5,3x,'zf =',e15.5)
      endif
      return
      end