инфа / проги инфа вар 1,2(родионова) / задача с базами

inteGer rej
character ptc*30,c,fmt1*55,name1*30,name2*30,fmt2*50,name*30
logical DA_NET,fptc
common /d1/fmt1,/d2/fmt2
ptc='D:\ptcf1_1.doc'
INQUIRE(file=ptc,exist=fptc)
if(fptc) then
open(unit=7,file=ptc)
close(unit=7,status='delete')
endif
open(7,file=ptc,access='sequential',form='formatted',status='new')

fmt1=' (3x,A15,2x,a5,2x,a8,2x,i2,12x,i3) '
fmt2=' (3x,A15,2x,i2,12x,i3) '
1 continue
write(*,*)' Vozmogni sledyshie regimi raboti:'
write(*,*)' 1- sozdanie ishodnogo posledovatelnogo formatnogo faila'
write(*,*)' 2-prosmotr ishodhogo faila'
write(*,*)' 3- sozdaniepo ishodnomy faily rabo4ego (pr9mogo besformatnogo) i ego ypor9do4ivanie'
write(*,*)' 4- prosmotr rabo4ego faila'
write(*,*)' 5- sozdanie rezyltiryushego faila i ego ypor9do4ivanie'
write(*,*)' 6- prosmotr rezultiryushego faila'
write(*,*)' 7 - prosmotr rezultiryushegofaila po ysloviu'
write(*,*)' 8 - okon4anie raboti'
write(*,*)' vvedite nomer regima'
write(7,*)' Vozmogni sledyshie regimi raboti:'
write(7,*)' 1- sozdanie ishodnogo posledovatelnogo formatnogo faila'
write(7,*)' 2-prosmotr ishodhogo faila'
write(7,*)' 3- sozdaniepo ishodnomy faily rabo4ego (pr9mogo besformatnogo) i ego ypor9do4ivanie'
write(7,*)' 4- prosmotr rabo4ego faila'
write(7,*)' 5- sozdanie rezyltiryushego faila i ego ypor9do4ivanie'
write(7,*)' 6- prosmotr rezultiryushego faila'
write(7,*)' 7 - prosmotr rezultiryushegofaila po ysloviu'
write(7,*)' 8 - okon4anie raboti'
write(*,*)' vvedite nomer regima'
read(*,*)rej
write(7 , ' (27x,I1) ' )rej
go to (101,201,301,401,501,601,701,801)rej
write(*,*) ' Takogo regima net'
write(7,*) ' Takogo regima net'
goto 999
101 CONTINUE
! write(*,*) ' in DA_NET'
if( DA_NET(name,.false.)) then
! write(*,*) ' out DA_NET '
! pause
write(*,16) name
Write(7,16) name
16 format (3x,' sozdaem fail - ' ,A30)
! write(*,*) ' in SOZD'
! pause
call Sozd (name)
! write(*,*)' out SOZD'
! Pause
end if
109 CONTINUE
goto 999

201 CONTINUE
if (DA_NET(name,.true.))then
Write(*,206) name
write(7,206) name
206 format(7x,'fail - ',A30/)
!write(*,*)' in VIVISH'
! pause
call VIVISH (name)
! write(*,*) ' out VIVISH'
! pause
endif
209 CONTINUE
goto 999
301 CONTINUE
write (*,*)' Po ishodnomy faily (namel) sozdaem rabo4ii (name2)'
write (*,*)' Ishodnii fail'
write(7,*)' Po ishodnomy faily (namel) sozdaem rabo4ii (name2)'
write (7,*)' Ishodnii fail'
if(DA_NET(name1,.true.))then
write(*,*)' Rabo4ii fail'
write(7,*)' Rabo4ii fail'
if (DA_NET(name2,.false.))then
call ISH_RAB (name1,name2)
endif
endif
call upor (name2)
309 CONTINUE
goto 999
401 CONTINUE
if (DA_NET(name2,.true.)) then
write(*,406)name2
write(7,406)name2
406 format (3x,'Rabo4ii fail _ ',A30/)
call VIVARAB (name2)
end if
409 CONTINUE
goto 999
501 CONTINUE
write(*,*)' Rabo4ii fail'
write (7,*)' Rabo4ii fail'
if (DA_NET(name,.true.)) then
write(*,*)' ykazanna9 data i nomer reisa'
write(7,*)' ykazanna9 data i nomer reisa'
if( DA_NET (name1,.false.))then
call RAZBIVKA (name,name1)
call upor1 (name1)
write (*,*)'prosmotrim rtot fail? (y/n)'
write(7,*)'prosmotrim rtot fail? (y/n)'
read(*,'(A1)')c
write(7,'(A1)')c
if(c=='y' .or. c=='Y') then
write (*,506)name1
write(7,506)name1
506 format (2x, ' sformirovannii fail - ',A30/)
call VIVREZ(name1)
end if
end if
end if
509 CONTINUE
601 CONTINUE
if(DA_NET (name,.true.)) then
write(*,206)name
write(7,206)name
call VIVREZ(name)
end if
go to 999
701 CONTINUE
if(DA_NET (name,.true.)) then
write(*,206)name
write(7,206)name
call VIVREZ(name)
end if
go to 999
801 CONTINUE
write(*,*)' a modet bit...'
write(*,*)' a modet bit...'
999 write(*,*)' prodolgim? (y/n)'
write(7,*)' prodolgim? (y/n)'
read(*,'(A1)')c
write(7,'(25x,A1)')c
if (c=='y' .or. c=='Y') go to 1
8 CONTINUE
write (*,*)' Programma okon4ena.'
write (7,*)' Programma okon4ena.'
close(7)
pause
stop
end

Logical function DA_NET (fname,pr)
character fname*30,c
logical pr,ff,b,p
integer d
11 CONTINUE
c='n'
b=.false.
write(*,*)'vvedit polnoe im9 faila (<=30 simvolov)'
write(7,*)'vvedit polnoe im9 faila (<=30 simvolov)'
Read (*,'(A30)') fname
Write (7,'(5x,A30)') fname
INQUIRE (file=fname, exist=ff)
If(ff.and. .not.pr.or. .not.ff .and.pr) then
b=.true.
if (pr) then
write(*,*)'Takogo daila net'
write(7,*)'takogo daila net'
else
write(*,*)' Takoi fail yge est'
write(7,*)'Takoi fail yge est'
endif
write(*,*) ' vvedete drygoe im9? (y/n) '
write(7,*) ' vvedete drygoe im9? (y/n) '
read(*,*) c
write(7, ' (31x,A1/) ' )
endif
if(c=='y' .or. c=='y' ) goto 11
19 CONTINUE
If (b) then
If(.Not.Pr) then
Write(*,*) ' 4to bydem delat? '
Write(*,*) ' 1 – zatrem syshestvyushii fail '
Write(*,*) ' 2 – vihod '
Write(*,*) ' vvedite nomer otveta '
Read(*,*) d
Write(7,*) ' 4to bydem delat? '
Write(7,*) ' 1 – zatrem syshestvyushii fail '
Write(7,*) ' 2 – vihod '
Write(7,*) ' vvedite nomer otveta '
Write(7, ' (31x, A1/) ' ) c
If (d==1) then
Open (unit=1, file=fname)
Close (unit=1,status='delete')
P=.true.
Else
P=.false.
Endif
Else
P=.false.
Endif
Else
P=.true.
Endif
DA_NET=p
Return
end
Subroutine SOZD (fname)
character fname*30,fmt*55
character c, fio*15, nom*5,date*8
integer k,kol,ves
common /d1/fmt
open (1,file=fname,access='sequential',form='formatted',status='new')
write (1,'(A55)')fmt
k=0
11 CONTINUE
k=k+1
write(*,26) k
26 format (3x,'vvodim',I2,' zapis:')
write(*,*)' vvedite FIO (<=15 simvolov)'
read(*,'(A15)')fio
write(*,*)' vvedite nomer reisa(= xxxxx) '
read(*,'(a5)')nom

write (*,*)' vvedite daty vileta po formaty xx.xx.xx (god.mes9c.den)'
read(*,'(A8Z)')date
write(*,*)' vvedite koli4estvo veshei (<=xx)'
read(*,'(I2)')KOL
write(*,*)' vvedite obshii ves veshei(<=xxx)'
read(*,'(i3)')ves
Write (1,fmt) fio,nom,date,kol,ves
write(*,*) ' Eshe zapisA? (y/n)'
read(*,'(A1)')c
if (c=='y'.or.c=='Y') go to 11
19 COnTINUE
close(1,status='keep')
write(*,*) fname,k
write(7,*) fname,k
66 format (2x,'Fail ',A30,' sformirovan. V nem',I2,' zna4ashih zapisey'/&
& 3x,'perva9 zapis - format dannih')
pause
return
end

subroutine VIVISH (fname)
character fname*30,fmt*55
character fio*15, nom*5,date*8
integer kol,ves
open (1,file=fname,access=' sequential',form='formatted',status='old')
read (1,'(A55)')fmt
write(*,*) ' perva9 zapis:'
write (*,'(A55)')fmt
write(*,*)
write(*,76)
write(7,*)' perva9 zapis (format):'
write(7,'(A55)')fmt
write(7,*)
write(7,76)
76 format (3x,'fio',15x,'nomer',2x,'data',3x,'kol-vo veshei',1x,' obhii ves'/)
11 CONTINUE
read (1,fmt, end=19) fio,nom,date,kol,ves
write(*,fmt)fio,nom,date,kol,ves
write(7,fmt)fio,nom,date,kol,ves
go to 11
19 CONTINUE
close(1,status='keep')
pause
return
end

subroutine ISH_RAB(fnm1,fnm2)
character fnm1*30,fnm2*30,fmt*55
character fio*15,nom*5,date*8
integer k,kol,ves

open (1,file=fnm1,access='sequential', form=' formatted', status='old')
read(1,'(A55)') fmt
open (2,file=fnm2,access='direct', form=' unformatted', status='new',recl=80)
k=0
write (2) k
do while (.not.eof(1))
k=k+1
read(1,fmt) fio,nom,date,kol,ves
write(2)fio,nom,date,kol,ves
end do
19 CONTINUE
write(2,rec=1)k
write(*,16)fnm1,fnm2,k
write(7,16)fnm1,fnm2,k
16 format(3x,'po faily',A30,' sozdan fail ',A30/&
&4x,'v nem',I2,'zna4ashih zapisey (+perva9->kol-vo zna4. zap)')
pause
close(1)
close(2)
return
end

subroutine VIVRAB (fname)
character fname*30,fmt*55
character fio*15, nom*5,date*8
integer k,i,kol,ves
common /d1/fmt

open(2,FILE=fname,access='direct',form=' unformatted',status='oid',recl=80)
read(2) K
WRITE(*,166) K
166 format (2x,'perva9 zapis:'/1x,I3/2x,'ostalnie sm. tablicy nige'/)
write(*,76)
WRITE(7,166)k
write(7,76)
76 format (3x,'fio',15x,'nomer',2x,'data',3x,'kol-vo veshei',1x,'obshii ves'/)
do i=1,k,1
read(2) fio,nom,date,kol,ves
write(*,fmt) fio,nom,date,kol,ves
write(7,fmt) fio,nom,date,kol,ves
enddo
pause
close(2)
return
end

subroutine Upor(fname)
character fname*30
character fio1*15,fio2*15, nom1*5,nom2*5,date1*8,date2*8
integer k,i,kol1,kol2,ves1,ves2,h
logical p
open (2,file=fname,access='direct',form='unformatted',status='old',rec1=80)
read(2) k
h=k
do while (h>1)
h=h/2
m=k-h+1
11 CONTINUE
p=.true.
do i=2,m
read (2,rec=i) fio1,nom1,date1,kol1,ves1
read(2,rec=i+h) fio2,nom2,date2,kol2,ves2
if(date1>date2)then
p=.false.
read (2,rec=i+h) fio1,nom1,date1,kol1,ves1
read(2,rec=i) fio2,nom2,date2,kol2,ves2
else
if (date1.EQ.date2.end.nom1.GT.nom2) then
p=.false.
read (2,rec=i+h) fio1,nom1,date1,kol1,ves1
read(2,rec=i) fio2,nom2,date2,kol2,ves2
end if
end do
if(.not.p) go to 11
19 CONTINUE
end do
close(2)
return
end

subroutine UPOR1 (fname)
character fname*30
character fmt2*50,fio1*15,fio2*15
integer k,i,kol1,kol2,ves1,ves2
logical p
open(2,file=fname,access='direct',form='formatted',status='old',rec1=80)
read (2,'(A50)')fmt2
read(2,'(I3)')k
11 CONTINUE
p=.true.
do i=3,k+1
read (2,fmt2, rec=i) fio1,kol1,ves1
read (2,fmt2, rec=i+1) fio2,kol2,ves2
if(fio1>fio2)then
p=.false.
write(2,fmt2,rec=i+1)fio1,kol1,ves1
write(2,fmt2,rec=i)fio2,kol2,ves2
endif
enddo
if(.not.p)goto 11
close(2)
return
end

subroutine RAZBIVKA(nm,nm1)
character*30 nm1,nm,fmt2*50,fio*15,nom*5,date*8,nom1*5,date1*8
integer i,k,nk,ves,kol
common /d2/fmt2
open(4,file=nm,access='direct',form='unformatted',status='old',recl=80)
open(1,file=nm1,access='direct',form='formatted',status='new',rec1=80)
nk=0
write(*,*)'vvedite nomer reisa(= xxxxx) '
write(7,*)'vvedite nomer reisa(= xxxxx) '
read(*,'(a5)')nom1
write(7,'(a5)') nom1
write(*,*)' vvedite daty vileta poformaty xx.xx.xx (god.mes9c.den)'
write(7,*)' vvedite daty vileta poformaty xx.xx.xx (god.mes9c.den)'
read(*,'(A8)')date1
write(7,'(A8)')date1
write(1,'(A50)')fmt2
write(1,'(I3)')nk
read(4)k
do i=1,k,1
read (4) fio,nom,date,kol,ves
if (date1==date.and.nom1==nom) then
write(1,fmt2) fio,kol,ves
nk=nk+1
endif
end do
write(1,'(I3)',rec=2)nk
close(1)
close(4)
write(*,26) nm,nm1,nk
write(7,26) nm,nm1,nk
26 format (2x,'fail',A30,'razbit na odin fail'/2x,'1-',A30,&
&'v nem',I3,' zapisei'//)
Pause
Return
End

Subroutine VIVERZ (nm)
Character fmtx*50, nm*30, fio*15
Integer k, kol, ves
Open (1,file=nm,access='direct', form=' farmatted', status='old', recl=80)
Read(1,'(A50)')fmtx
Read(1, ' (13) ')k
If (k==0) then
Write(*,*) ' Uvi, takih net! '
Write(7,*) ' Uvi, takih net! '
Else
Write(*,66)
Write(7,66)
66 format (3x,'fio',15x,'kol-vo veshei',1x,'obshii ves' /)
Do while (.not.eof (1) )
Read(1, fmtx) fio,kol,ves
Write(*,fmtx) fio,kol,ves
Write (7,fmtx) fio, kol,ves
Enddo
19 CONTINUE
Pause
Endif
Close (1)
Return
End

Subroutine VIVERZZ (nm)
Character fmtx*50, nm*30, fio*15
Integer k, kol, ves , kol1, ves1
Kol1=1
Ves1=30
Open(1, file=nm, access='direct' , form=' formatted ' , status=' old ', recl=80 )
Read(1,'(A50)') fmtx
Read (1,'(13)') k
If (k==0) then
Write(*,*) ' Uvi, takih net! '
Write(7,*) ' Uvi, takih net! '
Else
Write(*, 66)
Write(7,66)
66 format (3x, 'fio'/)
Do while (.not.eof (1) )
Read(1, fmtx) fio,kol,ves
If (kol1==kol.and.ves>=ves1) then
Write(*,fmtx) fio
Write(7, fmtx) fio
Endif
Enddo
19 CONTINUE
Pause
Endif
Close (1)
Return
End