c Fortran 77 library : Chara.f c c Subroutine | Version | Last update c ------------+---------+-------------- c WRFILE | 1.00 | 2006/ 2/18 c ITOAGN | 1.02 | 2007/ 7/28 c ATOIGN | 1.00 | 2007/ 1/ 1 c ATORGN | 1.00 | 2007/ 1/ 1 c ALGGN | 1.00 | 2006/ 2/18 c ALGSRP | 1.00 | 2006/ 2/18 c T1LPAS | 1.00 | 2006/ 2/18 subroutine WRFILE(unno,text) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2006 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2006/ 2/18 c Modification: c c In this subroutine, c write the text on the file. c c Input variables: (name : type : explanation) c unno : integer type : unit number. c text : character type : text data. c c Output variables: (name : type : explanation) c None. c c Required subroutines : ALGGN and ALGSRP (in the library 'Chara.f'). c /----------------------------------- integer unno character*(*) text integer lg,i if (len(text).le.1200) then call ALGGN(text,lg) else call ALGSRP(text,lg) end if if (lg.eq.0) then write(unno,*) ' ' else write(unno,601) (text(i:i),i=1,lg) 601 format(20000A1) end if return end subroutine ITOAGN(i,a,ilg) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2006-2007 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2006/ 2/18 c Modification: Ver.1.01, TAKAGI-1, 2006/12/15 (allover) c Ver.1.02, TAKAGI-1, 2007/ 7/28 (debug **1) c c In this subroutine, c change the integer type number to the character type number. c c Input variables: (name : type : explanation) c i : integer type : number (e.g. 123). c c Output variables: (name : type : explanation) c ilg : integer type : digit number c a : character type*10 : number (e.g. '123'). c c Required subroutines : T1PAS (in the library 'Chara.f'). c /----------------------------------- integer i character*10 a character*10 b integer ilg integer j integer fulrng parameter (fulrng = 10) if (i.ge.10**(fulrng-1) ) then write(*,*) 'ERROR: SR-ITOAGN: overflow [1]' call T1LPAS stop end if * write(b,'(I10.10)') i * ! (I fulrng . fulrng ) cc [**1, deletion] cc do j=1,fulrng-1 cc [**1, insertion] do j=1,fulrng if (b(j:j).ne.'0') then ilg = fulrng - j +1 a = b(j:) return end if end do a = '0' ilg = 1 return * end subroutine ATOIGN(aa,ii) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2007 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2007/ 1/ 1 c Modification: c c In this subroutine, c change the chracter type number to the integer type number. c c Input variables: (name : type : explanation) c aa : character type : number (e.g. '123'). c c Output variables: (name : type : explanation) c ii : integer type : number (e.g. 123). c c Required subroutines : ATORGN (in the library 'Chara.f'). c /----------------------------------- character aa*(*) integer ii character a*160 integer alen real r a=' ' alen=len(aa) a(1:alen)=aa call ATORGN(a,r) ii=nint(r) return end subroutine ATORGN(a,r) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2007 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2007/ 1/ 1 c Modification: c c In this subroutine, c change the chracter type number to the real type number. c c Input variables: (name : type : explanation) c a : character type : number (e.g. '1.23'). c c Output variables: (name : type : explanation) c r : real type : number (e.g. 1.23). c c Required subroutines : none. c /----------------------------------- character*(*) a character*160 b,memo integer i,point,order,alen double precision d real r d=0.0D0 alen=len(a) b=' ' b(1:alen)=a 1 if (b(1:1).eq.' ') then memo=b b=memo(2:160) goto 1 end if do 10 i=1,160 if (b(i:i).eq.'.') then point=i goto 100 end if if (b(i:i).eq.' ') then b(i:i)='.' point=i goto 100 end if 10 continue 100 do 20 i=1,160 if (b(i:i).eq.'.') then goto 20 end if if (b(i:i).eq.' ') then goto 200 end if if (point-i.gt.0) then order=point-i-1 d=d+dble(ichar(b(i:i))-ichar('0'))*dble(10**order) else order=i-point d=d+dble(ichar(b(i:i))-ichar('0'))/dble(10**order) end if 20 continue 200 r=sngl(d) return end subroutine ALGGN(a,lg) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2006 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2006/ 2/18 c Modification: c c In this subroutine, c count characters of the text. c c Input variables: (name : type : explanation) c a : character type : text (e.g. 'abc'). c c Output variables: (name : type : explanation) c alg : integer type : byte number of the text (e.g. 3) c c Required subroutines : none. c /----------------------------------- character a*(*) integer lg,j,k,along along = len(a) if (a.eq.' ') then lg=0 goto 100 end if do 5 j=along,30,-30 if (a(j-29:j).ne. *' ') then goto 8 end if 5 continue 8 do 10 k=j,1,-1 if (a(k:k).ne.' ') then goto 20 end if 10 continue 20 lg=k 100 return end subroutine ALGSRP(a,lg) c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2006 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2006/ 2/18 c Modification: c c In this subroutine, c count characters of the text rapidly. c c Input variables: (name : type : explanation) c a : character type : text (e.g. 'abc'). c c Output variables: (name : type : explanation) c alg : integer type : byte number of the text (e.g. 3) c c Required subroutines : none. c /----------------------------------- character a*(*) integer lg,j,k,i character fty*50 character th*1000 integer m integer along fty=' ' if (a.eq.' ') then lg=0 goto 100 end if do 3 m=1,20 th((m-1)*50+1:m*50)=fty(1:50) 3 continue along=len(a) do 200 i=along,1000,-1000 if (a(i-999:i).ne.th) then goto 4 end if 200 continue 4 do 5 j=i,50,-50 if (a(j-49:j).ne.fty) then goto 8 end if 5 continue 8 do 10 k=j,1,-1 if (a(k:k).ne.' ') then goto 20 end if 10 continue 20 lg=k 100 return end subroutine T1LPAS c ----------------------------------- c You can freely use, copy, modify and redistribute this subroutine. c This subroutine comes with absolutely no warranty. c c Copyright (C) 2006 TAKAGI-1 c c Author : TAKAGI-1 c Date : 2006/ 2/18 c Modification: c c In this subroutine, c pause. c c Input variables: (name : type : explanation) c None. c c Output variables: (name : type : explanation) c None. c c Required subroutines : none. c /----------------------------------- real r write(*,*) '-- Now Pausing --' write(*,*) 'any number : OK' read(*,*) r return end