C C SUBROUTINE CSTUDY C C FUNCTION C TO CREATE N GAMMA GATED STUDIES FROM C A STUDY ADDRESSED BY SAVE AREA "0" C C WRITTEN BY G.GUELF1 JUL-81 C C CALL CSTUDY(NFILES,ISTUDY,ICHANS,MDOFF,NFRAME,TITLE,NEWSTY) C C C WHERE C C NFILES NUMBER OF STUDIES TO BE CREATED C ISTUDY I/O CHANNEL FOR ORIGINAL DATA C ICHANS I/O CHANNEL FOR EACH FILE C MDOFF STARTING BLOCK NO. OF GAMMA DATA C NFRAME NO. OF FRAME IN STUDY C TITLE NEW STUDY TITLE C NEWSTY NEW STUDY RAD50 NAME C C SUBROUTINE CSTUDY(NFILES,ISTUDY,ICHANS,MDOFF,NFRAME,TITLE,NEWSTY) DIMENSION IQQ(256),ICHANS(1) INTEGER*2 SY1,SY3 LOGICAL*1 BIQ(512),SNAME(12),TITLE(12) EQUIVALENCE (IQQ,BIQ,STNAME) REAL *8 STNAME,SVAR00,NEWSTY DATA SVAR00/12RSVASVAR00SYS/ DATA SY3/3RSY3/,SY1/3RSY1/ C C OPEN SAVE AREAS 0 C CALL CRTFIL(SVAR00,53,ISAVE0,1) C C GET STUDY NAME C ITP = 0 CALL READW(256,IQQ,ITP,ISAVE0) C C OPEN STUDY FOR DATA EXTRACTION C CALL CRTFIL(STNAME,ISTYLN,ISTUDY,1) ITP = 0 CALL READW(256,IQQ,ITP,ISTUDY) C C CHECK IF STUDY DYNAMIC C C WRITE(7,400)BIQ(190),IQQ(117),IQQ(107) 400 FORMAT(O6,2I6) IF (BIQ(190).LE.0.AND.IQQ(117).EQ.1)GOTO 9 WRITE(7,200) 200 FORMAT(' STUDY MUST BE A DYNAMIC AND HAVE ONLY ONE GROUP'//) DO 8 I = 1,10 J = I - 1 CALL CLOSEC(J) 8 CALL IFREEC(J) CALL BGAMMA('') 9 NFRAME = IQQ(116) MDOFF = IQQ(107) C C CREATE NEW STUDY FILES C ITP = 0 CALL READW(256,IQQ,ITP,ISAVE0) CALL CLOSEC(ISAVE0) CALL IFREEC(ISAVE0) C C CHECK GAMMA DEVICE GE SY3 THEN DIRECT TO SY1 C IF (IQQ(1).GE.SY3) IQQ(1) = SY1 CALL R50ASC(12,STNAME,SNAME) DO 10 I = 1,NFILES 4 IF (SNAME(12).NE.'9') GOTO 5 SNAME(12) = "57 IF (SNAME(11).EQ.'9') SNAME(11) = "57 IF (SNAME(11).NE.'9') SNAME(11) = SNAME(11) + 1 5 SNAME(12) = SNAME(12) + 1 CALL IRAD50(12,SNAME,NEWSTY) CALL CRTFIL(NEWSTY,NUMBKS,ICHANS(I),1) CALL CLOSEC(ICHANS(I)) CALL IFREEC(ICHANS(I)) IF (NUMBKS.EQ.-2) GOTO 6 C C FILE EXITS GET NEW EXTENSION NUMBER C GOTO 4 C C CREATE NEW FILE C 6 IBLKS = ISTYLN CALL CRTFIL(NEWSTY,IBLKS,ICHANS(I),0) IRD = 0 IWT = 0 DO 7 II = 1,MDOFF-1 CALL READW(256,IQQ,IRD,ISTUDY) C IF (II.EQ.1) IQQ(118) = "031061 IF (II.EQ.1) CALL HDCHG(IQQ,TITLE) CALL WRITW(256,IQQ,IWT,ICHANS(I)) 7 CONTINUE C TITLE(12) = TITLE(12) + 1 10 CONTINUE RETURN END