C PROGRAM BMAX7.FT C ---------------- C S ENTRY BMAX7 S CPAGE 2 S BMAX7,BLOCK 2 C C PETER LEMKIN C IMAGE PROCESSING UNIT, DCBD C NATIONAL CANCER INSTITUTE C NATIONAL INSTITUTES OF HEALTH C 9000 ROCKVILLE PIKE C BETHESDA, MD. 20014 C C FEB 25 1977 /REMOVED TTYCTL C FEB 7, 1977 C JAN 23, 1977 C JAN 21, 1977 C JAN 20, 1977 C OCT 14, 1976 C OCT 7, 1976 C SEPT 30, 1976 C SEPT 16, 1976 C SEPT 15, 1976 C SEPT 13, 1976 C SEPT 8, 1976 C SEPT 7, 1976 C AUG 28, 1976 C C PURPOSE C ------- C BMAX7 IS THE PICTURE PROCESSING PACKAGE FOR BMON1 C IT CONTAINS THE FOLLOWING FUNTIONS: C IVAL FUNCTION C ---- -------- C 1 OPENFILE C 2 SETFSREL,, C 3 COMPUTE GENSYM OF (IB = name, IC = value) and C return it in FC; FC=IB[1 FOR 2] & CVOS(IC); C 4 FOR ALL FILESPECS IN CD AREA C DO FILESPEC(I)===FC NEQ "GENSYM" C THEN RETURN WITH FC UNCHANGED, C ELSE IGENSYM(2)<==IGENSYM(2)+1, C FC=GENSYM(IGENSYM(1),IGENSYM(2); C C OPDEFS C ------ S OPDEF TADI 1400 S OPDEF DCAI 3400 C C S OPDEF DISP1 6435 S OPDEF DISP2 6436 C S OPDEF HPR 6320 S OPDEF VPR 6322 S OPDEF HPL 6360 S OPDEF VPL 6362 C S OPDEF SWAB 7431 S OPDEF SWBA 7447 S OPDEF SHL 7413 S OPDEF ASR 7415 S OPDEF DAD 7443 S OPDEF DST 7445 S OPDEF DPIC 7573 S OPDEF CAM 7621 S OPDEF MUY 7405 S OPDEF DVI 7407 C S OPDEF CLAMQ 7621 S OPDEF MQA 7501 S OPDEF MQL 7421 S OPDEF BSW 7002 C C DIMENSION N(8),JB(3),JC(3) EQUIVALENCE (JB,B),(JC,C) C [0] DISPATCH SUM=0.0 C FIRST SAVE THE /C SWITCH IC3=ICNUM(3) KOMP=ISW(3) C J=0 K=0 GOTO(1,2,3,4),IVAL C S \2047, RETRN BMAX7 C [1] /OPENFI/ C OPEN THE FILE SPECIFIED IN THE OUTPUT SPEC C IF NO OUTPUT FILE IS SPECIFIED, THEN OPEN UP THE LPT: 1 CONTINUE C IF THE SPOOLER IS ALREADY OPEN, THEN CLOSE IT BEFORE OPENING IT AGAIN S TAD \IOUTSPOOL S SNA CLA S JMP \102 /OK C C CLOSE IT FIRST CALL OCLOSE C 102 DEVICE='LPT' C S TAD \KOUTFILE S SNA CLA S JMP \101 C C OK, GO OPEN UP THE DSK: DEVICE=GETDEVICE(KOUTFILE) S CALL 1,FAD S ARG \KOUTFILE S CALL 1, STO S ARG \FILE C 101 IOUTSPOOL=1 CALL OOPEN(DEVICE,FILE) GOTO 2047 C [2] SETFSBM, , 2 DO 201 I=1,2 IZ=12+I IA(I)=LSAVE(IZ,(IBM1+1)) 201 IB(I)=LSAVE(IZ,(IBM2+1)) C C C [2.1] "SET RELATIVE" C [H<==(H-X2)+X1; V<==(V-Y2)+Y1] S\202, HPR S DCA \IC IC=IBCD(IC,0) C S VPR S DCA \IZ IZ=IBCD(IZ,0) S TAD \IZ S DCA \IC# C ICNUM=(IC-IB) + IA C C COMPUTE: IZ=(IC(2)-IB(2))-IA(2) S TAD \IB# S CIA S TAD \IC# S TAD \IA# S DCA \IZ C C C [2.2] SETFS X,Y,(OPT HSIZE, VSIZE) IXPOSITION=IBCD(ICNUM,-1) IYPOSITION=IBCD(IZ,-1) C S TAD \IXPOSITION S HPL S TAD \IYPOSITION S VPL C C GOTO 2047 C [3] COMPUTE GENSYM OF (IB NAME, IC VALUE) C COMPUTE THE CONCATINATION OF C FC= IB[1 FOR 2] & CVOS(IC); 3 CONTINUE S JMS GENSYM GOTO 2047 C C C [4] FOR ALL FILESPEC IN CD AREA C DO FILESPEC(I)==>FC, C IF THE SYMBOL IN FC="GENSYM" C THEN RETURN WITH NO CHANGE TO FC; C ELSE C RETURN FC<==GENSYM(IGENSYM(1),IGENSYM(2)') C C C TEST IF FC="GENSYM" C C DO IT FOR OUTPUT AND 5 INPUT FILESPECS 4 B='GENSYM' C DO 401 IX1=1,6 C COMPUTE FILESPEC OFFSET J C NOTE: IN COMMON IT IS STORED AS KOUTFILE(4),KDEVIN(5),KOUTFILE(20) C THUS FOR THE INPUT FILES ADD ANOTHER 5. IX2=5 S CLA CMA S TAD \IX1 S SNA CLA S DCA \IX2 /IX2=0 C C COMPUTE: J=4*(IX1-1) S CLA CMA S TAD \IX1 S CLL RAL S CLL RAL S TAD \IX2 /OFFSET FOR KINFILE PART S DCA \J C C TEST THE IX1'TH FILESPEC DO 402 IX2=1,3 402 JC(IX2)=KOUTFILE(J+IX2) C C C IF B=C C THEN MATCH; C DO 450 N=1,3 IF(JB(N)-JC(N))401,450,401 450 CONTINUE C C MATCH NOW INCREMENT AND FETCH THE GENSYM S INC \IGENSYM# /IGENSYM(2) S NOP S TAD \IGENSYM# S DCA \IC IB=IGENSYM C S JMS GENSYM C C STORE BACK INTO FILESPEC C=FC DO 403 IX2=1,3 403 KOUTFILE(J+IX2)=JC(IX2) C 401 CONTINUE GOTO 2047 C **************************************************** C *SUBROUTINE G E N S Y M C **************************************************** C C COMPUTE GENSYM OF (IB NAME, IC VALUE) C COMPUTE THE CONCATINATION OF C FC= IB[1 FOR 2] & CVOS(IC); C C S CPAGE 3 S RGENSYM, JMP I GENSYM S GENSYM, 0 /ENTRY C N=IC C C COPY THE FIRST CHARS JC=IB C C C COMPUTE THE DECIMAL DIGITS S TAD \N S MQL S CPAGE 2 S DVI S 1750 /D1000 S DCA \N /SAVE REMAINDER S MQA S DCA \I14 /QUOTIENT C S TAD \N S MQL S CPAGE 2 S DVI S 144 /D100 S DCA \N S MQA S DCA \I13 C S TAD \N S MQL S CPAGE 2 S DVI S 12 /D10 S DCA \I11 S MQA S DCA \I12 C C C C STUFF THEM INTO JC. S TAD \I14 S BSW S TAD \I13 /100'S S TAD (6060 S DCA \JC# /JC(2) C S TAD \I12 /10'S S BSW S TAD \I11 S TAD (6060 S DCA \N JC(3)=N FC=C S JMP RGENSYM C C C POINTERS C -------- S PLINE, \LINE S PBUF1, \IBUF1 S PBUF2, \IBUF2 S PBUF3, \IBUF3 S PBUF4, \IBUF4 C S PI10, \I10 /POINTER S PN, \N /POINTER S CPAGE 2 S BUFF, BLOCK 2 C C C END