C V1A Edit #7 3-Aug-84 Autor: -tf- File: CPWOUT.FOR C C C P W O U T . F O R C C H.P. STOEHREL C C *** V1 *** 17-DEC-81 C *** V2 *** 21-DEC-81 CORR. C *** V3 *** 5-APR-82 CORR. C *** V4 *** 25-JUL-84 CORR. C C SUBROUTINE SETS UP FCB'S AND WRITES A BLOCK OUT C SUBROUTINE CPWOUT (IB,IDIR,IBLK,ISLO,IFCB,NAME,IFCTL,OPENFL,IERR) C C IFCTL : FILE CONTROL BLOCK HANDLING C = 0 OPEN FILE (NEW FCB) C = 1 CONTINUE WRITING C =-1 CLOSE FILE C OPENFL : TRUE: FILE HAS BEEN OPENED C FALSE: FILE NOT YET OPENED C INTEGER*2 IB(2),IDIR(2),IBLK(2),ISLO(2),IFCB(2),NAME(2) LOGICAL*1 OPENFL C IERR=0 ! HOPEFULLY C C>>>>>> C TYPE 99,IFCTL C99 FORMAT(/' IFCTL=',I3) C>>>>>> C IF (IFCTL.NE.0.AND.OPENFL.EQ..TRUE.) GOTO 100 C C OPEN NEW FILE : SET UP FCB C IEXT=0 ! EXTENT NB=0 ! BLOCK COUNT C>>>>>>> C PAUSE ' CPFCB : NEW' C>>>>>>> CALL CPFCB (IFCB,ISLO,NAME,INDX,IERF) ! SET UP NEW FCB OPENFL=.TRUE. IF (IERF.EQ.1) GOTO 90 C C>>>>>> C TYPE 97,INDX C97 FORMAT(/' INDX=',I3) C>>>>>> C C 100 DO 20 NR=2,242 ! LOOK FOR EMPTY BLOCKS IF (IBLK(NR).EQ.0) GOTO 30 20 CONTINUE 90 TYPE 91 91 FORMAT (/' ?CPMRT-W-CP/M Volume full'/) IERR=1 RETURN ! NO MORE BLOCKS - ERROR C 30 IBLK(NR)=NR ! MARK BLOCK AS USED C C>>>>>>> D TYPE 991,NR D991 FORMAT(' WRITING BLOCK#',I4) C>>>>>>> C C>>>>>>> C TYPE 899,(IB(LL),LL=1,1024) C899 FORMAT(X,A1$) C>>>>>>> C NB=NB+1 ! COUNT BLOCKS CALL CPWR (IB,NR) ! WRITE BLOCK IFCB(NB+16)=NR ! ENTER BLOCK# IN FCB IF (NB.LT.16) GOTO 200 ! 16 BLOCKS PER FCB C C MORE THAN 16 BLOCKS :SET UP FOR EXTENT C ENTER FCB IN DIRECTORY C IFCB(16)=NB*8 ! NOT REALLY NO.OF RECORDS !! IFCB(13)=IEXT ! SET EXTENT IEXT=IEXT+1 ! COUNT EXTENT C DO 70 J=1,32 IDIR(INDX+J)=IFCB(J) ! ENTER FCB INTO DIRECTORY C>>>>>> C TYPE 917,J,IDIR(INDX+J),IDIR(INDX+J) C917 FORMAT(/' ****SETUP EXTENT'/,I5,2X,A1,O8) C>>>>>> 70 CONTINUE NB=0 ! RESET BLOCK COUNT C CALL CPFCB (IFCB,ISLO,NAME,INDX,IERF) ! SET UP NEW FCB IF (IERF.EQ.1) GOTO 90 C C ENTER FCB IN DIRECTORY C 200 IF (IFCTL.NE.-1) GOTO 240 C C>>>>>>> C PAUSE ' CPFCB : CLOSE' C TYPE 97,INDX C>>>>>> IFCB(16)=NB*8 ! NOT REALLY NO.OF RECORDS !! IFCB(13)=IEXT ! SET EXTENT C DO 220 J=1,32 IDIR(INDX+J)=IFCB(J) ! ENTER FCB INTO DIRECTORY C>>>>>> C TYPE 919,J,IDIR(INDX+J),IDIR(INDX+J) C919 FORMAT(/' **** AFTER CLOSE'/,I5,2X,A1,O8) C>>>>>> 220 CONTINUE NB=1 ! RESET BLOCK COUNT C C>>>>>> C TYPE 901,(IDIR(K),K=1,1024) C901 FORMAT(X,16O4) C>>>>>> C CALL CPDIR(4,NAME,IRNO,IDIR,IBLK,ISLO,IFCB) C 240 RETURN END