subroutine read_general_data(*) implicit none include "DIMENSIONS" include "DIMENSIONS.ZSCOPT" include "DIMENSIONS.FREE" include "COMMON.TORSION" include "COMMON.INTERACT" include "COMMON.IOUNITS" include "COMMON.TIME1" include "COMMON.PROT" include "COMMON.PROTFILES" include "COMMON.CHAIN" include "COMMON.NAMES" include "COMMON.FFIELD" include "COMMON.ENEPS" include "COMMON.WEIGHTS" include "COMMON.FREE" include "COMMON.CONTROL" include "COMMON.ENERGIES" character*800 controlcard integer i,j,k,ii,n_ene_found integer ind,itype1,itype2,itypf,itypsc,itypp integer ilen external ilen character*16 ucase character*16 key external ucase call card_concat(controlcard,.true.) call readi(controlcard,"N_ENE",n_ene,max_ene) if (n_ene.gt.max_ene) then write (iout,*) "Error: parameter out of range: N_ENE",n_ene, & max_ene return1 endif call readi(controlcard,"NPARMSET",nparmset,1) separate_parset = index(controlcard,"SEPARATE_PARSET").gt.0 call readi(controlcard,"IPARMPRINT",iparmprint,1) write (iout,*) "PARMPRINT",iparmprint if (nparmset.gt.max_parm) then write (iout,*) "Error: parameter out of range: NPARMSET", & nparmset, Max_Parm return1 endif call readi(controlcard,"MAXIT",maxit,5000) call reada(controlcard,"FIMIN",fimin,1.0d-3) call readi(controlcard,"ENSEMBLES",ensembles,0) hamil_rep=index(controlcard,"HAMIL_REP").gt.0 write (iout,*) "Number of energy parameter sets",nparmset call multreadi(controlcard,"ISAMPL",isampl,nparmset,1) write (iout,*) "MaxSlice",MaxSlice call readi(controlcard,"NSLICE",nslice,1) call flush(iout) if (nslice.gt.MaxSlice) then write (iout,*) "Error: parameter out of range: NSLICE",nslice, & MaxSlice return1 endif write (iout,*) "Frequency of storing conformations", & (isampl(i),i=1,nparmset) write (iout,*) "Maxit",maxit," Fimin",fimin call readi(controlcard,"NQ",nQ,1) if (nQ.gt.MaxQ) then write (iout,*) "Error: parameter out of range: NQ",nq, & maxq return1 endif indpdb=0 if (index(controlcard,"CLASSIFY").gt.0) indpdb=1 call reada(controlcard,"DELTA",delta,1.0d-2) call readi(controlcard,"EINICHECK",einicheck,2) call reada(controlcard,"DELTRMS",deltrms,5.0d-2) call readi(controlcard,"NGRIDT",NGridT,400) call reada(controlcard,"STARTGRIDT",StartGridT,200.0d0) call reada(controlcard,"DELTA_T",Delta_T,1.0d0) call reada(controlcard,"DELTRGY",deltrgy,5.0d-2) call readi(controlcard,"RESCALE",rescale_mode,1) check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 write (iout,*) "delta",delta write (iout,*) "einicheck",einicheck write (iout,*) "rescale_mode",rescale_mode call flush(iout) bxfile=index(controlcard,"BXFILE").gt.0 cxfile=index(controlcard,"CXFILE").gt.0 if (nslice .eq. 1 .and. .not.bxfile .and. .not.cxfile) & bxfile=.true. histfile=index(controlcard,"HISTFILE").gt.0 histout=index(controlcard,"HISTOUT").gt.0 entfile=index(controlcard,"ENTFILE").gt.0 zscfile=index(controlcard,"ZSCFILE").gt.0 with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 call readi(controlcard,'CONSTR_DIST',constr_dist,0) write (iout,*) "with_dihed_constr ",with_dihed_constr, & " CONSTR_DIST",constr_dist call flush(iout) return end c------------------------------------------------------------------------------ subroutine read_efree(*) C C Read molecular data C implicit none include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.SBRIDGE' include 'COMMON.CONTROL' include 'COMMON.CHAIN' include 'COMMON.HEADER' include 'COMMON.GEO' include 'COMMON.FREE' character*320 controlcard,ucase integer iparm,ib,i,j,npars integer ilen external ilen if (hamil_rep) then npars=1 else npars=nParmSet endif do iparm=1,npars call card_concat(controlcard,.true.) call readi(controlcard,'NT',nT_h(iparm),1) write (iout,*) "iparm",iparm," nt",nT_h(iparm) call flush(iout) if (nT_h(iparm).gt.MaxT_h) then write (iout,*) "Error: parameter out of range: NT",nT_h(iparm), & MaxT_h return1 endif replica(iparm)=index(controlcard,"REPLICA").gt.0 umbrella(iparm)=index(controlcard,"UMBRELLA").gt.0 read_iset(iparm)=index(controlcard,"READ_ISET").gt.0 write (iout,*) "nQ",nQ," nT",nT_h(iparm)," replica ", & replica(iparm)," umbrella ",umbrella(iparm), & " read_iset",read_iset(iparm) call flush(iout) do ib=1,nT_h(iparm) call card_concat(controlcard,.true.) call readi(controlcard,'NR',nR(ib,iparm),1) if (umbrella(iparm)) then nRR(ib,iparm)=1 else nRR(ib,iparm)=nR(ib,iparm) endif if (nR(ib,iparm).gt.MaxR) then write (iout,*) "Error: parameter out of range: NR", & nR(ib,iparm),MaxR return1 endif call reada(controlcard,'TEMP',beta_h(ib,iparm),298.0d0) beta_h(ib,iparm)=1.0d0/(beta_h(ib,iparm)*1.987D-3) call multreada(controlcard,'FI',f(1,ib,iparm),nR(ib,iparm), & 0.0d0) do i=1,nR(ib,iparm) call card_concat(controlcard,.true.) call multreada(controlcard,'KH',KH(1,i,ib,iparm),nQ, & 100.0d0) call multreada(controlcard,'Q0',Q0(1,i,ib,iparm),nQ, & 0.0d0) enddo enddo do ib=1,nT_h(iparm) write (iout,*) "ib",ib," beta_h", & 1.0d0/(0.001987*beta_h(ib,iparm)) write (iout,*) "nR",nR(ib,iparm) write (iout,*) "fi",(f(i,ib,iparm),i=1,nR(ib,iparm)) do i=1,nR(ib,iparm) write (iout,*) "i",i," Kh",(Kh(j,i,ib,iparm),j=1,nQ), & "q0",(q0(j,i,ib,iparm),j=1,nQ) enddo call flush(iout) enddo enddo if (hamil_rep) then do iparm=2,nParmSet nT_h(iparm)=nT_h(1) do ib=1,nT_h(iparm) nR(ib,iparm)=nR(ib,1) if (umbrella(iparm)) then nRR(ib,iparm)=1 else nRR(ib,iparm)=nR(ib,1) endif beta_h(ib,iparm)=beta_h(ib,1) do i=1,nR(ib,iparm) f(i,ib,iparm)=f(i,ib,1) do j=1,nQ KH(j,i,ib,iparm)=KH(j,i,ib,1) Q0(j,i,ib,iparm)=Q0(j,i,ib,1) enddo enddo replica(iparm)=replica(1) umbrella(iparm)=umbrella(1) read_iset(iparm)=read_iset(1) enddo enddo endif return end c----------------------------------------------------------------------------- subroutine read_protein_data(*) implicit none include "DIMENSIONS" include "DIMENSIONS.ZSCOPT" include "DIMENSIONS.FREE" #ifdef MPI include "mpif.h" integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) include "COMMON.MPI" #endif include "COMMON.CHAIN" include "COMMON.IOUNITS" include "COMMON.PROT" include "COMMON.PROTFILES" include "COMMON.NAMES" include "COMMON.FREE" include "COMMON.OBCINKA" character*64 nazwa character*16000 controlcard integer i,ii,ib,iR,iparm,ilen,iroof,nthr,npars external ilen,iroof if (hamil_rep) then npars=1 else npars=nparmset endif do iparm=1,npars C Read names of files with conformation data. if (replica(iparm)) then nthr = 1 else nthr = nT_h(iparm) endif do ib=1,nthr do ii=1,nRR(ib,iparm) write (iout,*) "Parameter set",iparm," temperature",ib, & " window",ii call flush(iout) call card_concat(controlcard,.true.) write (iout,*) controlcard(:ilen(controlcard)) call readi(controlcard,"NFILE_BIN",nfile_bin(ii,ib,iparm),0) call readi(controlcard,"NFILE_ASC",nfile_asc(ii,ib,iparm),0) call readi(controlcard,"NFILE_CX",nfile_cx(ii,ib,iparm),0) call readi(controlcard,"REC_START",rec_start(ii,ib,iparm),1) call readi(controlcard,"REC_END",rec_end(ii,ib,iparm), & maxstr*isampl(iparm)+rec_start(ii,ib,iparm)-1) call reada(controlcard,"TIME_START", & time_start_collect(ii,ib,iparm),0.0d0) call reada(controlcard,"TIME_END",time_end_collect(ii,ib,iparm), & 1.0d10) write (iout,*) "rec_start",rec_start(ii,ib,iparm), & " rec_end",rec_end(ii,ib,iparm) write (iout,*) "time_start",time_start_collect(ii,ib,iparm), & " time_end",time_end_collect(ii,ib,iparm) call flush(iout) if (replica(iparm)) then call readi(controlcard,"TOTRAJ",totraj(ii,iparm),1) write (iout,*) "Number of trajectories",totraj(ii,iparm) call flush(iout) endif if (nfile_bin(ii,ib,iparm).lt.2 & .and. nfile_asc(ii,ib,iparm).eq.0 & .and. nfile_cx(ii,ib,iparm).eq.0) then write (iout,*) "Error - no action specified!" return1 endif if (nfile_bin(ii,ib,iparm).gt.0) then call card_concat(controlcard,.false.) call split_string(controlcard,protfiles(1,1,ii,ib,iparm), & maxfile_prot,nfile_bin(ii,ib,iparm)) #ifdef DEBUG write(iout,*)"nfile_bin",nfile_bin(ii,ib,iparm) write(iout,*) (protfiles(i,1,ii,ib,iparm), & i=1,nfile_bin(ii,ib,iparm)) #endif endif if (nfile_asc(ii,ib,iparm).gt.0) then call card_concat(controlcard,.false.) call split_string(controlcard,protfiles(1,2,ii,ib,iparm), & maxfile_prot,nfile_asc(ii,ib,iparm)) #ifdef DEBUG write(iout,*) "nfile_asc(ii,ib,iparm)",nfile_asc(ii,ib,iparm) write(iout,*) (protfiles(i,2,ii,ib,iparm), & i=1,nfile_asc(ii,ib,iparm)) #endif else if (nfile_cx(ii,ib,iparm).gt.0) then call card_concat(controlcard,.false.) call split_string(controlcard,protfiles(1,2,ii,ib,iparm), & maxfile_prot,nfile_cx(ii,ib,iparm)) #ifdef DEBUG write(iout,*) "nfile_cx(ii,ib,iparm)",nfile_cx(ii,ib,iparm) write(iout,*) (protfiles(i,2,ii,ib,iparm), & i=1,nfile_cx(ii,ib,iparm)) #endif endif call flush(iout) enddo enddo enddo return end c------------------------------------------------------------------------------- subroutine opentmp(islice,iunit,bprotfile_temp) implicit none include "DIMENSIONS" include "DIMENSIONS.ZSCOPT" include "DIMENSIONS.FREE" #ifdef MPI include "mpif.h" integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) include "COMMON.MPI" #endif include "COMMON.IOUNITS" include "COMMON.PROTFILES" include "COMMON.PROT" include "COMMON.FREE" character*64 bprotfile_temp character*3 liczba,liczba2 character*2 liczba1 integer iunit,islice integer ilen,iroof external ilen,iroof logical lerr write (liczba1,'(bz,i2.2)') islice write (liczba,'(bz,i3.3)') me #ifdef MPI c write (iout,*) "separate_parset ",separate_parset, c & " myparm",myparm if (separate_parset) then write (liczba2,'(bz,i3.3)') myparm bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & prefix(:ilen(prefix))//liczba//"_"//liczba2//".xbin.tmp"//liczba1 open (iunit,file=bprotfile_temp,status="unknown", & form="unformatted",access="direct",recl=lenrec) else bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 open (iunit,file=bprotfile_temp,status="unknown", & form="unformatted",access="direct",recl=lenrec) endif #else bprotfile_temp = scratchdir(:ilen(scratchdir))// & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 open (iunit,file=bprotfile_temp,status="unknown", & form="unformatted",access="direct",recl=lenrec) #endif c write (iout,*) "OpenTmp iunit",iunit," bprotfile_temp", c & bprotfile_temp c call flush(iout) return end c------------------------------------------------------------------------------- subroutine read_database(*) implicit none include "DIMENSIONS" include "DIMENSIONS.ZSCOPT" include "DIMENSIONS.FREE" #ifdef MPI include "mpif.h" integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE) include "COMMON.MPI" #endif include "COMMON.CHAIN" include "COMMON.IOUNITS" include "COMMON.PROTFILES" include "COMMON.NAMES" include "COMMON.VAR" include "COMMON.GEO" include "COMMON.ENEPS" include "COMMON.PROT" include "COMMON.INTERACT" include "COMMON.FREE" include "COMMON.SBRIDGE" include "COMMON.OBCINKA" real*4 csingle(3,maxres2) character*64 nazwa,bprotfile_temp character*3 liczba character*2 liczba1 integer i,j,ii,jj(maxslice),k,kk(maxslice),l, & ll(maxslice),mm(maxslice),if integer nrec,nlines,iscor,iunit,islice double precision energ integer ilen,iroof external ilen,iroof double precision rmsdev,energia(0:max_ene),efree,eini,temp double precision prop(maxQ) integer ntot_all(maxslice,0:maxprocs-1) integer iparm,ib,iib,ir,nprop,nthr,npars double precision etot,time integer ixdrf,iret logical lerr,linit lenrec1=12*(nres+nct-nnt+1)+4*(2*nss+2)+24 lenrec2=12*(nres+nct-nnt+1)+4*(2*nss+2)+24+8*nQ lenrec=lenrec2+8 write (iout,*) "lenrec",lenrec," lenrec1",lenrec1, & " lenrec2",lenrec2 do i=1,nQ prop(i)=0.0d0 enddo do islice=1,nslice ll(islice)=0 mm(islice)=0 enddo write (iout,*) "nparmset",nparmset if (hamil_rep) then npars=1 else npars=nparmset endif do iparm=1,npars if (replica(iparm)) then nthr = 1 else nthr = nT_h(iparm) endif do ib=1,nthr do iR=1,nRR(ib,iparm) write (iout,*) "iparm",iparm," ib",ib," iR",iR," nQ",nQ do islice=1,nslice jj(islice)=0 kk(islice)=0 enddo IF (NFILE_BIN(iR,ib,iparm).GT.0) THEN c Read conformations from binary DA files (one per batch) and write them to c a binary DA scratchfile. write (liczba,'(bz,i3.3)') me do if=1,nfile_bin(iR,ib,iparm) nazwa=protfiles(if,1,iR,ib,iparm) & (:ilen(protfiles(if,1,iR,ib,iparm)))//".bx" open (ientin,file=nazwa,status="old",form="unformatted", & access="direct",recl=lenrec2,err=1111) ii=0 do islice=1,nslice call opentmp(islice,ientout,bprotfile_temp) call bxread(nazwa,ii,jj(islice),kk(islice),ll(islice), & mm(islice),iR,ib,iparm) close(ientout) enddo close(ientin) enddo ENDIF ! NFILE_BIN>0 c IF (NFILE_ASC(iR,ib,iparm).GT.0) THEN c Read conformations from multiple ASCII int files and write them to a binary c DA scratchfile. do if=1,nfile_asc(iR,ib,iparm) nazwa=protfiles(if,2,iR,ib,iparm) & (:ilen(protfiles(if,2,iR,ib,iparm)))//".x" open(unit=ientin,file=nazwa,status='old',err=1111) write(iout,*) "reading ",nazwa(:ilen(nazwa)) ii=0 call xread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm) enddo ! if ENDIF IF (NFILE_CX(iR,ib,iparm).gt.0) THEN c Read conformations from cx files and write them to a binary c DA scratchfile. do if=1,nfile_cx(iR,ib,iparm) nazwa=protfiles(if,2,iR,ib,iparm) & (:ilen(protfiles(if,2,iR,ib,iparm)))//".cx" write(iout,*) "reading ",nazwa(:ilen(nazwa)) ii=0 print *,"Calling cxread" call cxread(nazwa,ii,jj,kk,ll,mm,iR,ib,iparm, & *1111) close(ientout) write (iout,*) "exit cxread" call flush(iout) enddo ENDIF do islice=1,nslice stot(islice)=stot(islice)+jj(islice) enddo enddo enddo write (iout,*) "IPARM",iparm enddo if (nslice.eq.1) then #ifdef MPI write (liczba,'(bz,i3.3)') me bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & prefix(:ilen(prefix))//liczba//".xbin.tmp" #else bprotfile_temp = scratchdir(:ilen(scratchdir))// & "/"//prefix(:ilen(prefix))//".xbin.tmp" #endif write(iout,*) mm(1)," conformations read",ll(1), & " conformations written to ", & bprotfile_temp(:ilen(bprotfile_temp)) else do islice=1,nslice write (liczba1,'(bz,i2.2)') islice #ifdef MPI write (liczba,'(bz,i3.3)') me bprotfile_temp = scratchdir(:ilen(scratchdir))//"/"// & prefix(:ilen(prefix))//liczba//".xbin.tmp"//liczba1 #else bprotfile_temp = scratchdir(:ilen(scratchdir))// & "/"//prefix(:ilen(prefix))//".xbin.tmp"//liczba1 #endif write(iout,*) mm(islice)," conformations read",ll(islice), & " conformations written to ", & bprotfile_temp(:ilen(bprotfile_temp)) enddo endif #ifdef MPI c Check if everyone has the same number of conformations call MPI_Allgather(stot(1),maxslice,MPI_INTEGER, & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) lerr=.false. do i=0,nprocs-1 if (i.ne.me) then do islice=1,nslice if (stot(islice).ne.ntot_all(islice,i)) then write (iout,*) "Number of conformations at processor",i, & " differs from that at processor",me, & stot(islice),ntot_all(islice,i)," slice",islice lerr = .true. endif enddo endif enddo if (lerr) then write (iout,*) write (iout,*) "Numbers of conformations read by processors" write (iout,*) do i=0,nprocs-1 write (iout,'(8i10)') i,(ntot_all(islice,i),islice=1,nslice) enddo write (iout,*) "Calculation terminated." call flush(iout) return1 endif do islice=1,nslice ntot(islice)=stot(islice) enddo return #endif 1111 write(iout,*) "Error opening coordinate file ",nazwa(:ilen(nazwa)) call flush(iout) return1 end c------------------------------------------------------------------------------ subroutine card_concat(card,to_upper) implicit none include 'DIMENSIONS.ZSCOPT' include "COMMON.IOUNITS" character*(*) card character*80 karta,ucase logical to_upper integer ilen external ilen read (inp,'(a)') karta if (to_upper) karta=ucase(karta) card=' ' do while (karta(80:80).eq.'&') card=card(:ilen(card)+1)//karta(:79) read (inp,'(a)') karta if (to_upper) karta=ucase(karta) enddo card=card(:ilen(card)+1)//karta return end c------------------------------------------------------------------------------ subroutine readi(rekord,lancuch,wartosc,default) implicit none character*(*) rekord,lancuch integer wartosc,default integer ilen,iread external ilen iread=index(rekord,lancuch(:ilen(lancuch))//"=") if (iread.eq.0) then wartosc=default return endif iread=iread+ilen(lancuch)+1 read (rekord(iread:),*) wartosc return end c---------------------------------------------------------------------------- subroutine reada(rekord,lancuch,wartosc,default) implicit none character*(*) rekord,lancuch character*80 aux double precision wartosc,default integer ilen,iread external ilen iread=index(rekord,lancuch(:ilen(lancuch))//"=") if (iread.eq.0) then wartosc=default return endif iread=iread+ilen(lancuch)+1 read (rekord(iread:),*) wartosc return end c---------------------------------------------------------------------------- subroutine multreadi(rekord,lancuch,tablica,dim,default) implicit none integer dim,i integer tablica(dim),default character*(*) rekord,lancuch character*80 aux integer ilen,iread external ilen do i=1,dim tablica(i)=default enddo iread=index(rekord,lancuch(:ilen(lancuch))//"=") if (iread.eq.0) return iread=iread+ilen(lancuch)+1 read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) 10 return end c---------------------------------------------------------------------------- subroutine multreada(rekord,lancuch,tablica,dim,default) implicit none integer dim,i double precision tablica(dim),default character*(*) rekord,lancuch character*80 aux integer ilen,iread external ilen do i=1,dim tablica(i)=default enddo iread=index(rekord,lancuch(:ilen(lancuch))//"=") if (iread.eq.0) return iread=iread+ilen(lancuch)+1 read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) 10 return end c---------------------------------------------------------------------------- subroutine reads(rekord,lancuch,wartosc,default) implicit none character*(*) rekord,lancuch,wartosc,default character*80 aux integer ilen,lenlan,lenrec,iread,ireade external ilen logical iblnk external iblnk lenlan=ilen(lancuch) lenrec=ilen(rekord) iread=index(rekord,lancuch(:lenlan)//"=") c print *,"rekord",rekord," lancuch",lancuch c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec if (iread.eq.0) then wartosc=default return endif iread=iread+lenlan+1 c print *,"iread",iread c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) iread=iread+1 c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) enddo c print *,"iread",iread if (iread.gt.lenrec) then wartosc=default return endif ireade=iread+1 c print *,"ireade",ireade do while (ireade.lt.lenrec .and. & .not.iblnk(rekord(ireade:ireade))) ireade=ireade+1 enddo wartosc=rekord(iread:ireade) return end c---------------------------------------------------------------------------- subroutine multreads(rekord,lancuch,tablica,dim,default) implicit none integer dim,i character*(*) rekord,lancuch,tablica(dim),default character*80 aux integer ilen,lenlan,lenrec,iread,ireade external ilen logical iblnk external iblnk do i=1,dim tablica(i)=default enddo lenlan=ilen(lancuch) lenrec=ilen(rekord) iread=index(rekord,lancuch(:lenlan)//"=") c print *,"rekord",rekord," lancuch",lancuch c print *,"iread",iread," lenlan",lenlan," lenrec",lenrec if (iread.eq.0) return iread=iread+lenlan+1 do i=1,dim c print *,"iread",iread c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) do while (iread.le.lenrec .and. iblnk(rekord(iread:iread))) iread=iread+1 c print *,"|",rekord(iread:iread),"|",iblnk(rekord(iread:iread)) enddo c print *,"iread",iread if (iread.gt.lenrec) return ireade=iread+1 c print *,"ireade",ireade do while (ireade.lt.lenrec .and. & .not.iblnk(rekord(ireade:ireade))) ireade=ireade+1 enddo tablica(i)=rekord(iread:ireade) iread=ireade+1 enddo end c---------------------------------------------------------------------------- subroutine split_string(rekord,tablica,dim,nsub) implicit none integer dim,nsub,i,ii,ll,kk character*(*) tablica(dim) character*(*) rekord integer ilen external ilen do i=1,dim tablica(i)=" " enddo ii=1 ll = ilen(rekord) nsub=0 do i=1,dim C Find the start of term name kk = 0 do while (ii.le.ll .and. rekord(ii:ii).eq." ") ii = ii+1 enddo C Parse the name into TABLICA(i) until blank found do while (ii.le.ll .and. rekord(ii:ii).ne." ") kk = kk+1 tablica(i)(kk:kk)=rekord(ii:ii) ii = ii+1 enddo if (kk.gt.0) nsub=nsub+1 if (ii.gt.ll) return enddo return end c-------------------------------------------------------------------------------- integer function iroof(n,m) ii = n/m if (ii*m .lt. n) ii=ii+1 iroof = ii return end