C23456789012345678901234567890123456789012345678901234567890123456789012 ************************************************************************ * XTAL DATABASE OF DR. A.CHANDRASEKARAN * * LAST MODIFIED: 09-JAN-04 * This was tested with Microsoft Fortran Powerstation 4.0 * If you need the Executable file, Please contact me. ************************************************************************ INTEGER OPT1 1 WRITE(*,*)' ' WRITE(*,*) ' ' WRITE(*,*)'SELECT OPTION [0=SEARCH, 1=ADD, 9=EXIT]:' READ(*,'(I1)')OPT1 IF(OPT1.NE.0.AND.OPT1.NE.1.AND.OPT1.NE.9) GOTO 1 IF(OPT1.EQ.0) CALL SEARCH IF(OPT1.EQ.1) CALL ADD IF(OPT1.EQ.9) STOP ' ' GOTO 1 STOP END ************************************************************************ SUBROUTINE ADD INTEGER NUMBER,DATA,SOLV,ZZ,EXPO,OVER,NATOMS,NEW REAL SIZE1,SIZE2,SIZE3,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL,MOS,TT REAL THETA CHARACTER DATED*9,REQ*20,GROUP*20,SOLV1*20,FORMULA*40,SOLV2*20 CHARACTER CORRECT*1,COLOR*20,SPGR*10,COMM*70,CDATE*9,SFORM*38 CHARACTER FILEDB*18,CCODE*10,DATAQ*20 WRITE(*,*)'PLEASE PROVIDE THE FOLLOWING INFORMATION.' NEW=0 CALL GETNUMBER(NEW,NUMBER) C WRITE(*,*)'REQUEST NUMBER:' C READ(*,*)NUMBER WRITE(*,*)'CRYSTAL CODE [A10]:' READ(*,'(A10)')CCODE WRITE(*,*)'WORKED DATE [DD-MMM-YY]:' READ(*,'(A9)')DATED CALL DATE(CDATE) WRITE(*,*)'REQUESTER [A20]:' READ(*,'(A20)')REQ WRITE(*,*)'GROUP [A20]:' READ(*,'(A20)')GROUP WRITE(*,*)'SOLVENT USED [A20]:' READ(*,'(A20)')SOLV1 WRITE(*,*)'STRUCTURAL DESCRIPTION EX: Ph3P or BENZIL. [A37]:' READ(*,'(A37)')SFORM WRITE(*,*)'FORMULA (LEAVE SOLVENT, IF ANY) [A40]:' READ(*,'(A40)')FORMULA WRITE(*,*)'SOLVENT NAME,RATIO (if present) OR "NO":' READ(*,'(A20)')SOLV2 WRITE(*,*)'EXPECTED STRUCTURE?(Y/N):' READ(*,'(A1)')CORRECT WRITE(*,*)'TOTAL CORRECT NON-HYDROGENS:' READ(*,*)NATOMS 10 WRITE(*,*)'DATA REQUEST CODE [1,2,3,4]:' READ(*,*)DATA IF(DATA.LT.1.OR.DATA.GT.4) GOTO 10 C DATE CODE 1 = "FOR IDENTIFICATION ONLY" C DATE CODE 2 = "FOR PUBLICATION (NOT ACTA CRYST.)" C DATE CODE 3 = "FOR PUBLICATION (IN ACTA CRYST.)" C DATE CODE 4 = "LOW TEMPERATURE DATA" 11 WRITE(*,*)'STRUCTURE SOLUTION REQUEST CODE [1,2,3]:' READ(*,*)SOLV IF(SOLV.LT.1.OR.SOLV.GT.3) GOTO 11 C STR. SOLUTION CODE 1 = "DO NOT SOLVE" C STR. SOLUTION CODE 2 = "SOLVE WITH REQUESTER" C STR. SOLUTION CODE 3 = "SOLVE WITHOUT REQUESTER" WRITE(*,*)'CRYSTAL SIZE (DIVISONS OR MM):' READ(*,*)SIZE1,SIZE2,SIZE3 IF(SIZE1.GT.2.0.OR.SIZE2.GT.2.0.OR.SIZE3.GT.2.0) THEN SIZE1=SIZE1*0.025 SIZE2=SIZE2*0.025 SIZE3=SIZE3*0.025 ELSE ENDIF WRITE(*,*)'CRYSTAL COLOR [A20]:' READ(*,'(A20)')COLOR WRITE(*,*)'CELL DIMENSIONS:' READ(*,*)AA,BB,CC,AL,BE,GA RAD=1.0/57.29577951 COSA=cos(AL*RAD) COSB=cos(BE*RAD) COSG=cos(GA*RAD) VOLUME=1.0-(COSA**2)-(COSB**2)-(COSG**2)+2.0*COSA*COSB*COSG VOLUME=sqrt(VOLUME) VOLUME=VOLUME*AA*BB*CC WRITE(*,*)'SPACE GROUP [Ex. P-1, P21/C, P212121]:' READ(*,'(A10)')SPGR WRITE(*,*)'NUMBER OF MOLECULES (Z):' READ(*,*)ZZ ATVOL=VOLUME/NATOMS/ZZ WRITE(*,*)'MOSAICITY:' READ(*,*)MOS WRITE(*,*)'EXPOSURE TIME PER FRAME (Seconds):' READ(*,*)EXPO WRITE(*,*)'OVERFLOW TIME (Seconds):' READ(*,*)OVER WRITE(*,*)'TOTAL DATA COLLECTION TIME [HOURS]:' READ(*,*)TT WRITE(*,*)'THETA RANGE (Degrees):' READ(*,*)THETA WRITE(*,*)'DATA QUALITY [GOOD...BAD or Rint, %Obs, Rsig] [A20]:' READ(*,'(A20)')DATAQ WRITE(*,*)'COMMENT? [A70]:' READ(*,'(A70)')COMM NDB=(NUMBER-1)/1000 FILEDB='C:\XTALDB\XTALDB.'//CHAR(NDB+65) OPEN(UNIT=1,FILE=FILEDB,STATUS='UNKNOWN',ACCESS='APPEND') WRITE(1,110)NUMBER,CCODE,REQ,GROUP,DATED,CDATE 110 FORMAT(I5,1X,A10,1X,2A20,1X,A9,1X,A9) WRITE(1,120)SOLV1,SOLV2,SFORM 120 FORMAT(A20,A20,A38) WRITE(1,130)FORMULA,CORRECT,DATA,SOLV,SIZE1,SIZE2,SIZE3 130 FORMAT(A40,4X,A1,1X,I1,I3,3F6.3) WRITE(1,140)COLOR,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL 140 FORMAT(A20,6F7.2,F8.1,F5.1) WRITE(1,150)SPGR,ZZ,MOS,EXPO,OVER,THETA,TT,DATAQ 150 FORMAT(A10,I3,F5.2,I4,I5,2F5.1,2X,A20) WRITE(1,160)NUMBER,COMM 160 FORMAT('#',I5,'# ',A70) C WRITE(1,'(I5,1X,A10,1X,2A20,1X,A9,1X,A9)')NUMBER,CCODE,REQ,GROUP C 1,DATED,CDATE C WRITE(1,'(A20,A20,A38)')SOLV1,SOLV2,SFORM C WRITE(1,'(A40,4X,A1,1X,I1,I3,3F6.3)')FORMULA,CORRECT,DATA,SOLV, C 1SIZE1,SIZE2,SIZE3 C WRITE(1,'(A20,6F7.2,F8.1,F5.1)')COLOR,AA,BB,CC,AL,BE,GA,VOLUME, C 1ATVOL C WRITE(1,'(A10,I3,F5.2,I4,I5,2F5.1,2X,A20)')SPGR,ZZ,MOS,EXPO,OVER C 1,THETA,TT,DATAQ C WRITE(1,'(A1,I5,A2,A70)')'#',NUMBER,'# ',COMM NEW=NEW+1 CLOSE (UNIT=1) RETURN END ************************************************************************ SUBROUTINE SEARCH INTEGER NUMBER,DATA,SOLV,ZZ,EXPO,OVER,NOPT,NHIT,NTHIT INTEGER NCCODE REAL SIZE1,SIZE2,SIZE3,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL,MOS,TT REAL THETA,A1,A2,A3,A4,A5,A6 REAL ZA,ZB,ZC,ZAL,ZBE,ZGA,C1,C2,C3,C4,C5,C6 CHARACTER DATED*9,REQ*20,GROUP*20,SOLV1*20,FORMULA*40,SOLV2*20 CHARACTER CORRECT*1,COLOR*20,SPGR*10,COMM*70,CDATE*9,SFORM*38 CHARACTER FILE1*18,CCODE*10,CFORM*40,WORDS*78,DATAQ*20,SCODE*10 CHARACTER ECODE*1 C ******** START THE OPTIONS ****** CALL GETOPTION(NOPT) IF (NOPT.EQ.98) CALL SUMMARY1 IF (NOPT.EQ.99) CALL SUMMARY IF (NOPT.EQ.3) CALL SPGROUP C CELL SEARCHING OPTION IF(NOPT.EQ.0) THEN WRITE(*,*)'PLEASE GIVE THE CELL PARAMETERS:' READ(*,*)ZA,ZB,ZC,ZAL,ZBE,ZGA CALL SETCELL(ZA,ZB,ZC,ZAL,ZBE,ZGA,C1,C2,C3,C4,C5,C6) ELSE ENDIF C FORMULA SEARCHING OPTION IF(NOPT.EQ.1) THEN WRITE(*,*)'PLEASE USE ALL CAPITAL LETTERS!' WRITE(*,*)' ' WRITE(*,*)'GIVE THE FORMULA [C10 H20 P2 CL2] or [P2]:' READ(*,'(A40)')CFORM ENDIF C FORMULA SEARCHING OPTION IF(NOPT.EQ.2) THEN WRITE(*,*)'PLEASE USE ALL CAPITAL LETTERS!' WRITE(*,*)' ' WRITE(*,*)'GIVE THE CRYSTAL CODE:' READ(*,'(A10)')SCODE WRITE(*,*)'DO YOU WANT EXACT SEARCH? [Y/N]:' READ(*,'(A1)')ECODE IF(ECODE.EQ.'y'.OR.ECODE.EQ.'Y') NCCODE=1 ENDIF C ******** START OF THE SEARCH LOOP ****** OPEN(UNIT=2,FILE='XTALDB.OUT',STATUS='UNKNOWN') NHIT=0 NUMBER=1 1 NDB1=(NUMBER-1)/1000 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='OLD',ERR=100) 10 READ(1,'(I5,1X,A10,1X,2A20,1X,A9,1X,A9)',END=100)NUMBER,CCODE, 1REQ,GROUP,DATED,CDATE READ(1,'(A20,A20,A38)')SOLV1,SOLV2,SFORM READ(1,'(A40,4X,A1,1X,I1,I3,3F6.3)')FORMULA,CORRECT,DATA,SOLV, 1SIZE1,SIZE2,SIZE3 READ(1,'(A20,6F7.2,F8.1,F5.1)')COLOR,AA,BB,CC,AL,BE,GA,VOLUME, 1ATVOL READ(1,'(A10,I3,F5.2,I4,I5,2F5.1,2X,A20)')SPGR,ZZ,MOS,EXPO,OVER, 1THETA,TT,DATAQ READ(1,'(1X,I5,1X,A70)')NUMBER,COMM NUM=NUM+1 C CELL SEARCHING OPTION IF(NOPT.EQ.0) THEN CALL SETCELL(AA,BB,CC,AL,BE,GA,A1,A2,A3,A4,A5,A6) D1=ABS(A1-C1) D2=ABS(A2-C2) D3=ABS(A3-C3) D4=ABS(A4-C4) D5=ABS(A5-C5) D6=ABS(A6-C6) IF(D1.LE.0.5.AND.D2.LE.0.5.AND.D3.LE.0.5.AND.D4.LE.0.8.AND.D5. 1LE.0.8.AND.D6.LE.0.8) THEN NHIT=NHIT+1 GOTO 201 ELSE ENDIF ELSE ENDIF C FORMULA SEARCHING OPTION, FOR THE REQUESTED STRING ONLY !!! IF(NOPT.EQ.1) THEN DO 200 NF=1,LEN_TRIM(FORMULA) IF(FORMULA(NF:NF-1+LEN_TRIM(CFORM)).EQ.CFORM) THEN NHIT=NHIT+1 GOTO 201 ELSE ENDIF 200 CONTINUE ELSE ENDIF C CRYSTAL CODE SEARCH (TRUNCATED) IF(NOPT.EQ.2.AND.NCCODE.NE.1) THEN IF(CCODE(1:LEN_TRIM(SCODE)).EQ.TRIM(SCODE)) THEN NHIT=NHIT+1 GOTO 201 ELSE ENDIF ELSE ENDIF C CRYSTAL CODE SEARCH (EXACT) IF(NOPT.EQ.2.AND.NCCODE.EQ.1) THEN IF(CCODE.EQ.SCODE) THEN NHIT=NHIT+1 GOTO 201 ELSE ENDIF ELSE ENDIF 900 CONTINUE IF (NUMBER.EQ.(NDB1+1)*1000) GOTO 1 GOTO 10 GOTO 1 C ******** END OF THE SEARCH LOOP ****** C ************* OUTPUT WRITING SECTION **************** 201 CONTINUE WRITE(2,110)NUMBER,CCODE 110 FORMAT('Xtal Number: 'I5,16X,'; Xtal Code: ',A10) WRITE(2,111)REQ,GROUP 111 FORMAT('Requester: ',A20,' ; Group: ',A20) WRITE(2,112)DATED,CDATE 112 FORMAT('Date Worked : ',A9,' ; Date Entered: ',A9) WRITE(2,120)SFORM 120 FORMAT('Structual Description: ',A38) WRITE(2,121)SOLV1,SOLV2 121 FORMAT('Solvent Used: ',A20,'; Solvent Found?: ',A20) WRITE(2,130)FORMULA,CORRECT 130 FORMAT('Formula: ',A40,'; Expected?: ',A1) WRITE(2,131)SOLV,DATA 131 FORMAT('Structure Solution Request Code: ',I1,'; Data Request C 1ode: ',I1) WRITE(2,132)SIZE1,SIZE2,SIZE3, COLOR 132 FORMAT('Xtal Dimensions:',3F6.3,'; Xtal Color: ',A20) WRITE(2,140)AA,BB,CC,AL,BE,GA 140 FORMAT('Cell Parameters: ',6F7.2) WRITE(2,141)VOLUME,ATVOL 141 FORMAT('Cell Volume: ',F8.1,13X,'; Atomic Volume: ',F5.1) WRITE(2,150)SPGR,ZZ,MOS 150 FORMAT('Space Group: ',A10,'; Z =',I3,' ; Mosaicity: ',F5.2) WRITE(2,151)EXPO,OVER 151 FORMAT('Exposure Time (sec/frame): ',I4,3X,'; Overflow Time: ', 1I4) WRITE(2,152)THETA,TT,DATAQ 152 FORMAT('Theta Max.: ',F5.1,'; Total Hour:',F4.1,';Data Quality', 1'(Rint,%Obs,Rsig): ',A20) WRITE(2,160)COMM 160 FORMAT('Comment: ',A70) WRITE(2,170) 170 FORMAT(78('*')) GOTO 900 100 CONTINUE NTHIT=NTHIT+NHIT WRITE(*,*)'TOTAL NUMBER OF DATA IN THE DATABASE :',NUM WRITE(*,*)'HITS WITH CLOSE MATCH IN THIS SEARCH :',NHIT WRITE(*,*)'TOTAL HITS IN ALL SEARCHES MADE NOW :',NTHIT CLOSE (UNIT=1) CLOSE (UNIT=2) NUM=0 RETURN END ************************************************************************ C ******** ANNUAL SUMMARY LOOP ****** SUBROUTINE SUMMARY INTEGER NUMBER,DATA,SOLV,ZZ,EXPO,OVER,NTOTAL,NID(50),NTID INTEGER NGDATA(50),NGGOOD(50),NSOLV(50),NSOLVE REAL SIZE1,SIZE2,SIZE3,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL,MOS,TT REAL THETA CHARACTER DATED*9,REQ*20,GROUP*20,SOLV1*20,FORMULA*40,SOLV2*20 CHARACTER CORRECT*1,COLOR*20,SPGR*10,COMM*70,CDATE*9,SFORM*38 CHARACTER FILE1*18,CCODE*10,DATAQ*20, TODAY*9, CMON*3 CHARACTER*20 GRNAME(50),YEARASK*2 NUMBER=1 NG=1 NTOTAL=1 CALL DATE(TODAY) YEARASK=TODAY(8:9) WRITE(*,'(A,$)')' GIVE THE MONTH (use "ALL" for FULL Year) [Defa 1ult="ALL"]:' READ(*,'(A3)')CMON IF(CMON.EQ.' ') CMON='ALL' WRITE(*,*)'PLEASE PROVIDE THE YEAR FOR SUMMARY (Ex. 00 or XX):' WRITE(*,'(A,$)')' [Default=Current Year]: ' READ(*,'(A2)')YEARASK IF(YEARASK.EQ.' ') YEARASK=TODAY(8:9) IF(YEARASK.EQ.'xx') YEARASK='XX' 1 NDB1=(NUMBER-1)/1000 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='OLD',ERR=100) 10 READ(1,'(I5,1X,A10,1X,2A20,1X,A9,1X,A9)',END=100)NUMBER,CCODE, 1REQ,GROUP,DATED,CDATE READ(1,'(A20,A20,A38)')SOLV1,SOLV2,SFORM READ(1,'(A40,4X,A1,1X,I1,I3,3F6.3)')FORMULA,CORRECT,DATA,SOLV, 1SIZE1,SIZE2,SIZE3 READ(1,'(A20,6F7.2,F8.1,F5.1)')COLOR,AA,BB,CC,AL,BE,GA,VOLUME, 1ATVOL READ(1,'(A10,I3,F5.2,I4,I5,2F5.1,2X,A20)')SPGR,ZZ,MOS,EXPO,OVER, 1THETA,TT,DATAQ READ(1,'(1X,I5,1X,A70)')NUMBER,COMM NTOTAL=NTOTAL+1 IF(DATED(8:9).NE.YEARASK.AND.YEARASK.NE.'XX') GOTO 10 IF(DATED(4:6).NE.CMON.AND.CMON.NE.'ALL') GOTO 10 NYEAR=NYEAR+1 C SUMMARY OPTION DO 300 JG=1,NG IF (GROUP.EQ.GRNAME(JG)) THEN NGDATA(JG)=NGDATA(JG)+1 IF(CORRECT.EQ.'Y'.OR.CORRECT.EQ.'y') NGGOOD(JG)=NGGOOD(JG)+1 IF(SOLV.GT.1.AND.DATA.NE.1) NSOLV(JG)=NSOLV(JG)+1 IF(DATA.EQ.1) NID(JG)=NID(JG)+1 GOTO 201 ELSE ENDIF 300 CONTINUE GRNAME(NG)=GROUP NGDATA(NG)=1 IF(CORRECT.EQ.'Y'.OR.CORRECT.EQ.'y') NGGOOD(NG)=1 IF(SOLV.GT.1.AND.DATA.NE.1) NSOLV(NG)=NSOLV(NG)+1 IF(DATA.EQ.1) NID(NG)=NID(NG)+1 NG=NG+1 201 CONTINUE IF (NUMBER.EQ.(NDB1+1)*1000) GOTO 1 GOTO 10 C ******** END OF THE SEARCH LOOP ****** 100 CONTINUE OPEN(UNIT=2,FILE='XTALDB.SUM',STATUS='UNKNOWN') WRITE(2,400)NTOTAL-1 400 FORMAT(' TOTAL STRUCTURES IN THE DATABASE :',I4) WRITE(2,401)CMON,YEARASK,NYEAR 401 FORMAT(' TOTAL STRUCTURES FOR -',A3,'- 20',A2,' :',I4/) WRITE(2,402)CMON,YEARASK 402 FORMAT(' GROUPWISE STATISTICS (FOR -',A3,'- 20',A2,'):') WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,404) 404 FORMAT(' GROUP PI TOTAL CORRECT OTHER* SOL 1UTION# IDENTITIY&') WRITE(2,*)'----------------------------------------------------- 1---------------------' DO 500 JG=1,NG-1 NGREST=NGDATA(JG)-NGGOOD(JG) NGOOD=NGOOD+NGGOOD(JG) NREST=NREST+NGREST NSOLVE=NSOLVE+NSOLV(JG) NTID=NTID+NID(JG) WRITE(2,410)GRNAME(JG),NGDATA(JG),NGGOOD(JG),NGREST,NSOLV(JG), 1 NID(JG) 410 FORMAT(2X,A20,2X,I3,6X,I3,6X,I3,10X,I3,8X,I3) 500 CONTINUE WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,420)NYEAR,NGOOD,NREST,NSOLVE,NTID 420 FORMAT(' TOTAL',18X,I3,6X,I3,6X,I3,10X,I3,8X,I3) WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,*)'( Data Collection Charges = $25 x TOTAL)' WRITE(2,*)'(* Unexpected & Unpredicted Structures)' WRITE(2,*)'(# Structure Solution requests; $25 Each)' WRITE(2,*)'(& Identity requests; includes Structure Solution)' CLOSE (UNIT=1) STOP ' ' END ************************************************************************ C ******** GROUP SUMMARY LOOP ****** SUBROUTINE SUMMARY1 INTEGER NUMBER,DATA,SOLV,ZZ,EXPO,OVER,NTOTAL,NID(50),NTID INTEGER NUDATA(50),NUGOOD(50),NGOOD,NSOLV(50),NSOLVE INTEGER CHARGE,CHARGE1,CHARGE2,NCHARGE REAL SIZE1,SIZE2,SIZE3,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL,MOS,TT REAL THETA CHARACTER DATED*9,REQ*20,GROUP*20,SOLV1*20,FORMULA*40,SOLV2*20 CHARACTER CORRECT*1,COLOR*20,SPGR*10,COMM*70,CDATE*9,SFORM*38 CHARACTER FILE1*18,CCODE*10,DATAQ*20,TODAY*9 CHARACTER*20 REQNAME(50),GRNAME,CMON*3,CMON2*3,YEARASK*2 NUMBER=1 NG=1 NTOTAL=1 CHARGE=0 CHARGE1=25 CHARGE2=25 CALL DATE(TODAY) C GROUP SUMMARY OPTION WRITE(*,*)'PLEASE USE ALL CAPITAL LETTERS!' WRITE(*,*)' ' WRITE(*,'(A,$)')' GIVE THE GROUP NAME:' READ(*,'(A20)')GRNAME WRITE(*,'(A,$)')' GIVE THE MONTH (use "ALL" for FULL Year) [Defa 1ult="ALL"]:' READ(*,'(A3)')CMON IF(CMON.EQ.' ') CMON='ALL' WRITE(*,'(A,$)')' GIVE THE SECOND MONTH (OPTIONAL):' READ(*,'(A3)')CMON2 OPEN(UNIT=2,FILE='XTALDB'//GRNAME(1:2)//'.SUM',STATUS='UNKNOWN') WRITE(*,'(A,$)')' PLEASE PROVIDE THE YEAR FOR SUMMARY (Ex. 00): 1 [Default: Current Year]:' READ(*,'(A2)')YEARASK IF(YEARASK.EQ.' ') YEARASK=TODAY(8:9) TODAY=TODAY(1:7)//YEARASK IF(CMON.EQ.'ALL') THEN WRITE(2,398)TODAY(8:9),GRNAME 398 FORMAT(' GROUP SUMMARY FOR THE YEAR 20',A2,', FOR Prof. ',A20/) ELSE WRITE(2,397)CMON,CMON2,TODAY(8:9) 397 FORMAT(' X-ray facility charges for -',A3,'-',A3,'-20',A2) WRITE(2,399)CMON,CMON2,GRNAME 399 FORMAT(' GROUP SUMMARY FOR THE MONTH(S) -',A3,'-',A3,', FOR Prof 1. ',A20) WRITE(2,*)'(A Bill will be sent later)' WRITE(2,*)' ' ENDIF WRITE(2,*)' ' WRITE(2,*)'THE FOLLOWING WORK WAS DONE DURING THIS TIME:' WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,*)' # CODE REQUESTER DATE DAT 1A & SOLUTION CHARGES' WRITE(2,*)'----------------------------------------------------- 1---------------------' 1 NDB1=(NUMBER-1)/1000 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='OLD',ERR=100) 10 READ(1,'(I5,1X,A10,1X,2A20,1X,A9,1X,A9)',END=100)NUMBER,CCODE, 1REQ,GROUP,DATED,CDATE READ(1,'(A20,A20,A38)')SOLV1,SOLV2,SFORM READ(1,'(A40,4X,A1,1X,I1,I3,3F6.3)')FORMULA,CORRECT,DATA,SOLV, 1SIZE1,SIZE2,SIZE3 READ(1,'(A20,6F7.2,F8.1,F5.1)')COLOR,AA,BB,CC,AL,BE,GA,VOLUME, 1ATVOL READ(1,'(A10,I3,F5.2,I4,I5,2F5.1,2X,A20)')SPGR,ZZ,MOS,EXPO,OVER, 1THETA,TT,DATAQ READ(1,'(1X,I5,1X,A70)')NUMBER,COMM IF(GROUP.NE.GRNAME) GOTO 10 NTOTAL=NTOTAL+1 IF(DATED(7:9).NE.TODAY(7:9)) GOTO 10 NYEAR=NYEAR+1 IF(DATED(4:6).NE.CMON.AND.DATED(4:6).NE.CMON2.AND.CMON.NE.'ALL') 1 GOTO 10 NMONTH=NMONTH+1 C IF(DATA.GT.1.AND.SOLV.GT.1) CHARGE=CHARGE2 NCHARGE=NCHARGE+CHARGE1+CHARGE WRITE(2,299)NMONTH,CCODE,REQ,DATED,CHARGE1,CHARGE 299 FORMAT(I3,2X,A10,2X,A20,2X,A9,3X,'$',I2' + $',I2) CHARGE=0 C SUMMARY OPTION DO 300 JG=1,NG IF (REQ.EQ.REQNAME(JG)) THEN NUDATA(JG)=NUDATA(JG)+1 IF(CORRECT.EQ.'Y'.OR.CORRECT.EQ.'y') NUGOOD(JG)=NUGOOD(JG)+1 IF(SOLV.GT.1.AND.DATA.NE.1) NSOLV(JG)=NSOLV(JG)+1 IF(DATA.EQ.1) NID(JG)=NID(JG)+1 GOTO 201 ELSE ENDIF 300 CONTINUE REQNAME(NG)=REQ NUDATA(NG)=1 IF(CORRECT.EQ.'Y'.OR.CORRECT.EQ.'y') NUGOOD(NG)=1 IF(SOLV.GT.1.AND.DATA.NE.1) NSOLV(NG)=NSOLV(NG)+1 IF(DATA.EQ.1) NID(NG)=NID(NG)+1 NG=NG+1 201 CONTINUE IF (NUMBER.EQ.(NDB1+1)*1000) GOTO 1 GOTO 10 C ******** END OF THE SEARCH LOOP ****** 100 CONTINUE WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,*)'TOTAL CHARGES =',NCHARGE WRITE(2,*)'----------------------------------------------------- 1---------------------' NCHARGE=0 WRITE(2,*)' ' WRITE(2,400)NTOTAL-1 400 FORMAT(' TOTAL STRUCTURES IN THE DATABASE :',I4) WRITE(2,401)TODAY(8:9),NYEAR 401 FORMAT(' TOTAL STRUCTURES FOR YEAR 20',A2,' :',I4) IF(CMON.EQ.'ALL') THEN WRITE(2,407)TODAY(8:9) 407 FORMAT(' USERWISE STATISTICS (FOR THE YEAR 20',A2,'):') ELSE WRITE(2,411)CMON,CMON2,NMONTH 411 FORMAT(' TOTAL STRUCTURES FOR MONTH(S) -',A3,'-',A3,':',I4/) WRITE(2,402)CMON,CMON2 402 FORMAT(' USERWISE STATISTICS (FOR MONTH(S) -',A3,'-',A3,'):') ENDIF WRITE(2,*)'[Excludes: Discount Data ($10 each) and Recollection 1($25 each)]' WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,403) 403 FORMAT(' GROUP PI TOTAL CORRECT OTHER* SOL 1UTION# IDENTITIY&') WRITE(2,*)'----------------------------------------------------- 1---------------------' DO 500 JG=1,NG-1 NUREST=NUDATA(JG)-NUGOOD(JG) NGOOD=NGOOD+NUGOOD(JG) NREST=NREST+NUREST NSOLVE=NSOLVE+NSOLV(JG) NTID=NTID+NID(JG) WRITE(2,410)REQNAME(JG),NUDATA(JG),NUGOOD(JG),NUREST,NSOLV(JG), 1 NID(JG) 410 FORMAT(2X,A20,2X,I3,6X,I3,6X,I3,10X,I3,8X,I3) 500 CONTINUE WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,420)NMONTH,NGOOD,NREST,NSOLVE,NTID 420 FORMAT(' TOTAL',18X,I3,6X,I3,6X,I3,10X,I3,8X,I3) WRITE(2,*)'----------------------------------------------------- 1---------------------' WRITE(2,*)'(Data Collection Charges = $25 x TOTAL)' WRITE(2,*)'(Discount Data = Cell-Determination-Only, $10 Each)' WRITE(2,*)'(# Structure Solution charges; $25 Each)' WRITE(2,*)'(* Unexpected & Unpredicted Structures)' WRITE(2,*)'(& Identity requests; includes Structure Solution)' CLOSE (UNIT=1) STOP ' ' END ************************************************************************ ************************************************************************ C ******** SPACE GROUP SUMMARY LOOP ****** SUBROUTINE SPGROUP INTEGER NUMBER,DATA,SOLV,ZZ,EXPO,OVER,NTOTAL INTEGER NSPG(250) REAL SIZE1,SIZE2,SIZE3,AA,BB,CC,AL,BE,GA,VOLUME,ATVOL,MOS,TT REAL THETA CHARACTER DATED*9,REQ*20,GROUP*20,SOLV1*20,FORMULA*40,SOLV2*20 CHARACTER CORRECT*1,COLOR*20,SPGR*10,COMM*70,CDATE*9,SFORM*38 CHARACTER FILE1*18,CCODE*10,DATAQ*20 CHARACTER*10 SPG(250) NUMBER=1 NG=1 NTOTAL=1 1 NDB1=(NUMBER-1)/1000 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='OLD',ERR=100) OPEN(UNIT=2,FILE='XTALDB.SUM',STATUS='UNKNOWN') 10 READ(1,'(I5,1X,A10,1X,2A20,1X,A9,1X,A9)',END=100)NUMBER,CCODE, 1REQ,GROUP,DATED,CDATE READ(1,'(A20,A20,A38)')SOLV1,SOLV2,SFORM READ(1,'(A40,4X,A1,1X,I1,I3,3F6.3)')FORMULA,CORRECT,DATA,SOLV, 1SIZE1,SIZE2,SIZE3 READ(1,'(A20,6F7.2,F8.1,F5.1)')COLOR,AA,BB,CC,AL,BE,GA,VOLUME, 1ATVOL READ(1,'(A10,I3,F5.2,I4,I5,2F5.1,2X,A20)')SPGR,ZZ,MOS,EXPO,OVER, 1THETA,TT,DATAQ READ(1,'(1X,I5,1X,A70)')NUMBER,COMM NTOTAL=NTOTAL+1 C SUMMARY OPTION DO 300 JG=1,NG IF (SPGR.EQ.SPG(JG)) THEN NSPG(JG)=NSPG(JG)+1 GOTO 201 ELSE ENDIF 300 CONTINUE SPG(NG)=SPGR NSPG(NG)=1 NG=NG+1 201 CONTINUE IF (NUMBER.EQ.(NDB1+1)*1000) GOTO 1 GOTO 10 C ******** END OF THE SEARCH LOOP ****** 100 CONTINUE WRITE(2,*)' ' WRITE(2,400)NTOTAL-1 400 FORMAT(' TOTAL STRUCTURES IN THE DATABASE :',I4/) WRITE(2,*)'---------------------------------------------------' WRITE(2,*)' ' WRITE(2,*)'THE FOLLOWING IS THE SPACE GROUP SUMMARY:' WRITE(2,*)'---------------------------------------------------' WRITE(2,403) 403 FORMAT(' NUMBER SPACE GROUP # OF OBSERVATIONS') WRITE(2,*)'---------------------------------------------------' DO 500 JG=1,NG-1 WRITE(2,410)JG,SPG(JG),NSPG(JG) 410 FORMAT(2X,I3,7X,A10,I10) 500 CONTINUE WRITE(2,*)'---------------------------------------------------' CLOSE (UNIT=1) STOP ' ' END ************************************************************************ SUBROUTINE GETNUMBER(NEW,NT) INTEGER NUMBER,NEW,NT CHARACTER TEST*1,FILE1*18 NDB1=0 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='UNKNOWN') 10 READ(1,'(A1,I5)',ERR=10,END=100)TEST,NUM IF(TEST.EQ.'#') NUMBER=NUM IF(NUMBER.GT.1000) THEN NDB1=(NDB1-1)/1000 FILE1='C:\XTALDB\XTALDB.'//CHAR(NDB1+65) OPEN(UNIT=1,FILE=FILE1,STATUS='OLD',ERR=100) GOTO 10 ELSE ENDIF GOTO 10 100 CONTINUE NT=NUMBER+NEW+1 WRITE(*,'(A24,I6)')' ASSIGNED DATA NUMBER IS',NT CLOSE (UNIT=1) RETURN END ************************************************************************ SUBROUTINE GETOPTION(NOPT) INTEGER NOPT 10 WRITE(*,*)'AVAILABLE OPTIONS ARE:' WRITE(*,*)' CELL [0]' WRITE(*,*)' FORMULA [1]' WRITE(*,*)' CRYSTAL CODE [2]' WRITE(*,*)' SPACE GROUPS [3]' WRITE(*,*)' GROUP SUMMARY [98]' WRITE(*,*)'ANNUAL SUMMARY [99]' WRITE(*,*)' STOP [9]' C WRITE(*,*)' SOLVENT [4]' C WRITE(*,*)' COLOR [5]' C WRITE(*,*)' VOLUME [6]' C WRITE(*,*)' Z [8]' WRITE(*,*)' ' WRITE(*,*)'PLEASE CHOOSE ONE OPTION:' READ(*,*)NOPT IF(NOPT.EQ.9) STOP IF((NOPT.LT.0.OR.NOPT.GT.9).AND.NOPT.LT.90) GOTO 10 IF(NOPT.LE.3.OR.NOPT.EQ.98.OR.NOPT.EQ.99) RETURN WRITE(*,*)'THIS OPTION NOT YET AVAILABLE !' GOTO 10 END ************************************************************************ SUBROUTINE SETCELL(AA,BB,CC,AL,BE,GA,A1,A2,A3,A4,A5,A6) REAL AA,BB,CC,AL,BE,GA,A1,A2,A3,A4,A5,A6,TEMP1,TEMP2 A1=AA A2=BB A3=CC A4=AL A5=BE A6=GA IF (A1.GT.A2) THEN TEMP1=A1 TEMP2=A4 A1=A2 A2=TEMP1 A4=A5 A5=TEMP2 ELSE ENDIF IF (A1.GT.A3) THEN TEMP1=A1 TEMP2=A4 A1=A3 A3=TEMP1 A4=A6 A6=TEMP2 ELSE ENDIF IF (A2.GT.A3) THEN TEMP1=A2 TEMP2=A5 A2=A3 A3=TEMP1 A5=A6 A6=TEMP2 ELSE ENDIF if(a4.lt.90.0) a4=180.0-a4 if(a5.lt.90.0) a5=180.0-a5 if(a6.lt.90.0) a6=180.0-a6 RETURN END ************************************************************************