--- /dev/null
+ 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
+ energy_dec=index(controlcard,"ENERGY_DEC").gt.0
+ 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
+ refstr = index(controlcard,'REFSTR').gt.0
+ pdbref = index(controlcard,'PDBREF').gt.0
+ 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
projects / unres.git / blobdiff