C-----PROFILE PREPARATION PROGRAM MAIN 0 C-----THIS PROGRAM PREPARES THE PROFILE DATA FOR THE REFINEMENT PROGRAM MAIN 10 C-----THE OUTPUT IS SAVED ON DISK (OR TAPE) UNIT 2 MAIN 20 C-----FORTRAN IV VERSION, DECEMBER 1970. MAIN 30 C-----H.M.RIETVELD, REACTOR CENTRUM NEDERLAND, PETTEN(N.H.), THE NETHERLMAIN 40 C-----MODIFIED SEPT 1972 BY A.W.HEWAT, MATERIALS PHYSICS, UKAEA &ARWE-L C YALFA,YSTAP,YOMEG,YPOS REPLACE IALFA,ISTAP,IOMEG,IPOS AWHFEB87 c C ****************************** TIMER for Mac **************************** c SUBROUTINE TIMER(SECONDS) c INTEGER*4 CLOCK_TICKS,CLOCK_TICKS2,SECONDS c COMMON/CPUTIM/START_TIME,CLOCK_TICKS c CALL TIME(SECONDS) c RETURN c END c C *******************************************************************MAIN 50 C * VARIABLE DIMENSIONS *MAIN 60 C * N=MAXIMUM NUMBER OF REFLECTIONS *MAIN 70 C * B=MAXIMUM NUMBER OF BACKGROUND POSITIONS *MAIN 80 C * L=MAXIMUM NUMBER OF EXCLUDED REGIONS *MAIN 90 C * I=MAXIMUM NUMBER OF PROFILE INTENSITIES *MAIN 100 C * ***** *MAIN 110 C * ARRAYS WITH VARIABLE DIMENSIONS *MAIN 120 C * BAK(B) HW(N) HWL(N) *MAIN 130 C * ICODE(N) IH(3,N) IHIGH(L) *MAIN 140 C * IHIGHJ(I) INDEX(N) LOW(L) *MAIN 150 C * LOWJ(I) LL(N) M(N) *MAIN 160 C * PLOR(N) POS(B) TL(N) *MAIN 170 C * TT(N) YY(I) T(N) *MAIN 180 C *******************************************************************MAIN 190 C ****************** MAIN 200 C * PRESENT VALUES * MAIN 210 C * N = 4889 * MAIN 220 C * B = 199 * MAIN 230 C * L = 49 * MAIN 240 C * I =8000 * MAIN 250 C ****************** MAIN 260 C **************************** MAIN 270 C CHANGES FOR VAX-8600 C * UNIT 6 = 'PROF1.PRI' * MAIN 280 C * UNIT 5 = YOUR DATA FILE * MAIN 290 C * UNIT 2 = TEMPORARY DATA SET ON DISK * MAIN 300 C **************************** MAIN 320 DIMENSION A(3,3),BAK(199),DUMPA(500), MAIN 330 1HW(4889),HWL(4889),ICODE(4889),IH(3,4889),IHIGH(49),IHIGHJ(8000), MAIN 340 1INDEX(4889),LOW(49),LOWJ(8000),LL(4889),NH(3),M(4889),PLOR(4889), MAIN 350 1POS(199),TEXT(20),TL(4889),TT(4889),YY(8000),T(4889),IW(8000) MAIN 360 INTEGER*4 CLOCK_TICKS,CLOCK_TICKS2,SECONDS CHARACTER*20 FILEN COMMON/CPUTIM/START_TIME,CLOCK_TICKS COMMON DUMPA, II,NKEY,TEXT,NTEXT,KSTART MAIN 370 C DATA NOX/3HNO./,FILEN/' '/ NOX='NO.' Write(*,1009) 1009 FORMAT(' File name for profile preparation ? eg PROF.PRE ') read(*,1019) FILEN 1019 FORMAT(A) IF(FILEN.EQ.' ') FILEN='PROF.PRE' Write(*,1029) 1029 FORMAT(' Please Wait....Profile data being prepared.'/) c C cpu timer *** A.Hewat 23 Feb 89 *** SECONDS=0 CALL TIMER(SECONDS) IF(SECONDS.NE.0) START_TIME=SECONDS C cpu timer *** A.Hewat 23 Feb 89 *** C OPEN(UNIT=2,FILE='PROF1.BIN',STATUS='UNKNOWN',FORM='UNFORMATTED') OPEN(UNIT=5,FILE=FILEN,STATUS='OLD') OPEN(UNIT=6,FILE='PROF1.LIS',STATUS='NEW') C-----WHEN ANGLES IN 1/10000 CYCLES, FOLLOWING STATEMENT SHOULD READ: MAIN 390 C-----RAD=3.14159265359/10000. MAIN 400 RAD=3.14159265359/36000. MAIN 410 C-----READ IN PROBLEM INDENTIFICATION AND PRINT TITLE PLUS INDENTIFICATIMAIN 420 1000 WRITE( 6,1) MAIN 430 READ( 5,4)TEXT MAIN 450 WRITE( 6,100)TEXT MAIN 460 C-----ZEROIZE DUMP ARRAYS MAIN 470 DO 5 I=1,500 MAIN 480 5 DUMPA(I)=0. MAIN 490 C-----READ FILE NAME MAIN 500 READ( 5,4)X MAIN 510 C-----SEARCH FOR EXISTING FILE NAME MAIN 520 NKEY=0 MAIN 530 C ****************************************************************************** C THE FOLLOWING CARDS COMMENTED OUT FOR RHEL SYSTEM C 102 READ(2)DUMPA MAIN 540 C 105 IF(DUMPA(2).EQ.X)GOTO 103 MAIN 550 C WRITE(1)DUMPA MAIN 560 C IF(DUMPA(1).NE.-12345.)GOTO 102 MAIN 570 C IF(NKEY)106,106,107 MAIN 580 C 106 BACKSPACE 2 MAIN 590 C GOTO 108 MAIN 600 C 107 REWIND 1 MAIN 610 C REWIND 2 MAIN 620 C 109 READ(1)DUMPA MAIN 630 C IF(DUMPA(1).EQ.-12345.)GOTO 108 MAIN 640 C WRITE(2)DUMPA MAIN 650 C GOTO 109 MAIN 660 C 103 NKEY=1 MAIN 670 C 104 READ(2)DUMPA MAIN 680 C IF(ABS(DUMPA(1)).NE.12345.)GOTO 104 MAIN 690 C GOTO 105 MAIN 700 C 108 REWIND 1 MAIN 710 C END OF THIS FIELD OF COMMENTING OUT C ****************************************************************************** C-----PRINT FILE NAME MAIN 720 IF(NKEY.EQ.0)WRITE( 6,110)X MAIN 730 IF(NKEY.EQ.1)WRITE( 6,111)X MAIN 740 II=0 MAIN 750 CALL DUMP(12345.) MAIN 760 CALL DUMP(X) MAIN 770 C-----READ IN CELL DIMENSIONS,WAVELENGTH,ZEROPOINT AND HALFWIDTH PARAMS.MAIN 780 CALL CELL(A) MAIN 790 READ( 5,6)SLABDA,ZERO,P,Q,R,WLIMIT MAIN 800 WRITE( 6,80)SLABDA MAIN 810 WRITE( 6,81)ZERO MAIN 820 WRITE( 6,82) MAIN 830 WRITE( 6,83)P,Q,R MAIN 840 IF(WLIMIT.GT.0.) WRITE( 6,99) WLIMIT 99 FORMAT(//'****WARNING**** WEIGHTS OF STRONG POINTS ARE LIMITED BY 1FACTOR WLIM/(Y+WLIM) WHERE WLIM=',F8.0,'******'/) SLABDA=0.25*SLABDA*SLABDA MAIN 850 C-----READ IN BACKGROUND MAIN 860 I=1 MAIN 870 10 READ( 5,117)POS(I),BAK(I) MAIN 880 IF(POS(I)+100.)8,9,8 MAIN 890 8 I=I+1 MAIN 900 GOTO 10 MAIN 910 9 NB=I-1 MAIN 920 WRITE( 6,84) MAIN 930 WRITE( 6,85)(POS(I),BAK(I),I=1,NB) MAIN 940 READ( 5,7)N,IHIGH(1) MAIN 950 C-----WHEN N IS NEGATIVE,THE LOWER AND UPPER LIMITS OF THOSE PARTS OF MAIN 960 C-----THE DIAGRAM,WHICH HAVE TO BE EXCLUDED FROM THE CALCULATIONS,HAVE MAIN 970 C-----TO BE READ IN. MAIN 980 NCU=0 MAIN 990 IF(N)11,12,12 MAIN1000 11 I=1 MAIN1010 18 IF(I-1)13,14,13 MAIN1020 14 LOW(I)=-N MAIN1030 IHIGH(I)=-IHIGH(I) MAIN1040 GOTO 15 MAIN1050 13 READ( 5,7)LOW(I),IHIGH(I) MAIN1060 LOW(I)=-LOW(I) MAIN1070 IHIGH(I)=-IHIGH(I) MAIN1080 15 IF(LOW(I)-100)16,17,16 MAIN1090 16 I=I+1 MAIN1100 GOTO 18 MAIN1110 17 NCU=I-1 MAIN1120 WRITE( 6,87) MAIN1130 WRITE( 6,88)(LOW(I),IHIGH(I),I=1,NCU) MAIN1140 READ( 5,7)N MAIN1150 12 IF(NCU.EQ.0)WRITE( 6,86) MAIN1160 C-----READ IN DENOMINATORS OF MILLER INDICES MAIN1170 READ( 5,19)(NH(I),I=1,3) MAIN1180 WRITE( 6,20) MAIN1190 WRITE( 6,21)(NH(I),I=1,3) MAIN1200 C-----READ REFLECTIONS AND CALCULATE FOR EACH THE LORENTZ MAIN1210 C-----FACTOR,THE POSITION AND THE HALFWIDTH. MAIN1220 DO 22 I=1,N MAIN1230 READ( 5,23)ICODE(I),(IH(J,I),J=1,3),M(I) MAIN1240 D=0. MAIN1250 DO 68 J=1,3 MAIN1260 DO 68 K=J,3 MAIN1270 68 D=A(J,K)*IH(J,I)*IH(K,I)/(NH(J)*NH(K))+D MAIN1280 D=SLABDA*D MAIN1290 IF(D.GE.1.) D=0.99 PLOR(I)=1./(2.*D*SQRT(1.-D)) MAIN1300 TAN=SQRT(D/(1.-D)) MAIN1310 TL(I)=ATAN(TAN)/RAD+ZERO MAIN1320 HWL(I)=SQRT(P*TAN*TAN+Q*TAN+R) MAIN1330 22 INDEX(I)=0 MAIN1340 CALL SORT(TL,LL,N) MAIN1350 DO 69 I=1,N MAIN1360 J=LL(I) MAIN1370 T(I)=TL(J) MAIN1380 69 HW(I)=HWL(J) MAIN1390 C-----READ IN PROFILE INTENSITIES MAIN1400 READ( 5,24)YALFA,YSTAP,YOMEG MAIN1410 POS(NB+1)=YOMEG+YSTAP MAIN1420 BAK(NB+1)=BAK(NB) MAIN1430 MAXR=N MAIN1440 PI=YSTAP/SQRT(3.14159265359) ! WAS PI=YSTAP/(100.*SQRT(RAD)) FISCH87F PI=PI*SQRT(3.6) ! THIS FACTOR JUST TO RETAIN PREV (FALSE) SCALE JJ=1 MAIN1460 I=1 MAIN1470 MINR=1 MAIN1480 PS=YALFA MAIN1490 C---- READ IN ONE RECORD OF 10 INTENSITIES MAIN1500 34 J=JJ-(JJ-1)/10*10 MAIN1510 JJ9=JJ+9 MAIN1520 IF(J.NE.1) GO TO 342 C----IW(J) IS THE NUMBER OF MEASUREMENTS FOR POINT J (NUMBER DETECTORS) READ( 5,25)(IW(J),YY(J),J=JJ,JJ9) MAIN1530 DO341J=JJ,JJ9 341 IF(IW(J).EQ.0) IW(J)=1 342 Y=YY(JJ) MAIN1540 C-----DETERMINE WETHER INTENSITY IS IN EXCLUDED RANGE MAIN1550 LOWJ(JJ)=0 MAIN1560 IHIGHJ(JJ)=0 MAIN1570 IF(NCU)70,70,71 MAIN1580 71 DO 26 J=1,NCU MAIN1590 IF((PS.GE.LOW(J)).AND.(PS.LE.IHIGH(J)))Y=0. MAIN1600 26 YY(JJ)=Y MAIN1610 70 IF(Y.EQ.0.)GOTO 27 MAIN1620 MARK=0 MAIN1630 C-----DETERMINE WHAT REFLECTIONS CAN CONTRIBUTE TO INTENSITY I.E. ARE MAIN1640 C-----WITHIN 1.5*HALFWIDTH FROM INTENSITY POSITION. MAIN1650 DO 28 J=MINR,MAXR MAIN1660 WIDTH=HW(J)*1.5 MAIN1670 ST=T(J) MAIN1680 MIN=ST-WIDTH+0.5 MAIN1690 MAX=ST+WIDTH+0.5 MAIN1700 IF(.NOT.((PS.GE.MIN).AND.(PS.LE.MAX)))GOTO 29 MAIN1710 IF(MARK)30,31,30 MAIN1720 31 I=J MAIN1730 LOWJ(JJ)=J MAIN1740 MARK=1 MAIN1750 30 INDEX(J)=-1 MAIN1760 GOTO 28 MAIN1770 29 IF(MARK.EQ.1)GOTO 32 MAIN1780 28 CONTINUE MAIN1790 J=MAXR+1 32 IF(MARK.EQ.1)IHIGHJ(JJ)=J-1 MAIN1800 MINR=I MAIN1810 27 PS=PS+YSTAP MAIN1820 JJ=JJ+1 MAIN1830 IF(PS-YOMEG)34,34,33 MAIN1840 C-----DETERMINE MAXIMUM NUMBER OF OVERLAPPING REFLECTIONS FOR ANY MAIN1850 C-----INTENSITY. MAIN1860 33 OLIM=1. MAIN1870 JJ1=JJ-1 MAIN1880 DO 72 I=1,JJ1 MAIN1890 C-----DETERMINATION OF TOTAL NUMBER OF REFLECTIONS WITHIN RANGE CONCERNEMAIN1900 IF(LOWJ(I).EQ.0)YY(I)=0. MAIN1910 Y=IHIGHJ(I)-LOWJ(I) MAIN1920 72 IF(Y.GT.OLIM)OLIM=Y MAIN1930 OLIM=OLIM+1. MAIN1940 I=0 MAIN1950 DO 35 IS=1,N MAIN1960 IF(INDEX(IS).EQ.-1)I=I+1 MAIN1970 35 CONTINUE MAIN1980 C-----WRITE DATA ON TAPE AND PRINT REFLECTIONS MAIN1990 CALL DUMP(OLIM) MAIN2000 CALL DUMP(FLOAT(I)) MAIN2010 DO 36 I=1,3 MAIN2020 36 CALL DUMP(FLOAT(NH(I))) MAIN2030 I=0 MAIN2040 DO 37 IS=1,N MAIN2050 LLS=LL(IS) MAIN2060 IZ=0 MAIN2070 IF(INDEX(IS).EQ.-1)IZ=1 MAIN2080 IF(IZ-1)38,39,38 MAIN2090 39 I=I+1 MAIN2100 TT(IS)=I MAIN2110 CALL DUMP(FLOAT(ICODE(LLS))) MAIN2120 DO 40 J=1,3 MAIN2130 40 CALL DUMP(FLOAT(IH(J,LLS))) MAIN2140 XX=FLOAT(M(LLS))*PI*PLOR(LLS) MAIN2150 CALL DUMP(XX) MAIN2160 WRITE( 6,41)I,ICODE(LLS),(IH(J,LLS),J=1,3),M(LLS),HW(IS),T(IS) MAIN2170 GOTO 37 MAIN2180 38 TT(IS)=0. MAIN2190 WRITE( 6,42)ICODE(LLS),(IH(J,LLS),J=1,3),M(LLS),HW(IS),T(IS) MAIN2200 37 CONTINUE MAIN2210 C-----CORRECT FOR BACKGROUND AND PRINT PROFILE INTENSITIES MAIN2220 WRITE( 6,89)YALFA,YOMEG,YSTAP MAIN2230 LIMO=OLIM+0.5 MAIN2240 WRITE( 6,44)(NOX,I=1,LIMO) MAIN2250 CALL DUMP(YALFA) MAIN2260 CALL DUMP(YSTAP) MAIN2270 CALL DUMP(YOMEG) MAIN2280 YPOS=YALFA MAIN2290 JJ=1 MAIN2300 IZ=0 MAIN2310 NZ=0 MAIN2320 65 Y=YY(JJ) MAIN2330 IF(Y)45,46,45 MAIN2340 46 NZ=NZ+1 MAIN2350 IZ=1 MAIN2360 CALL DUMP(0.) MAIN2370 GOTO 47 MAIN2380 45 NB1=NB+1 MAIN2390 DO 48 J=1,NB1 MAIN2400 J1=J-1 MAIN2410 IF(J1.EQ.0)J1=1 MAIN2420 IF(POS(J).LE.YPOS)GOTO 48 MAIN2430 BACK=BAK(J1) IF(POS(J1).NE.POS(J)) A BACK=BACK+(YPOS-POS(J1))/(POS(J)-POS(J1))*(BAK(J)-BAK(J1)) MAIN2440 GOTO 49 MAIN2450 48 CONTINUE MAIN2460 49 W=IW(JJ) W=W*250./Y MAIN2470 C LIMIT THE WEIGHT OF COUNTS NEAR ZERO AND ELIMINATE NEGATIVE COUNTS IF(Y.LE.10) W=IW(JJ)*25 IF(Y.LE.0) W=0 ! A.HEWAT 7-JUN-88 C****LIMIT THE WEIGHT OF VERY STRONG PEAKS, E.G. WLIMIT=5000**** C A.W.HEWAT 25-FEB-83 IF(WLIMIT.GT.0.)W=W*WLIMIT/(WLIMIT+Y) YL=Y-BACK MAIN2480 IF(YL.EQ.0.)YL=1. MAIN2490 L=0 MAIN2500 III=0 MAIN2510 66 IF(IZ-1)50,51,50 MAIN2520 51 IF(NZ-4)52,52,53 MAIN2530 52 WRITE( 6,54)(III,K=1,NZ) MAIN2540 GOTO 55 MAIN2550 53 WRITE( 6,54)(III,K=1,2) MAIN2560 NZ4=NZ-4 MAIN2570 WRITE( 6,56)NZ4 MAIN2580 WRITE( 6,54)(III,K=1,2) MAIN2590 55 IF(YPOS-YOMEG)57,57,58 MAIN2600 57 IZ=0 MAIN2610 NZ=0 MAIN2620 50 CALL DUMP(YL) MAIN2630 CALL DUMP(W) MAIN2640 K1=LOWJ(JJ) MAIN2650 K1=TT(K1)+0.5 MAIN2660 CALL DUMP(FLOAT(K1)) MAIN2670 K2=IHIGHJ(JJ) MAIN2680 K2=TT(K2)+0.5 MAIN2690 CALL DUMP(FLOAT(K2)) MAIN2700 RPOS=0.01*YPOS WRITE( 6,59)RPOS,Y,BACK,YL,W,(K,K=K1,K2) MAIN2710 47 YPOS=YPOS+YSTAP MAIN2720 JJ=JJ+1 MAIN2730 IF(YPOS.LE.YOMEG)GOTO 65 MAIN2740 IF(IZ.EQ.1)GOTO 66 MAIN2750 58 CALL DUMP(-12345.) MAIN2760 WRITE( 6,67) MAIN2770 CLOSE(UNIT=2) CLOSE(UNIT=5) CLOSE(UNIT=6) CLOSE(UNIT=19) C cpu timer *** A.Hewat 23 Feb 89 *** SECONDS=1 CALL TIMER(SECONDS) IF(SECONDS.EQ.1) GO TO 1234 ETIME=FLOAT(SECONDS)-START_TIME CTIME=ETIME Write(*,9999) CTIME,ETIME 9999 FORMAT(//' CPU time :',F9.2,5X,'Elapsed time :',F9.2/) 1234 PAUSE ' Press RETURN to finish.' C cpu timer *** A.Hewat 23 Feb 89 *** STOP MAIN2775 1 FORMAT(' PREPARATION FOR NEUTRON POWDER PROFILE REFINEMENT'/ 1 '---ILL VERSION 8000 DATA POINTS & 4889 REFLEXIONS---') 4 FORMAT(20A4) 6 FORMAT(6F8.4) MAIN2820 7 FORMAT(2I8) MAIN2830 19 FORMAT(3I8) MAIN2840 20 FORMAT(51H0 NO. CODE H K L MULT HW POSN) MAIN2850 21 FORMAT(14X,3I4) MAIN2860 23 FORMAT(5I8) MAIN2870 24 FORMAT(3F8.0) MAIN2880 25 FORMAT(10(I2,F6.0)) MAIN2890 41 FORMAT(1X,I5,I6,2X,3I4,I6,F9.1,F11.1) MAIN2900 42 FORMAT(7H ***,I6,2X,3I4,I6,F9.1,F11.1) MAIN2910 43 FORMAT(1H0,3I6) MAIN2920 44 FORMAT(42H0 POSN I+B B I W ,20(A3,1X)) MAIN2930 54 FORMAT(1X,I12) MAIN2940 56 FORMAT(6X,1H(,I4,7H ZEROS)) MAIN2950 59 FORMAT(1X,F8.3,3F7.0,F9.4,20I4,(/37X,20I4)) MAIN29 67 FORMAT(130H0++++++++++++++++++++++++++++++++++++++++++++++++++++++MAIN2970 1++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++MAIN2980 2+++++++++/1H1) MAIN2990 80 FORMAT(12H0WAVELENGTH=,F7.4) MAIN3000 81 FORMAT(11H0ZEROPOINT=,F6.2) MAIN3010 82 FORMAT(22H0HALFWIDTH PARAMETERS=) MAIN3020 83 FORMAT(3H U=,F9.1,3X,2HV=,F9.1,3X,2HW=,F9.1) MAIN3030 84 FORMAT(12H0BACKGROUND=/9H POSITION,4X,9HINTENSITY) MAIN3040 85 FORMAT(1X,F7.0,6X,F6.0) MAIN3050 86 FORMAT(21H0NO EXCLUDED REGIONS.) MAIN3060 87 FORMAT(18H0EXCLUDED REGIONS=/4HFROM,5X,2HTO) MAIN3070 88 FORMAT(1X,I5,4X,I5) MAIN3080 89 FORMAT(13H0DIAGRAM FROM,F8.1,3H TO,F8.1,12H IN STEPS OF,F5.1, A1X,15H1/100THS DEGREE) 100 FORMAT(1X,20A4) MAIN3110 110 FORMAT(12H0FILE NAMED ,A4,1X ,8HCREATED.) MAIN3120 111 FORMAT(12H0FILE NAMED ,A4,1X,9HREPLACED.) MAIN3130 117 FORMAT(2F8.0) MAIN3140 END MAIN3150 SUBROUTINE SORT(A,L,N) SORT 0 C-----THE SUBROUTINE SORT APPLIES TO THE ARRAY A WITH J ELEMENTS. SORT 10 C-----THE INDICES OF THE ORDERED ARRAY ARE PLACED IN ARRAY L SORT 20 C-----TO OBTAIN THE ORDERED ARRAY REPLACE THE INDICES I OF A(I) SORT 30 C-----WITH I=L(I)---REF.CACM 271 SORT 40 DIMENSION A(4889),L(4889),IUT(10),ILT(10) SORT 50 J=N SORT 60 I=1 SORT 70 M=1 SORT 80 DO1 K=1,J SORT 90 1 L(K)=K SORT 100 6 IF(J-I-1)2,2,3 SORT 110 3 IP=(J+I)/2 SORT 120 ITT=L(IP) SORT 130 T=A(ITT) SORT 140 L(IP)=L(I) SORT 150 IQ=J SORT 160 K=I+1 SORT 170 22 IF(K.GT.IQ)GOTO 23 SORT 180 LK=L(K) SORT 190 IF(A(LK).LE.T)GOTO 4 SORT 200 IQ=IQ SORT 210 20 IF(IQ.LT.K)GOTO 21 SORT 220 LQ=L(IQ) SORT 230 IF(A(LQ).GE.T)GOTO 7 SORT 240 IX=L(K) SORT 250 L(K)=L(IQ) SORT 260 L(IQ)=IX SORT 270 IQ=IQ-1 SORT 280 GOTO 4 SORT 290 7 IQ=IQ-1 SORT 300 GOTO 20 SORT 310 21 CONTINUE SORT 320 IQ=K-1 SORT 330 GOTO 11 SORT 340 4 K=K+1 SORT 350 GOTO 22 SORT 360 23 CONTINUE SORT 370 11 L(I)=L(IQ) SORT 380 L(IQ)=ITT SORT 390 IF(2*IQ-I-J)12,12,13 SORT 400 13 ILT(M)=I SORT 410 IUT(M)=IQ-1 SORT 420 I=IQ+1 SORT 430 GOTO 14 SORT 440 12 ILT(M)=IQ+1 SORT 450 IUT(M)=J SORT 460 J=IQ-1 SORT 470 14 M=M+1 SORT 480 GOTO 6 SORT 490 2 IF(I-J)15,16,16 SORT 500 15 LI=L(I) SORT 510 LJ=L(J) SORT 520 IF(A(LI)-A(LJ))16,16,17 SORT 530 17 IX=L(I) SORT 540 L(I)=L(J) SORT 550 L(J)=IX SORT 560 16 M=M-1 SORT 570 IF(M)18,18,19 SORT 580 19 I=ILT(M) SORT 590 J=IUT(M) SORT 600 GOTO 6 SORT 610 18 CONTINUE SORT 620 RETURN SORT 630 END SORT 640 SUBROUTINE CELL(X) CELL 0 C-----THE SUBROUTINE CELL READS EITHER DIRECT CELL PARAMETERS AND CELL 10 C-----CONVERTS THESE TO CELL CONSTANTS,WHICH ARE PLACED IN ARRAY X OR CELL 20 C-----READS CELL CONSTANTS AND PRINTS THE DIRECT CELL PARAMETERS. CELL 30 DIMENSION X(3,3) CELL 40 RAD=3.14159265359/180. CELL 50 READ( 5,1)A,B,C,D,E,F CELL 60 ISW=0 CELL 70 IF(A.LT.1.)ISW=1 CELL 80 IF(ISW.EQ.0)GOTO 4 CELL 90 X(1,1)=A CELL 100 X(2,2)=B CELL 110 X(3,3)=C CELL 120 X(1,2)=F CELL 130 X(1,3)=E CELL 140 X(2,3)=D CELL 150 A=SQRT(A) CELL 160 B=SQRT(B) CELL 170 C=SQRT(C) CELL 180 COSA=D/(2.*B*C) CELL 190 COSB=E/(2.*A*C) CELL 200 COSC=F/(2.*A*B) CELL 210 GOTO 5 CELL 220 4 COSA=COS(RAD*D) CELL 230 COSB=COS(RAD*E) CELL 240 COSC=COS(RAD*F) CELL 250 5 SINA=SQRT(1.-COSA*COSA) CELL 260 SINB=SQRT(1.-COSB*COSB) CELL 270 SINC=SQRT(1.-COSC*COSC) CELL 280 V=A*B*C*SQRT(1.-COSA*COSA-COSB*COSB-COSC*COSC+2.*COSA*COSB*COSC) CELL 290 AS=B*C*SINA/V CELL 300 BS=C*A*SINB/V CELL 310 CS=A*B*SINC/V CELL 320 COSAS=(COSB*COSC-COSA)/(SINB*SINC) CELL 330 COSBS=(COSC*COSA-COSB)/(SINC*SINA) CELL 340 COSCS=(COSA*COSB-COSC)/(SINA*SINB) CELL 350 IF(ISW.EQ.0)GOTO 6 CELL 360 A=AS CELL 370 B=BS CELL 380 C=CS CELL 390 D=ATAN2(SQRT(1.-COSAS*COSAS),COSAS)/RAD CELL 400 E=ATAN2(SQRT(1.-COSBS*COSBS),COSBS)/RAD CELL 410 F=ATAN2(SQRT(1.-COSCS*COSCS),COSCS)/RAD CELL 420 GOTO 7 CELL 430 6 X(1,1)=AS*AS CELL 440 X(2,2)=BS*BS CELL 450 X(3,3)=CS*CS CELL 460 X(1,2)=2.*AS*BS*COSCS CELL 470 X(1,3)=2.*AS*CS*COSBS CELL 480 X(2,3)=2.*BS*CS*COSAS CELL 490 7 WRITE( 6,2) CELL 500 WRITE( 6,3)A,B,C,D,E,F CELL 510 1 FORMAT(6F8.4) CELL 520 2 FORMAT(17H0CELL DIMENSIONS=) CELL 530 3 FORMAT(3H A=,F8.4,6X,2HB=,F8.4,6X,2HC=,F8.4/ CELL 540 17H ALPHA=,F7.3,3X,5HBETA=,F7.3,4X,6HGAMMA=,F7.3) CELL 550 RETURN CELL 560 END CELL 570 SUBROUTINE DUMP(X) DUMP 0 C-----THE SUBROUTINE DUMP STORES THE VALUE X IN ARRAY DUMPA. DUMP 10 C ****************************************************************************** C CHANGE FOR RHEL SYSTEM C ****************************************************************************** C-----WHEN THIS HAS BEEN FILLED,ITS CONTENTS ARE TRANSFERRED TO DUMP 20 C-----A TEMPORARY DATA SET ON DISC IN RECORDS OF 500 MUMBERS. DUMP 30 COMMON DUMPA(500),II,NKEY,TEXT(20),NTEXT,KSTART DUMP 40 II=II+1 DUMP 50 1 DUMPA(II)=X DUMP 60 IF(II.NE.500)GOTO 3 DUMP 70 WRITE(2)DUMPA DUMP 80 19 FORMAT(10F10.3) II=0 DUMP 90 3 IF(X.NE.-12345.)GOTO 4 DUMP 100 WRITE(2)DUMPA DUMP 110 DUMPA(1)=-12345. DUMP 120 WRITE(2)DUMPA DUMP 130 REWIND 2 DUMP 140 4 RETURN DUMP 150 END DUMP 160 SUBROUTINE TIMER(SECONDS) C ******* C Get the Vax cpu time and local time. Initialise with SECONDS=0 C Include Job Process Information DEFinition codes (JPIDEF). C Supplied by DIGITAL. INCLUDE '($JPIDEF)' INTEGER*4 CLOCK_TICKS,CLOCK_TICKS2,SECONDS LOGICAL*4 STATUS COMMON/CPUTIM/START_TIME,CLOCK_TICKS IF(SECONDS.NE.0) GO TO 2 C Get local time. START_TIME = SECNDS(0.0) C Get cpu time. STATUS = LIB$GETJPI(JPI$_CPUTIM,,,CLOCK_TICKS,,) C Return to calling subroutine. RETURN C Get elapsed time. 2 ETIME = SECNDS(START_TIME) C Get cpu time. STATUS = LIB$GETJPI(JPI$_CPUTIM,,,CLOCK_TICKS2,,) C Total cpu time used. CTIME = FLOAT(CLOCK_TICKS2 - CLOCK_TICKS) / 100.0 TYPE 9, CTIME,ETIME 9 FORMAT(/1X,'CPU time :',F9.2,5X,'Elapsed time :',F9.2/) C Return to the monitor. CALL EXIT C ******* END