C C C SUBROUTINE PBCRT(MAT,CMAT,BMAT,ADMIN,RADMIN,NAME,NFR,N1) VIRTUAL MAT(64,64),CMAT(64,64) LOGICAL*1 CMAT,BMAT(64,64),ADMIN(512),RADMIN(500),NAME(14),NUM NBLK = NFR*4 + 1 NAME(3) = '1' NAME(9) = 'R' NAME(10) = 'T' NUM = '1' C C COMPILE WITH /D IF YOU REQUIRE CHOICE C OF DISK TO STORE PBACK BUFFERS C D WRITE(7,905)NBLK D905 FORMAT(//'$WHICH DISC UNIT FOR PB BUFFER (',I4,' BLOCKS))? ') D READ(5,906)NAME(3) D906 FORMAT(A1) D907 WRITE(7,910) D910 FORMAT(//,'$ENTER STUDY TYPE-RT,HG OR CP D 1AND NO.(1 TO 4 TO CREATE P1 - P4 FOR MR JOIN) ') D READ(5,911)NAME(9),NAME(10),NUM,NUM D911 FORMAT(4A1) D IF (NUM.LE.'0'.OR.NUM.GT.'4') GOTO 907 NAME(12)='G' NAME(13)='P' NAME(14)='B' WRITE(7,210)(NAME(I),I=5,10),NAME(3),NUM 210 FORMAT(//,' TO PLAYBACK PHASE IMAGE BUFFER TYPE - PB ' 1,6A1,',',A1,' OR P',A1,//) CALL ASSIGN(2,NAME,14,'NEW','NC') DEFINE FILE 2(NBLK,256,U,N2) C C SET UP FOR P?.GPB C NAME(3) = '0' NAME(5) = 'P' NAME(6) = NUM NAME(7) = ' ' NAME(8) = ' ' NAME(9) = ' ' NAME(10) = ' ' CALL ASSIGN(3,NAME,14,'NEW','NC') DEFINE FILE 3(NBLK,256,U,N3) C NFR=24 !EXTRACTED FROM SVAR06 N=1 N2=1 N3 = 1 L1="54 L2="20 K=124 DO 77 I=1,24 IF(ADMIN(I).EQ.0)GO TO 78 RADMIN(K)=ADMIN(I) K=K+1 77 CONTINUE 78 RADMIN(K-1)="054 RADMIN(K)="040 J=K+1 DO 79 I=54,62 RADMIN(J)=ADMIN(I) J=J+1 79 CONTINUE RADMIN(J-1)="054 RADMIN(J)="040 WRITE(2'N2)NFR,N,RADMIN WRITE(3'N3)NFR,N,RADMIN WRITE(7,303) 303 FORMAT(//' PROCESSING-PLEASE WAIT - APPROX 2 MIN'/) C reread phase image data from SA N1=2 DO 920 I=1,64,4 920 READ(1'N1)((MAT(K,J),J=1,64),K=I,I+3) CALL CLOSE(1) C set all pixels in phase image to same value ICT = 0 DO 30 I=1,64 DO 30 J=1,64 IF(MAT(I,J).EQ.0)GO TO 29 BMAT(I,J)=2 ICT = ICT + 1 GO TO 30 29 BMAT(I,J)=0 30 CONTINUE RNFR = NFR DO 300 LZ=1,NFR DO 100 I=1,64 DO 100 J=1,64 IF(MAT(I,J).EQ.0)GO TO 100 IPH=INT(1.+(RNFR*FLOAT(MAT(I,J)-1.)/6283.)) IF(IPH.NE.LZ)GO TO 100 BMAT(I,J)=7 100 CONTINUE K=65 DO 95 I=1,64 K=K-1 DO 95 J=1,64 CMAT(J,I)=BMAT(K,J) 95 CONTINUE DO 94 I = 1,64 DO 94 J = 1,64 94 BMAT(I,J) = CMAT(I,J) N = 2048 CALL PACK(BMAT,BMAT,N) DO 200 I = 1,32,8 WRITE(2'N2)((BMAT(K,J),K=1,64),J=I,I+7) 200 WRITE(3'N3)((BMAT(K,J),K=1,64),J=I,I+7) C C reset pixels in amp image C DO 250 I=1,64 DO 250 J=1,64 IF(MAT(I,J).EQ.0)GO TO 249 BMAT(I,J)=2 GO TO 250 249 BMAT(I,J)=0 250 CONTINUE 300 CONTINUE CALL CLOSE(2) CALL CLOSE(3) RETURN END