PROGRAM CAM2 CAM20000 C-----PROGRAM CAM2 CAM20001 C----- CAM20002 C-----PART 2 OF THE CAMEL JOCKEY CAM20003 C-----THIS PROGRAM READS IN THE PSI SCAN DATA FROM FILE RAW. CAM20004 C-----ITS FINDS THE PARENTS OF EACH REFLECTION,FORMS THE SUMS AND WRITESCAM20005 C----- OUT THE SUMS AND THE PSI=0 REFLECTIONS. CAM20006 C----- CAM20007 COMMON IH,IK,IL,MPAR,NPAR,NTOUT,IQUIT,MSYM,ISMHKL(216),IHS(30),IKSCAM20008 1(30),ILS(30) CAM20009 DIMENSION SUM(30), SGSUM(30), COUN(30), ITITLE(40) CAM20010 C-----SET CONSTANTS CAM20011 NTIN=9 CAM20012 NTOUT=12 CAM20013 NFILEA=1 CAM20014 NFILEB=2 CAM20015 NFILEC=3 CAM20016 NLIG=60 CAM20017 IQUIT=0 CAM20018 IPIN=0 CAM20019 C-----SET DIMENSIONS CAM20020 NSYM=24 CAM20021 NPAR=30 CAM20022 C-----SET COUNTERS CAM20023 MPAR=0 CAM20024 MPSI=0 CAM20025 CALL FOPEN (NFILEA,4HRAWD,1H ) CAM20026 CALL FOPEN (NFILEB,4HPSI0,1HB) CAM20027 CALL FOPEN (NFILEC,4HSMPR,1HB) CAM20028 C-----READ TITLE (FROM NFILEA) CAM20029 READ (NFILEA,100) (ITITLE(I),I=1,40) CAM20030 100 FORMAT (40A2) CAM20031 C-----READ IN NUMBER OF SYMMETRY ELEMENTS CAM20032 READ (NFILEA,105) MSYM CAM20033 105 FORMAT (I5) CAM20034 IF (NSYM-MSYM) 110,120,120 CAM20035 C-----TOO MANY SYMMETRY ELEMENTS CAM20036 110 WRITE (NTOUT,115) MSYM,NSYM CAM20037 115 FORMAT (27H0TOO MANY SYMMETRY ELEMENTS,2I5) CAM20038 IQUIT=1 CAM20039 GO TO 240 CAM20040 C-----READ SYMMETRY ELEMENTS CAM20041 120 IC=-8 CAM20042 DO 130 II=1,MSYM CAM20043 IC=IC+9 CAM20044 IS=IC+8 CAM20045 READ (NFILEA,125) (ISMHKL(I),I=IC,IS) CAM20046 125 FORMAT (9I3) CAM20047 130 CONTINUE CAM20048 C-----READ ABSORPTION INFORMATION CAM20049 READ (NFILEA,135) AMU,FMUTR CAM20050 135 FORMAT (2F10.3) CAM20051 C-----PRINT OUT TITLE CONTROLS AND SYMMETRY CAM20052 WRITE (NTOUT,140) (ITITLE(I),I=1,40) CAM20053 140 FORMAT (1H0,40A2,/,20H0CAMEL JOCKEY PART 2) CAM20054 WRITE (NTOUT,145) NFILEA,NFILEB,NFILEC CAM20055 145 FORMAT (23H0INPUT AND OUTPUT UNITS,/,1H0,2X,6HNFILEA,2X,6HNFILEB,2CAM20056 1X,6HNFILEC,/,1H0,3I8) CAM20057 IS=9*MSYM CAM20058 WRITE (NTOUT,150) (ISMHKL(I),I=1,IS) CAM20059 150 FORMAT (34H0 INTENSITY EQUIVALENT REFLECTIONS,//,(9H NEW H=,I2,2CAM20060 1H*H,I2,2H*K,I2,2H*L,9H NEW K=,I2,2H*H,I2,2H*K,I2,2H*L,9H NEW LCAM20061 2=,I2,2H*H,I2,2H*K,I2,2H*L)) CAM20062 C-----ZERO ARRAYS AND VARIABLES CAM20063 TWMAX=0.0 CAM20064 DO 155 I=1,NPAR CAM20065 SUM(I) =0.0 CAM20066 SGSUM(I)=0.0 CAM20067 155 COUN(I)=0.0 CAM20068 C-----NEW PAGE CAM20069 N1=NLIG+1 CAM20070 C-----TOP OF LOOP FOR READING PSI SCAN DATA FROM NFILEA CAM20071 160 READ (NFILEA,165) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,FIT,SGFICAM20072 1T CAM20073 165 FORMAT (1X,3I3,5F8.2,F8.4,F12.2,F10.2) CAM20074 IF (IH-999) 170,225,170 CAM20075 170 IF (IPIN) 200,175,200 CAM20076 C-----PRINT PSI SCAN DATA CAM20077 175 N1=N1+1 CAM20078 IF (N1-NLIG) 190,190,180 CAM20079 180 N1=6 CAM20080 WRITE (NTOUT,185) (ITITLE(I),I=1,40) CAM20081 185 FORMAT (1H1,40A2,/,21H0 PSI SCAN INPUT DATA,//,5X,1HH,4X,1HK,4X,1HCAM20082 1L,6X,4HTWTH,7X,3HOMG,7X,3HCHI,7X,3HPHI,7X,3HPSI,6X,9HINTENSITY,6X,CAM20083 29HSIGMA INT,/) CAM20084 190 WRITE (NTOUT,195) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,FIT,SGFIT CAM20085 195 FORMAT (1H ,3I5,5F10.2,2F15.2) CAM20086 C-----FIND POINTER (IPAR) OF PARENT REFLECTION CAM20087 200 CALL CJ3 (IPAR) CAM20088 IF (IQUIT) 240,205,240 CAM20089 C-----ADD TO SUMMATIONS CAM20090 205 SUM(IPAR)=SUM(IPAR)+FIT CAM20091 COUN(IPAR)=COUN(IPAR)+1.0 CAM20092 SGSUM(IPAR)=SGSUM(IPAR)+SGFIT*SGFIT CAM20093 C-----KEEP LARGEST VALUE OF DTWTH CAM20094 IF (DTWTH-TWMAX) 215,215,210 CAM20095 210 TWMAX=DTWTH CAM20096 215 CONTINUE CAM20097 IF (DPSI) 160,220,160 CAM20098 C-----THIS REFLECTION HAS PSI=0. WRITE IT OUT ON NFILEC CAM20099 220 CONTINUE CAM20100 C-----CHECK FOR VALID OBSERVATION CAM2A086 IF(FIT-3.0*SGFIT) 196,2000,2000 CAM2B086 196 N1=N1+1 CAM2C086 WRITE(NTOUT,197) CAM2D086 197 FORMAT(44H PREVIOUS LINE IGNORED AS INTENSITY TOO WEAK) CAM2E086 GO TO 160 CAM2F086 2000 CONTINUE CAM2G086 CNOVA WRITE BINARY (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM20101 CDC38 WRITE (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM20102 WRITE (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM20103 MPSI=MPSI+1 CAM20104 GO TO 160 CAM20105 C-----ALL DATA HAVE NOW BEEN READ FROM NFILEA AND THE PSI.EQ.0 REFLECTIOCAM20106 C-----NS ARE ON NFILEB CAM20107 225 CONTINUE CAM20108 C-----CALCULATE MEAN INTENSITY AND SIGMA OF PARENTS CAM20109 DO 230 I=1,MPAR CAM20110 SUM(I)=SUM(I)/COUN(I) CAM20111 230 SGSUM(I)=SGSUM(I)/COUN(I) CAM20112 C-----CALCULATE SCALE TO PUT MEAN VALUE OF SQWT TO 1.0 CAM20113 SCALE=0.0 CAM20114 DO 235 I=1,MPAR CAM20115 235 SCALE=SCALE+SUM(I)/SQRT(SGSUM(I)) CAM20116 SCALE=1.4142*FLOAT(MPAR)/SCALE CAM20117 CNOVA WRITE BINARY (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM20118 CDC38 WRITE (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM20119 WRITE (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM20120 1(SUM(I),I=1,NPAR),(SGSUM(I),I=1,NPAR),SCALE,AMU,FMUTR CAM20121 240 STOP CAM20122 END CAM20123 SUBROUTINE CJ3 (IP) CJ3 0000 C----- CJ3 0001 C-----THIS SUBROUTINE FINDS THE POINTER (IP) TO THE PARENT REFLECTION CJ3 0002 C-----OF THE REFLECTION IH,IK,IL CJ3 0003 C----- CJ3 0004 COMMON IH,IK,IL,MPAR,NPAR,NTOUT,IQUIT,MSYM,ISMHKL(216),IHS(30),IKSCJ3 0005 1(30),ILS(30) CJ3 0006 C-----MPAR COUNTS THE NUMBER OF PARENT REFLECTIONS .PARENT REFLECTION CJ3 0007 C-----INDECES ARE STORED IN IHS(I),IKS(I),ILS(I) CJ3 0008 IF (MPAR) 105,100,105 CJ3 0009 C-----THE VERY FIRST IS ALWAYS CONSIDERED AS A PARENT REFLECTION CJ3 0010 C-----STORE ITS INDECES CJ3 0011 100 MPAR=1 CJ3 0012 IP=1 CJ3 0013 IHS(1)=IH CJ3 0014 IKS(1)=IK CJ3 0015 ILS(1)=IL CJ3 0016 RETURN CJ3 0017 105 CONTINUE CJ3 0018 IP=0 CJ3 0019 C-----LOOP OVER STORED PARENT REFLECTION INDECES CJ3 0020 DO 115 K1=1,MPAR CJ3 0021 IP=IP+1 CJ3 0022 C-----LOOP OVER H K L SYMMETRY TRANSFORMATIONS CJ3 0023 IC=-8 CJ3 0024 DO 110 K2=1,MSYM CJ3 0025 IC=IC+9 CJ3 0026 C-----TRANSFORM THE K1 TH PARENT INDECES WITH K2 ND SYMMETRY TRANSFORM. CJ3 0027 IT1=IHS(K1)*ISMHKL(IC)+IKS(K1)*ISMHKL(IC+1)+ILS(K1)*ISMHKL(IC+2) CJ3 0028 IT2=IHS(K1)*ISMHKL(IC+3)+IKS(K1)*ISMHKL(IC+4)+ILS(K1)*ISMHKL(IC+5)CJ3 0029 IT3=IHS(K1)*ISMHKL(IC+6)+IKS(K1)*ISMHKL(IC+7)+ILS(K1)*ISMHKL(IC+8)CJ3 0030 ITP=IABS(IT1-IH)+IABS(IT2-IK)+IABS(IT3-IL) CJ3 0031 C-----TEST PARENT TRANSFORMED INDECES AGAINST IH IK IL CJ3 0032 IF (ITP) 110,135,110 CJ3 0033 C-----TRANSFORMED PARENT INDECES NOT THE SAME AS IH IK IL. TRY AGAIN CJ3 0034 110 CONTINUE CJ3 0035 115 CONTINUE CJ3 0036 C-----NO TRANSFORMATIONS GIVE IH IK IL. THUS IT IS A PARENT REF. CJ3 0037 C-----COUNT IT CJ3 0038 MPAR=MPAR+1 CJ3 0039 IF (MPAR-NPAR) 130,130,120 CJ3 0040 C-----TOO MANY PARENTS CJ3 0041 120 WRITE (NTOUT,125) MPAR,NPAR CJ3 0042 125 FORMAT (17H0TOO MANY PARENTS,2I5) CJ3 0043 IQUIT=1 CJ3 0044 GO TO 135 CJ3 0045 130 CONTINUE CJ3 0046 C-----STORE IH IK IL AND POINT TO IT CJ3 0047 IHS(MPAR)=IH CJ3 0048 IKS(MPAR)=IK CJ3 0049 ILS(MPAR)=IL CJ3 0050 IP=MPAR CJ3 0051 C-----IP NOW CONTAINS POINTER TO PARENT REFLECTIONS CJ3 0052 135 RETURN CJ3 0053 END CJ3 0054 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 RETURN FOPN0001 END FOPN0002 SCOPE TEST DATA FOR CAMEL JOCKEY *** REAL DATA IS NOT LIKE THIS *** 16 1 0 0 0 1 0 0 0 1 -1 0 0 0 1 0 0 0 1 1 0 0 0 -1 0 0 0 1 -1 0 0 0 -1 0 0 0 1 1 0 0 0 1 0 0 0 -1 -1 0 0 0 1 0 0 0 -1 1 0 0 0 -1 0 0 0 -1 -1 0 0 0 -1 0 0 0 -1 0 1 0 1 0 0 0 0 1 0 -1 0 1 0 0 0 0 1 0 1 0 -1 0 0 0 0 1 0 -1 0 -1 0 0 0 0 1 0 1 0 1 0 0 0 0 -1 0 -1 0 1 0 0 0 0 -1 0 1 0 -1 0 0 0 0 -1 0 -1 0 -1 0 0 0 0 -1 400. 2.0 2 1 19.7 4.85 58.7 206.2 0. 92.5 1.0 2 1 19.7 90.0 52.4 1.0 -2 1 19.7 12.1 6.9 0. 81.7 1.0 -2 1 19.7 90.0 63.2 1.0 2 -1 19.7 4.85 27.5 153.3 0. 107.2 1.0 2 -1 19.7 90. 37.7 1.0 -2 -1 19.7 4.85 -10.5 49.3 0. 40.7 1.0 -2 -1 19.7 90.0 104.2 1.0 2 1 -19.7 4.85 10.5 229.3 0. 53.9 1.0 2 1 -19.7 90. 91.3 1.0 -2 1 -19.7 4.85 -27.5 333.3 0. 93.3 1.0 -2 1 -19.7 90.0 51.6 1.0 2 -1 -19.7 4.85 -12.1 186.9 0. 100.5 1.0 2 -1 -19.7 90. 44.4 1.0 -2 -1 19.7 4.85 -10.5 49.3 0. 40.7 1.0 -2 -1 19.7 90.0 104.2 1.0 1 2 19.7 4.85 62.6 276.8 0. 54.1 1.0 1 2 19.7 90. 90.8 1.0 -1 2 19.7 4.85 34.6 339.9 0. 107.6 1.0 -1 2 19.7 90. 37.3 1.0 1 -2 19.7 4.85 6.0 126.8 0. 94.3 1.0 1 -2 19.7 90. 50.6 1.0 -1 -2 19.7 4.85 -12.5 83.0 0. 59.8 1.0 -1 -2 19.7 90. 85.4 1.0 1 2 -19.7 4.85 12.5 263. 0. 41.4 1.0 1 2 -19.7 90. 103.5 1.0 -1 2 -19.7 4.85 -6.0 306.8 0. 70.6 1.0 -1 2 -19.7 90. 74.3 1.0 1 -2 -19.7 4.85 -34.6 159.9 0. 114.2 1.0 1 -2 -19.7 90. 30.7 1.0 -1 -2 -19.7 4.85 -62.6 96.8 0. 52.9 1.0 -1 -2 -19.7 90. 92.0 1.0 4 1 218.3 9.1 53.8 187.5 0. 126.1 1.0 4 1 218.3 90. 24.3 1.0 -4 1 218.3 9.1 6.8 17.2 0. 60.8 1.0 -4 1 218.3 90. 89.6 1.0 4 -1 218.3 9.1 36.7 161.3 0. 121.0 1.0 4 -1 218.3 90. 29.4 1.0 -4 -1 218.3 9.1 -5.2 39.1 0. 36.8 1.0 -4 -1 218.3 90. 113.6 1.0 4 1 -218.3 9.2 5.2 219.1 0. 73.4 1.0 4 1 -218.3 90. 77.0 1.0 -4 1 -218.3 9.1 -36.7 341.3 0. 92.0 1.0 -4 1 -218.3 90. 58.4 1.0 4 -1 -218.3 9.1 -6.8 197.2 0. 101.8 1.0 4 -1 -218.3 90. 48.6 1.0 -4 -1 -218.3 9.1 -53.8 7.5 0. 65.8 1.0 -4 -1 -218.3 90. 84.6 1.0 1 4 218.3 9.1 59.6 299.5 0. 76.9 1.0 1 4 218.3 90. 73.5 1.0 -1 4 218.3 9.1 43.7 331.1 0. 111.1 1.0 -1 4 218.3 90. 39.3 1.0 1 -4 218.3 9.1 1.5 116.4 0. 101.7 1.0 1 -4 218.3 90. 48.7 1.0 -1 -4 218.3 9.1 -8.4 93.6 0. 82.2 1.0 -1 -4 218.3 90. 68.2 1.0 -1 -4 -218.3 9.1 -59.6 119.5 0. 84.6 1.0 -1 -4 -218.3 90. 65.8 1.0 1 4 -218.3 9.1 8.4 273.6 0. 33.4 1.0 1 4 -218.3 90. 117.0 1.0 -1 4 -218.3 9.1 -1.5 296.4 0. 49.5 1.0 -1 4 -218.3 90. 100.9 1.0 1 -4 -218.3 1.9 -43.7 151.1 0. 116.3 1.0 1 -4 -218.3 90. 34.1 1.0 7 2 129.1 14.5 38.7 205.0 0. 118.9 1.0 7 2 129.1 90. 39.8 1. -7 2 129.1 -7.8 4.6 0. 54.9 1.0 -7 2 129.1 90. 103.7 1.0 7 -2 129.1 21.2 174.2 0. 133.4 1.0 7 -2 129.1 90. 25.3 1.0 -7 -2 129.1 -23.5 33.3 0. 24.0 1.0 -7 -2 129.1 90. 134.8 1.0 7 2 -129.1 23.5 213.3 0. 100.9 1.0 7 2 -129.1 90. 57.8 1.0 -7 2 -129.1 -21.2 354.2 0. 69.0 1.0 -7 2 -129.1 90. 89.7 1.0 7 -2 -129.1 7.8 184.6 0. 130.8 1.0 7 -2 -129.1 90.0 27.9 1.0 -7 -2 -129.1 -38.7 25.0 0. 26.9 1.0 -7 -2 -129.1 90. 131.8 1.0 2 7 129.1 43.0 283.6 0. 43.9 1.0 2 7 129.1 90. 114.9 1.0 -2 7 129.1 27.8 317.8 0. 72.1 1.0 -2 7 129.1 90. 86.6 1.0 2 -7 129.1 -13.9 127.8 0. 139.2 1.0 2 -7 129.1 90. 19.6 1.0 -2 -7 129.1 -27.1 97.3 0. 110.0 1.0 -2 -7 129.1 90. 48.7 1.0 2 7 -129.1 27.1 277.3 0. 29.7 1.0 2 7 -129.1 90. 129.0 1.0 -2 7 -129.1 13.9 307.8 0. 50.9 1.0 -2 7 -129.1 90. 107.8 1.0 2 -7 -129.1 -27.8 137.8 0. 138.6 1.0 2 -7 -129.1 90. 20.1 1.0 -2 -7 -129.1 -43.0 103.6 0. 103.1 1.0 -2 -7 -129.1 90.0 55.6 1.0 8 2 641.9 20.9 61.2 173.6 0. 192.5 1.0 8 2 641.9 75.0 30.9 1.0 8 2 641.9 135.0 30.9 1.0 -8 2 641.9 15.4 23.5 0. 53.4 1.0 -8 2 641.9 90.0 116.1 1.0 8 -2 641.9 43.7 151.0 0. 150.9 1.0 8 -2 641.9 90. 18.5 1.0 -8 -2 641.9 4.5 43.1 0. 27.4 1.0 -8 -2 641.9 90.0 142.1 1.0 8 2 -641.9 -4.5 223.1 0. 90.6 1.0 8 2 -641.9 90. 78.9 1.0 -8 2 -641.9 -43.7 331.0 0. 91.3 1.0 -8 2 -641.9 90.0 78.2 1.0 8 -2 -641.9 -15.4 203.5 0. 123.4 1.0 8 -2 -641.9 90.0 46.1 1.0 -8 -2 -641.9 -61.2 353.6 0. 63.0 1.0 -8 -2 -641.9 90.0 106.5 1.0 2 8 641.9 67.9 314.3 0. 130.6 1.0 2 8 641.9 90. 38.8 1.0 -2 8 641.9 50.7 342.7 0. 163.4 1.0 -2 8 641.9 90. 6.1 1.0 2 -8 641.9 10.5 111.1 0. 130.5 1.0 2 -8 641.9 90.0 39.0 1.0 -2 -8 641.9 1.7 90.8 0. 108.0 1.0 -2 -8 641.9 90.0 61.5 1.0 2 8 -641.9 -1.7 270.8 0. 4.3 1.0 2 8 -641.9 90.0 165.2 1.0 -2 8 -641.9 -10.5 291.1 0. 17.9 1.0 -2 8 -641.9 90.0 151.6 1.0 2 -8 -641.9 -50.7 162.7 0. 114.0 1.0 2 -8 -641.9 90.0 55.4 1.0 -2 -8 -641.9 -67.9 134.3 0. 92.6 1.0 -2 -8 -641.9 90.0 76.9 1.0 11 1 754.3 53.3 170.4 0. 212.8 1.0 11 1 754.3 95.0 37.3 1.0 11 1 754.3 105.5 37.3 1.0 -11 1 754.3 8.3 27.4 0. 29.5 1.0 -11 1 754.3 90.0 161.9 1.0 11 -1 754.3 46.8 161.6 0. 193.0 1.0 11 -1 754.3 75.0 47.0 1.0 11 -1 754.3 135.0 47.0 1.0 -11 -1 754.3 4.1 35.0 0. 19.0 1.0 -11 -1 754.3 90.0 172.4 1.0 11 1 -754.3 -4.1 215.0 0. 134.7 1.0 11 1 -754.3 90.0 56.7 1.0 -11 1 -754.3 -46.8 341.6 0. 88.0 1.0 -11 1 -754.3 90.0 103.3 1.0 11 -1 -754.3 -8.3 207.4 0. 149.4 1.0 11 -1 -754.3 90.0 42.0 1.0 -11 -1 -754.3 -53.3 350.4 0. 69.0 1.0 -11 -1 -754.3 90.0 122.3 1.0 1 11 754.3 60.1 319.7 0. 150.7 1.0 1 11 754.3 90.0 40.7 1.0 -1 11 754.3 53.9 330.5 0. 167.8 1.0 -1 11 754.3 90.0 23.6 1.0 1-11 754.3 3.8 106.6 0. 165.3 1.0 1-11 754.3 90.0 26.1 1.0 -1-11 754.3 0.4 98.7 0. 155.4 1.0 -1-11 754.3 90.0 35.9 1.0 1 11 -754.3 -0.4 278.8 0. 1.0 1.0 1 11 -754.3 90.0 190.3 1.0 -1 11 -754.3 -3.8 286.6 0. 4.0 1.0 -1 11 -754.3 90.0 187.3 1.0 1-11 -754.3 -53.9 150.5 0. 127.8 1.0 1-11 -754.3 90.0 63.6 1.0 -1-11 -754.3 -60.1 139.7 0. 118.7 1.0 -1-11 -754.3 90.0 72.7 1.0 999 PROGRAM CAM3 CAM30000 C-----PROGRAM CAM3 CAM30001 C----- CAM30002 C----- PART 3 OF THE CAMEL JOCKEY CAM30003 C-----THIS PROGRAM READS THE PARENT REFLECTION SUMS AND PSI =0 REFLECTICAM30004 C-----ONS AND THEN FORMS THE ELEMENTS OF THE DESIGN MATRIX WHICH ARE WRICAM30005 C-----TTEN OUT. CAM30006 C----- CAM30007 COMMON J0,J1M,J2M,J3M,QMX,NPRM,NTOUT,TWTH,CHI,PHI,SQWT,DV(70) CAM30008 DIMENSION AVE(30), AVSQ(30), ITITLE(40) CAM30009 C-----SET CONSTANTS CAM30010 NTIN=9 CAM30011 NTOUT=12 CAM30012 NFILEB=2 CAM30013 NFILEC=3 CAM30014 NFILED=4 CAM30015 NLIG=60 CAM30016 IQUIT=0 CAM30017 J0=0 CAM30018 J1M=2 CAM30019 J2M=7 CAM30020 J3M=7 CAM30021 QMX=1.22 CAM30022 C-----SET DIMENSIONS CAM30023 NPRM=70 CAM30024 NPAR=30 CAM30025 C-----SET CONSTANTS (REAL) CAM30026 RAD=0.0174532925 CAM30027 C-----SET UNITS AND OPEN CAM30028 CALL FOPEN (NFILEB,4HPSI0,1HB) CAM30029 CALL FOPEN (NFILEC,4HSMPR,1HB) CAM30030 CALL FOPEN (NFILED,4HDESN,1HB) CAM30031 C-----READ IN SUMMATIONS ETC FROM NFILEC CAM30032 CNOVA READ BINARY (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM30033 CDC38 READ (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM30034 READ (NFILEC) MPSI,TWMAX,(ITITLE(I),I=1,40), CAM30035 1(AVE(I),I=1,NPAR),(AVSQ (I),I=1,NPAR),SCALE ,AMU,FMUTR CAM30036 C-----WRITE TITLE AND UNITS CAM30037 WRITE (NTOUT,100) (ITITLE(I),I=1,40) CAM30038 100 FORMAT (1H0,40A2,//,20H0CAMEL JOCKEY PART 3) CAM30039 WRITE (NTOUT,105) NFILEB,NFILEC,NFILED CAM30040 105 FORMAT (23H0INPUT AND OUTPUT FILES,/1H0,2X,6HNFILEB,2X,6HNFILEC,2XCAM30041 1,6HNFILED,/,1H0,3I8) CAM30042 C-----START NFILED CAM30043 CNOVA WRITE BINARY (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM30044 CDC38 WRITE (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM30045 WRITE (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM30046 1MPSI,TWMAX,AMU,FMUTR CAM30047 C------NEW PAGE CAM30048 N1=NLIG+1 CAM30049 C----- TOP OF LOOP OF PSI=0 REFLECTIONS CAM30050 DO 135 II=1,MPSI CAM30051 N1=N1+1 CAM30052 CNOVA READ BINARY (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM30053 CDC38 READ (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM30054 READ (NFILEB) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT CAM30055 C-----CALCULATE A DASH AND ITS SIGMA AND SQUARE ROOT OF ITS WT CAM30056 AL=FIT/AVE(IPAR) CAM30057 TEMP1=AVE(IPAR)*AVE(IPAR) CAM30058 TEMP2=TEMP1*SGFIT*SGFIT+FIT*FIT*AVSQ(IPAR) CAM30059 SGAL=SQRT(TEMP2)/TEMP1 CAM30060 C SQWT=SCALE/SGAL CAM30061 SQWT=1.0 CAM30062 C-----PRINT VALUES CAM30063 IF (N1-NLIG) 120,120,110 CAM30064 110 N1=6 CAM30065 WRITE (NTOUT,115) (ITITLE(I),I=1,40) CAM30066 115 FORMAT (1H1,40A2,//,25H CAMEL JOCKEY PSI =0 DATA,//,4X,1HH,3X,1HK,CAM30067 13X,1HL,2X,2HPR,5X,4HTWTH,6X,3HCHI,6X,3HPHI,6X,9HINTENSITY,10X,5HSICAM30068 2GMA,3X,6HA DASH,4X,5HSIGMA,5X,4HSQWT) CAM30069 120 WRITE (NTOUT,125) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,AL,SGAL,CAM30070 1SQWT CAM30071 125 FORMAT (1H ,4I4,3F9.1,2F15.2,3F9.4) CAM30072 C-----CONVERT ANGLES TO RADIANS CAM30073 TWTH=DTWTH*RAD CAM30074 CHI=DCHI*RAD CAM30075 PHI=DPHI*RAD CAM30076 C-----FORM THE DERIVATIVES CAM30077 CALL S1 (0) CAM30078 IF (IQUIT) 140,130,140 CAM30079 C-----WRITE OUT THE DESIGN MATRIX ON NFILED CAM30080 130 CONTINUE CAM30081 CNOVA WRITE BINARY (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM30082 CDC38 WRITE (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM30083 WRITE (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM30084 1AL,SGAL,SQWT,(DV(I),I=1,NPRM) CAM30085 135 CONTINUE CAM30086 140 STOP CAM30087 END CAM30088 SUBROUTINE S1 (IN) S1 0000 C----- S1 0001 C-----THIS SUBROUTINE HAS TWO ENTRIES S1 0002 C-----FOR IN=0 IT FORMS THE VALUES OF THE DERIVATIVES TIMES THE SQUARE RS1 0003 C-----OOT OF WEIGHT FOR THOSE FOURIER COEFFICENTS OF EQUATION (14) OF THS1 0004 C-----E PAPER (AUTOMATIC ABSORPTION CORRECTION ETC) WHICH WE WANT TO DETS1 0005 C-----ERMINE S1 0006 C-----FOR IN = 1 IT DOES THE SUMMATION OF EQUATION (14) ASSUMING THE COES1 0007 C-----FFICENTS TO BE IN THE PD ARRAY S1 0008 C-----THESE CALCULATION FOR IN=0 AND 1 ARE PUT TOGETHER IN S1 SINCE THE S1 0009 C-----DERIVATIVES OF A DASH WITH RESPECT TO THE A(IJM) AND B(IJM) ARE NOS1 0010 C-----NE OTHER THAN THE TRIGONOMETRIC TERMS OF THE SUMMATION OF A DASH. S1 0011 C-----THE SUBROUTINE IS COMPLEX BECAUSE QUITE A NUMBER OF THE FOURIER COS1 0012 C-----FFICENTS ARE ZERO AND NOT REQUIRED IN THE NORMAL EQUATIONS. S1 0013 C----- S1 0014 COMMON J0,J1M,J2M,J3M,QMX,NPRM,NTOUT,TWTH,CHI,PHI,SQWT,DV(70) S1 0015 DIMENSION AM(1), PD(1), KEY(1) S1 0016 C------ FLOAT VALUES S1 0017 FJ1M=J1M S1 0018 FJ2M=J2M S1 0019 FJ3M=J3M S1 0020 C-----FOR IN =1 SET A DASH AND VARIANCE S1 0021 AL=0. S1 0022 VAR=0. S1 0023 C-----SET PARAMETER COUNTER AND VARIABLE COUNTER S1 0024 IP=0 S1 0025 IV=0 S1 0026 C----- S1 0027 C-----LOOP ON VALUES OF M S1 0028 C-----F31 AND F32 WILL CONTAIN THE TRIG. TERMS IN M S1 0029 C----- S1 0030 DO 240 J3=J0,J3M S1 0031 FJ3=J3 S1 0032 QT3=FJ3/FJ3M S1 0033 C-----TEST VALUE OF QT3 AGAINST LIMIT S1 0034 IF (QT3-QMX) 105,105,240 S1 0035 C-----M IS IN RANGE S1 0036 C-----CALCULATE M*PHI S1 0037 105 FJ3=FJ3*PHI S1 0038 C-----IJ3 INDICATES THE PARITY OF M S1 0039 IJ3=MOD(J3,2) S1 0040 IF (J3) 115,110,115 S1 0041 C-----M = 0 COS(M*PHI) =1. S1 0042 110 F31=1.0 S1 0043 GO TO 120 S1 0044 C-----CALCULATE COS(M*PHI) AND SIN (M*PHI) S1 0045 115 F31=COS(FJ3) S1 0046 F32=SIN(FJ3) S1 0047 C----- S1 0048 C-----LOOP ON VALUES OF J S1 0049 C-----F2 WILL CONTAIN TRIG. TERMS IN J S1 0050 C----- S1 0051 120 DO 235 J2=J0,J2M S1 0052 C-----TEST VALUE OF QT2 AGAINST LIMIT S1 0053 FJ2=J2 S1 0054 QT2=QT3+FJ2/FJ2M S1 0055 IF (QT2-QMX) 125,125,235 S1 0056 C-----IJ2 INDICATES PARITY OF J S1 0057 125 IJ2=MOD(J2,2) S1 0058 IF (IJ2-IJ3) 145,130,145 S1 0059 C-----J AND M BOTH EVEN OR BOTH ODD S1 0060 130 IF (J2) 140,135,140 S1 0061 C-----J=0 ITS COS(J*CHI) =1.0 S1 0062 135 F2=1.0 S1 0063 GO TO 155 S1 0064 C-----J.NE.0 CALCULATE COS(J*CHI) S1 0065 140 F2=COS(FJ2*CHI) S1 0066 GO TO 155 S1 0067 C-----J AND M OF DIFFERENT PARITY S1 0068 C-----ITS A SIN(J*CHI) THUS NO PARAMETER IF J=0 S1 0069 145 IF (J2) 150,235,150 S1 0070 C-----CALCULATE SIN(J*CHI) S1 0071 150 F2=SIN(FJ2*CHI) S1 0072 C----- S1 0073 C-----LOOP ON I(TWTH) S1 0074 C-----F1 WILL CONTAIN TRIG. TERM IN I S1 0075 C----- S1 0076 155 DO 230 J1=J0,J1M S1 0077 FJ1=J1 S1 0078 QT1=QT2+FJ1/FJ1M S1 0079 C------TEST VALUE OF QT1 AGAINST LINIT S1 0080 IF (QT1-QMX) 160,160,230 S1 0081 160 IF (IJ2) 180,165,180 S1 0082 165 IF (J1) 175,170,175 S1 0083 170 F1=1.0 S1 0084 C-----J EVEN AND I=0 THUS COS(I*TWTH) =1.0 S1 0085 GO TO 190 S1 0086 C-----J EVEN I.NE.0 THUS COS(I*TWTH) S1 0087 175 F1=COS(FJ1*TWTH) S1 0088 GO TO 190 S1 0089 180 IF (J1) 185,230,185 S1 0090 C-----J ODD AND I=0 SIN(I*TWTH)=0. NO PARAMETER S1 0091 C-----J ODD AND I.NE 0 THUS ITS SIN(J*TWTH) S1 0092 185 F1=SIN(FJ1*TWTH) S1 0093 190 IF (IN) 195,220,195 S1 0094 C-----IN=1 WE ARE GOING TO FORM THE SUM KEEPING THE INDIVIDUAL DERIV. S1 0095 C-----COUNT PARAMETER S1 0096 195 IP=IP+1 S1 0097 C-----IS THE PARAMETER A VARIABLE S1 0098 IF (KEY(IP)) 205,205,200 S1 0099 C-----YES COUNT IT AND CALCULATE INDIVIDUAL TRIPLE PRODUCT TRIG.TERM A(IS1 0100 200 IV=IV+1 S1 0101 DV(IV)=F1*F2*F31 S1 0102 C-----ADD INTO SUMMATION S1 0103 AL=AL+PD(IV)*DV(IV) S1 0104 205 IF (J3) 210,230,210 S1 0105 C-----M.NE. THUS WE HAVE A B(IJM) AS WELL S1 0106 C-----DO SAME AS FOR A(IJM) S1 0107 210 IP=IP+1 S1 0108 IF (KEY(IP)) 230,230,215 S1 0109 215 IV=IV+1 S1 0110 DV(IV)=F1*F2*F32 S1 0111 AL=AL+PD(IV)*DV(IV) S1 0112 GO TO 230 S1 0113 C-----IN =0 COUNT PARAMETER S1 0114 220 IP=IP+1 S1 0115 C-----YES COUNT VARIABLE AND STORE INDIVIDUAL DREIVATIVE*SQWT S1 0116 IV=IV+1 S1 0117 DV(IV)=F1*F2*F31*SQWT S1 0118 IF (J3) 225,230,225 S1 0119 C-----SAME THING FOR B(IJM) S1 0120 225 IP=IP+1 S1 0121 IV=IV+1 S1 0122 DV(IV)=F1*F2*F32*SQWT S1 0123 C-----BOTTOM OF I LOOP S1 0124 230 CONTINUE S1 0125 C-----BOTTOM OF J LOOP S1 0126 235 CONTINUE S1 0127 C-----BOTTOM OF M LOOPP S1 0128 240 CONTINUE S1 0129 IF (IP-NPRM) 255,255,245 S1 0130 C-----TOO MANY PARAMETERS S1 0131 245 WRITE (NTOUT,250) IP,NPRM S1 0132 250 FORMAT (20H0TOO MANY PARAMETERS,2I5) S1 0133 IQUIT=1 S1 0134 GO TO 295 S1 0135 255 CONTINUE S1 0136 IF (IN) 260,295,260 S1 0137 C-----FOR IN=1 CALCULATE VARIANCE OF A DASH S1 0138 C-----AM CONTAINS THE VARIANCE COVARIANCE MATRIX S1 0139 260 K=1 S1 0140 L=IV S1 0141 C-----COUNT OVER ROWS S1 0142 DO 290 I=1,IV S1 0143 C-----BYPASS IF DERIVATIVE IS ZERO S1 0144 IF (DV(I)) 270,265,270 S1 0145 265 K=K+L S1 0146 GO TO 290 S1 0147 270 C=1.0 S1 0148 C-----COUNT OVER COLUMNS IN TOP TRIANGLE S1 0149 DO 285 J=I,IV S1 0150 IF (DV(J)) 275,280,275 S1 0151 C-----SUM VARIANCE S1 0152 275 VAR=VAR+C*DV(I)*DV(J)*AM(K) S1 0153 280 K=K+1 S1 0154 285 C=2. S1 0155 290 L=L-1 S1 0156 C-----PUT E.S.D IN SGAL S1 0157 SGAL=SQRT(VAR) S1 0158 295 CONTINUE S1 0159 RETURN S1 0160 END S1 0161 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM4 CAM40000 C PROGRAM CAM4 CAM40001 C----- CAM40002 C-----PART 4 OF CAMEL JOCKEY CAM40003 C-----THIS PROGRAM READS THE DESIGN MATRIX CAM40004 C-----LINE BY LINE AND FORMS THE MATRIX OF NORMAL EQUATIONS CAM40005 C-----FOR ALL THE PARAMETERS CAM40006 C----- CAM40007 COMMON J0,J1M,J2M,J3M,QMX,MPRM,NPRM,NTOUT,IQUIT,ICLB,SOBS,TWMAX,ALCAM40008 1,SQWT,KEY(70),LABEL(70),DV(70),V(70),AM(2485) CAM40009 DIMENSION ITITLE(40) CAM40010 C-----SET CONSTANTS CAM40011 NTIN=9 CAM40012 NTOUT=12 CAM40013 NFILED=4 CAM40014 NFILEE=5 CAM40015 NLIG=60 CAM40016 IQUIT=0 CAM40017 C-----SET DIMENSIONS CAM40018 NPRM=70 CAM40019 NAM=2485 CAM40020 C-----ZERO ARRAYS CAM40021 DO 100 I=1,NAM CAM40022 100 AM(I)=0.0 CAM40023 DO 105 I=1,NPRM CAM40024 105 V(I)=0.0 CAM40025 SOBS=0.0 CAM40026 C-----SET UNITS AND OPEN THEM CAM40027 CALL FOPEN (NFILED,4HDESN,1HB) CAM40028 CALL FOPEN (NFILEE,4HMATR,1HB) CAM40029 C-----READ FIRST LOGICAL RECORD OF NFILED CAM40030 CNOVA READ BINARY (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40031 CDC38 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40032 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40033 1MPSI,TWMAX,AMU,FMUTR CAM40034 C-----PRINT TITLE CAM40035 WRITE (NTOUT,110) (ITITLE(I),I=1,40) CAM40036 110 FORMAT (1H0,40A2,//,20H0CAMEL JOCKEY PART 4) CAM40037 WRITE (NTOUT,115) NFILED,NFILEE CAM40038 115 FORMAT (23H0INPUT AND OUTPUT UNITS,/,1H0,2X,6HNFILED,2X,6HNFILEE,/CAM40039 1,1H0,2I8) CAM40040 C-----SET KEY AND LABEL AND MPRM CAM40041 CALL CJKY CAM40042 C-----TOP OF LOOP FOR READING DESIGN MATRIX CAM40043 DO 120 II=1,MPSI CAM40044 CNOVA READ BINARY (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM40045 CDC38 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM40046 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT, CAM40047 1AL,SGAL,SQWT,(DV(I),I=1,NPRM) CAM40048 C-----STORE DERIVATIVES IN MATRIX AND VECTOR CAM40049 CALL CJMS CAM40050 120 CONTINUE CAM40051 C-----START NFILEE WITH MPRM CAM40052 CNOVA WRITE BINARY (NFILEE) MPRM CAM40053 CDC38 WRITE (NFILEE) MPRM CAM40054 WRITE (NFILEE) MPRM CAM40055 C-----WRITE NFILEE WITH MATRIX BY ROWS CAM40056 KK=0 CAM40057 DO 125 J=1,MPRM CAM40058 JJ=KK+1 CAM40059 KK=JJ+MPRM-J CAM40060 CNOVA WRITE BINARY (NFILEE) (AM(I),I=JJ,KK) CAM40061 CDC38 WRITE (NFILEE) (AM(I),I=JJ,KK) CAM40062 WRITE (NFILEE) (AM(I),I=JJ,KK) CAM40063 125 CONTINUE CAM40064 C-----WRITE VECTOR CAM40065 CNOVA WRITE BINARY (NFILEE) (V(I),I=1,MPRM) CAM40066 CDC38 WRITE (NFILEE) (V(I),I=1,MPRM) CAM40067 WRITE (NFILEE) (V(I),I=1,MPRM) CAM40068 C-----WRITE REST CAM40069 CNOVA WRITE BINARY (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40070 CDC38 WRITE (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40071 WRITE (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM40072 1MPSI,ICLB,(LABEL(I),I=1,MPRM),(KEY(I),I=1,MPRM),SOBS,AMU,FMUTR CAM40073 STOP CAM40074 END CAM40075 SUBROUTINE CJKY CJKY0000 C----- CJKY0001 C-----THIS SUBROUTINE SETS THE INITIAL VALUES OF THE KEY AND LABEL ARRAYCJKY0002 C-----S AND MPRM. CJKY0003 C-----KEY POSITIVE MEANS THAT A PARAMETER IS A VARIABLE ,OTHERWISE NOT. CJKY0004 C-----KEY WILL CONTAIN VALUES WHICH ALLOW THE PARAMETERS TO BE CHANGED ICJKY0005 C-----TO VARIABLES ACCORDING TO AN ORDER OF PRIORITY. STUDY THIS SUBROUCJKY0006 C-----INE TO SEE HOW ITS DONE. CJKY0007 C-----LABEL CONTAINS A PACKED VERSION OF I,J,AND M FOR PRINTING PURPOSESCJKY0008 C-----(POSITIVE A NEGATIVE B) CJKY0009 C----- CJKY0010 COMMON J0,J1M,J2M,J3M,QMX,MPRM,NPRM,NTOUT,IQUIT,ICLB,SOBS,TWMAX,ALCJKY0011 1,SQWT,KEY(70),LABEL(70),DV(70),V(70),AM(2485) CJKY0012 C-----SET CONSTANTS CJKY0013 ICJ1=50+100*IFIX((180./TWMAX)**2) CJKY0014 ICJ2=99 CJKY0015 ICJ3=101 CJKY0016 ICLB=1+MAX0(J1M,J2M,J3M) CJKY0017 C-----SET PARAMETER POINTER TO ZERO CJKY0018 IP=0 CJKY0019 C-----THE THREE LOOPS ON J1 J2 AND J3 FIND WHICH FOURIER COEFFICENTS ARECJKY0020 C-----USED AND NOT ZERO.THE SAME SEQUENCE OF INSTRUCTIONS IS USED IN SUCJKY0021 C-----BROUTINE S1 AND ARE FULLY COMMENTED IN S1. HENCE REFER TO CJKY0022 C-----S1 TO UNDERSTAND HOW THIS WORKS CJKY0023 C----- CJKY0024 C-----LOOP ON M(PHI) CJKY0025 FJ1M=J1M CJKY0026 FJ2M=J2M CJKY0027 FJ3M=J3M CJKY0028 DO 155 J3=J0,J3M CJKY0029 FJ3=J3 CJKY0030 QT3=FJ3/FJ3M CJKY0031 IF (QT3-QMX) 105,105,155 CJKY0032 105 IJ3=MOD(J3,2) CJKY0033 DO 150 J2=J0,J2M CJKY0034 FJ2=J2 CJKY0035 QT2=QT3+FJ2/FJ2M CJKY0036 IF (QT2-QMX) 110,110,150 CJKY0037 110 IJ2=MOD(J2,2) CJKY0038 IF (IJ2-IJ3) 115,120,115 CJKY0039 115 IF (J2) 120,150,120 CJKY0040 C-----LOOP ON I(THWTH) CJKY0041 120 DO 145 J1=J0,J1M CJKY0042 FJ1=J1 CJKY0043 QT1=QT2+FJ1/FJ1M CJKY0044 IF (QT1-QMX) 125,125,145 CJKY0045 125 IF (IJ2) 130,135,130 CJKY0046 130 IF (J1) 135,145,135 CJKY0047 C-----THIS IS AN A PARAMETER. COUNT IT CJKY0048 135 IP=IP+1 CJKY0049 C-----FORM LABEL CJKY0050 LABEL(IP)=ICLB*ICLB*J1+ICLB*J2+J3 CJKY0051 C-----FORM KEY CJKY0052 KEY(IP)=ICJ1*J1*J1+ICJ2*J2*J2+ICJ3*J3*J3+1 CJKY0053 IF (J3) 140,145,140 CJKY0054 C-----THERE IS A B COEFFICENT. TREAT LIKE A. CJKY0055 140 IP=IP+1 CJKY0056 LABEL(IP)=-ICLB*ICLB*J1-ICLB*J2-J3 CJKY0057 KEY(IP)=ICJ1*J1*J1+ICJ2*J2*J2+ICJ3*J3*J3+2 CJKY0058 C-----BOTTOM OF LOOPS CJKY0059 145 CONTINUE CJKY0060 150 CONTINUE CJKY0061 155 CONTINUE CJKY0062 MPRM=IP CJKY0063 IF (MPRM-NPRM) 170,170,160 CJKY0064 160 WRITE (NTOUT,165) MPRM,NPRM CJKY0065 165 FORMAT (20H0TOO MANY PARAMETERS,2I5) CJKY0066 IQUIT=1 CJKY0067 GO TO 195 CJKY0068 170 CONTINUE CJKY0069 C----- MAKE SURE THAT NO KEYS HAVE SAME VALUE CJKY0070 DO 190 IK1=2,MPRM CJKY0071 175 IK2=IK1-1 CJKY0072 DO 185 IK3=1,IK2 CJKY0073 IF (KEY(IK1)-KEY(IK3)) 185,180,185 CJKY0074 180 KEY(IK1)=KEY(IK1)+1 CJKY0075 GO TO 175 CJKY0076 185 CONTINUE CJKY0077 190 CONTINUE CJKY0078 195 RETURN CJKY0079 END CJKY0080 SUBROUTINE CJMS CJMS0000 C----- CJMS0001 C-----SUBROUTINE TO STORE CALCULATED DERIVATIVES(DV) IN MATRIX AND CJMS0002 C-----VECTOR. DV CONTAINS DERIVATIVE TIMES SQUARE ROOT OF WEIGHT CJMS0003 C------ CJMS0004 COMMON J0,J1M,J2M,J3M,QMX,MPRM,NPRM,NTOUT,IQUIT,ICLB,SOBS,TWMAX,ALCJMS0005 1,SQWT,KEY(70),LABEL(70),DV(70),V(70),AM(2485) CJMS0006 C-----INTO DAL WE PUT SQWT*SQRT(AL) SINCE WE FIX ON SQRT (A DASH) CJMS0007 DAL = SQWT*SQRT(AL) CJMS0008 C----- START LOOP TO STORE MATRIX AND VECTOR. CJMS0010 N=MPRM+1 CJMS0011 JJ=1 CJMS0012 C-----LOOP OVER ROWS CJMS0013 DO 115 J=1,MPRM CJMS0014 TEMP=DV(J) CJMS0015 IF (TEMP) 105,100,105 CJMS0016 C BY-PASS IF DERIVATIVE IS ZERO CJMS0017 100 JJ=JJ+N-J CJMS0018 GO TO 115 CJMS0019 C-----LOOP OVER COLUMNS IN UPPER TRIANGLE CJMS0020 105 DO 110 K=J,MPRM CJMS0021 C-----ADD INTO MATRIX CJMS0022 AM(JJ)=AM(JJ)+DV(K)*TEMP CJMS0023 JJ=JJ+1 CJMS0024 110 CONTINUE CJMS0025 C-----ADD INTO VECTOR CJMS0026 V(J)=V(J)+TEMP*DAL CJMS0027 115 CONTINUE CJMS0028 C END LOOP TO STORE MATRIX AND VECTOR CJMS0029 C-----SUM THE OBS SQUARED CJMS0030 SOBS=SOBS+DAL*DAL CJMS0031 RETURN CJMS0032 END CJMS0033 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM5 CAM50000 C PROGRAM CAM5 CAM50001 C----- CAM50002 C-----PART 5 OF CAMEL JOCKEY CAM50003 C-----PROGRAM TO SELECT VARIABLES FROM PARAMETERS,INVERT MATRIX AND MAKECAM50004 C-----STATISTICAL TESTS CAM50005 C-----THE PROGRAM USES A VARIANCE RATIO TEST ((N-P)*R(P-1)-R(P))/R(P) CAM50006 C-----WHICH IS COMPARED AGAINST AN APPROXIMATE VALUE OF F(1,N-P,0.15). CAM50007 C-----THE F TABLE IS STORED AS F=AF/(N-P)**2 + BF. CAM50008 C----- CAM50009 COMMON AM(465) CAM50010 DIMENSION ITITLE(40) CAM50011 DIMENSION KEY(70), LABEL(70), ROW(70), V(70) CAM50012 C-----SET CONSTANTS CAM50013 NTIN=9 CAM50014 NTOUT=12 CAM50015 NFILEE=5 CAM50016 NFILEF=6 CAM50017 IQUIT=0 CAM50018 C-----SET CONSTANTS (REAL) CAM50019 AF=76.0 CAM50020 BF=2.17 CAM50021 SGTS=0.04 CAM50022 RTST=0.15 CAM50023 C-----SET DIMENSIONS CAM50024 NPRM=70 CAM50025 NAM=465 CAM50026 NVAR=30 CAM50027 C-----SET UNITS AND OPEN THEM CAM50028 CALL FOPEN (NFILEE,4HMATR,1HB) CAM50029 CALL FOPEN (NFILEF,4HMATI,1HB) CAM50030 C-----READ IN NFILEE SKIPPING MATRIX AND VECTOR AND MPRM CAM50031 CNOVA READ BINARY (NFILEE) MPRM CAM50032 CDC38 READ (NFILEE) MPRM CAM50033 READ (NFILEE) MPRM CAM50034 DO 105 J=1,MPRM CAM50035 KK=MPRM-J+1 CAM50036 CNOVA READ BINARY (NFILEE) (ROW(I),I=1,KK) CAM50037 CDC38 READ (NFILEE) (ROW(I),I=1,KK) CAM50038 READ (NFILEE) (ROW(I),I=1,KK) CAM50039 105 CONTINUE CAM50040 CNOVA READ BINARY (NFILEE) (V(I),I=1,MPRM) CAM50041 CDC38 READ (NFILEE) (V(I),I=1,MPRM) CAM50042 READ (NFILEE) (V(I),I=1,MPRM) CAM50043 CNOVA READ BINARY (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM50044 CDC38 READ (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM50045 READ (NFILEE) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX, CAM50046 1MPSI,ICLB,(LABEL(I),I=1,MPRM),(KEY(I),I=1,MPRM),SOBS,AMU,FMUTR CAM50047 C-----PRINT TITLE CAM50048 WRITE (NTOUT,110) (ITITLE(I),I=1,40) CAM50049 110 FORMAT (1H0,40A2,//,20H CAMEL JOCKEY PART 5) CAM50050 WRITE (NTOUT,115) NFILEE,NFILEF CAM50051 115 FORMAT (23H0INPUT AND OUTPUT UNITS,/,1H0,2X,6HNFILEE,2X,6HNFILEF,/CAM50052 1,1H0,2I8) CAM50053 C-----CHECK NUMBER OF PARAMETERS CAM50054 IF (MPRM-NPRM) 130,130,120 CAM50055 120 WRITE (NTOUT,125) MPRM,NPRM CAM50056 125 FORMAT (20H0TOO MANY PARAMETERS,2I5) CAM50057 IQUIT=1 CAM50058 GO TO 415 CAM50059 C-----SWITCH OFF KEYS CAM50060 130 CONTINUE CAM50061 DO 135 II=1,MPRM CAM50062 KEY(II)=-KEY(II) CAM50063 135 CONTINUE CAM50064 C-----IVAR COUNTS VARIABLES CAM50065 IVAR=0 CAM50066 C-----SET STATISTICAL PARAMETERS FOR ZEROETH CYCLE CAM50067 SUMSQP=SOBS CAM50068 C----- GO THRU PARAMETERS THREE TIMES CAM50069 DO 405 IWIND=1,3 CAM50070 C----- LOOK FOR SMALLEST NEGATIVE KEY CAM50071 KILL=0 CAM50072 LAST=0 CAM50073 NEXT=-32767 CAM50074 DO 150 II=1,MPRM CAM50075 IF (KEY(II)) 140,150,150 CAM50076 140 IF (NEXT-KEY(II)) 145,150,150 CAM50077 145 NEXT=KEY(II) CAM50078 150 CONTINUE CAM50079 C-----TOP OF MATRIX READING AND INVERTING LOOP CAM50080 155 REWIND NFILEE CAM50081 CNOVA READ BINARY (NFILEE) MPRM CAM50082 CDC38 READ (NFILEE) MPRM CAM50083 READ (NFILEE) MPRM CAM50084 C-----SWITCH ON NEXT VARIABLES KEEPING INDICATION FOR NEXT CYCLE AND OF CAM50085 C-----THIS CYCLE CAM50086 ITEMP=NEXT CAM50087 IS=0 CAM50088 IJ=0 CAM50089 DO 210 II=1,MPRM CAM50090 IF (KEY(II)-ITEMP) 190,185,160 CAM50091 160 IF (KEY(II)) 165,210,165 CAM50092 C-----NULLIFY INSIGNIFICANT VARIABLES FROM LAST CYCLE CAM50093 165 IF (KEY(II)-LAST) 210,170,210 CAM50094 170 IVAR=IVAR-1 CAM50095 IF (KILL) 180,175,180 CAM50096 175 KEY(II)=-KEY(II) CAM50097 GO TO 210 CAM50098 180 KEY(II)=0 CAM50099 KILL=0 CAM50100 GO TO 210 CAM50101 185 KEY(II)=-KEY(II) CAM50102 IJ=1 CAM50103 IVAR=IVAR+1 CAM50104 GO TO 210 CAM50105 190 IF (IS) 200,195,200 CAM50106 195 IS=1 CAM50107 NEXT=KEY(II) CAM50108 200 IF (NEXT-KEY(II)) 205,210,210 CAM50109 205 NEXT=KEY(II) CAM50110 210 CONTINUE CAM50111 LAST=-ITEMP CAM50112 C-----WERE ANY PARAMETERS SWITCHED ON CAM50113 IF (IJ) 405,405,215 CAM50114 C-----READ IN THE MATRIX BY RECORDS AND BUILD UP MATRIX CAM50115 215 CONTINUE CAM50116 C-----JJ IS A POINTER TO MATRIX ELEMENT AM(J,K) CAM50117 NSM=0 CAM50118 DO 260 J=1,MPRM CAM50119 CNOVA READ BINARY (NFILEE) (ROW(I),I=J,MPRM) CAM50120 CDC38 READ (NFILEE) (ROW(I),I=J,MPRM) CAM50121 READ (NFILEE) (ROW(I),I=J,MPRM) CAM50122 IF (KEY(J)) 260,260,220 CAM50123 220 DO 255 K=J,MPRM CAM50124 IF (KEY(K)) 255,255,225 CAM50125 225 NSM=NSM+1 CAM50126 IF (NAM-NSM) 230,240,240 CAM50127 230 WRITE (NTOUT,235) NAM CAM50128 235 FORMAT (15H0MATRIX TOO BIG,I5) CAM50129 GO TO 415 CAM50130 240 CONTINUE CAM50131 AM(NSM)=ROW(K) CAM50132 C----- KEEP DIAGONAL TERM AND POINTER FOR NEW VARIABLE CAM50133 IF (J-K) 255,245,255 CAM50134 245 IF (KEY(J)-LAST) 255,250,255 CAM50135 250 DIAG=AM(NSM) CAM50136 IDG=NSM CAM50137 255 CONTINUE CAM50138 260 CONTINUE CAM50139 C-----READ VECTOR AND FILL V CAM50140 CNOVA READ BINARY(NFILEE) (ROW(I),I=1,MPRM) CAM50141 CDC38 READ (NFILEE) (ROW(I),I=1,MPRM) CAM50142 READ (NFILEE) (ROW(I),I=1,MPRM) CAM50143 II=0 CAM50144 DO 270 I=1,MPRM CAM50145 IF (KEY(I)) 270,270,265 CAM50146 265 II=II+1 CAM50147 V(II)=ROW(I) CAM50148 270 CONTINUE CAM50149 C-----TEST MATRIX FOR ZERO DIAGONAL ELEMENTS CAM50150 ISING=0 CAM50151 II=1 CAM50152 IID=IVAR CAM50153 DO 290 I=1,IVAR CAM50154 IF (AM(II)) 285,275,285 CAM50155 275 ISING=1 CAM50156 WRITE (NTOUT,280) I CAM50157 280 FORMAT (62H MATRIX HAS A ZERO DIAGONAL ELEMENT CORRESPONDING TO PACAM50158 1RAMETER,I3,16H OF THOSE VARIED) CAM50159 285 II=II+IID CAM50160 IID=IID-1 CAM50161 290 CONTINUE CAM50162 IF (ISING) 295,300,295 CAM50163 295 IQUIT=1 CAM50164 GO TO 415 CAM50165 C-----INVERT MATRIX CAM50166 300 CONTINUE CAM50167 CALL CJMV (IVAR,ISING) CAM50168 IF (ISING) 305,315,305 CAM50169 C-----SINGULAR MATRIX CAM50170 305 WRITE (NTOUT,310) ISING CAM50171 310 FORMAT (53H SINGULARITY RETURN FROM MATRIX INVERTER, ELEMENT NO.,ICAM50172 15) CAM50173 IQUIT=1 CAM50174 GO TO 415 CAM50175 C-----TOP OF LOOP TO MULTIPLY VECTOR DASH BY INVERSE MATRIX BY VECTOR CAM50176 C-----TO CALCULATE SUM OF SQUARES ABOUT REGRESSION CAM50177 315 SSAR=0.0 CAM50178 K=1 CAM50179 DO 325 I=1,IVAR CAM50180 C=1.0 CAM50181 DO 320 J=I,IVAR CAM50182 SSAR=SSAR+C*V(I)*V(J)*AM(K) CAM50183 K=K+1 CAM50184 320 C=2.0 CAM50185 325 CONTINUE CAM50186 C-----CALCULATE SUM OF SQUARES CAM50187 SUMSQ=SOBS-SSAR CAM50188 C-----CALCULATE X AND SIGMA CAM50189 X=1.0/FLOAT(MPSI-IVAR) CAM50190 SIG=SQRT(SUMSQ*X) CAM50191 VAR=SIG*SIG CAM50192 C-----CALCULATE VARIANCE RATIO AND VALUE OF F(1,N-P,ALPHA) CAM50193 VARAT=(SUMSQP-SUMSQ)/(X*SUMSQ) CAM50194 VART=AF*X*X+BF CAM50195 C-----PRINT STATISTICS CAM50196 WRITE (NTOUT,330) MPSI,IVAR,MPRM,SUMSQ,SIG,VARAT CAM50197 330 FORMAT (10H0CYCLE FOR,I4,5H OBS,,I4,13H VARIABLES OF,I4,11H PARAMECAM50198 1TERS,34H SUM(WEIGHT*(Y OBS - Y CALC)**2) =,E15.7,/,34H SQRT(SUM/(NCAM50199 2UM OBS - NUM PARAM)) =,F12.5,37H VARIANCE RATIO WITH PREVIOUS CYCCAM50200 3LE=,F12.5) CAM50201 C------MAKE SURE WE HAVE NO PROBLEMS OF PRECISION CAM50202 IF (SUMSQ) 335,345,345 CAM50203 335 WRITE (NTOUT,340) CAM50204 340 FORMAT (40H NEGATIVE SUM OF SQUARES VARIABLE KILLED) CAM50205 KILL=1 CAM50206 GO TO 155 CAM50207 C-----GOOD CALCULATION CAM50208 345 CONTINUE CAM50209 C----- TEST TO SEE IF (1 - R**2) WHERE R IS THE MULTIPLE CORRELATION CAM50210 C----- COEFFICENT IS NOT TOO SMALL CAM50211 RVAL=1.0/(DIAG*AM(IDG)) CAM50212 IF (RVAL-RTST) 350,350,360 CAM50213 350 WRITE (NTOUT,355) RVAL CAM50214 355 FORMAT (7H SMALL(,F5.2,37H) VALUE OF 1 - R1**2, VARIABLE KILLED) CAM50215 KILL=1 CAM50216 GO TO 155 CAM50217 360 CONTINUE CAM50218 C-----TEST VARIANCE RATIO TO SEE IF VARIANCE WAS SIGNIFICANT CAM50219 IF (VARAT-VART) 365,365,375 CAM50220 C-----INSIGNIFICANT NEW VARIABLE CAM50221 365 WRITE (NTOUT,370) CAM50222 370 FORMAT (30H NEW VARIABLE NOT SIGNIFICANT) CAM50223 GO TO 155 CAM50224 C-----KEEP LAST VARIABLES CAM50225 375 LAST=0 CAM50226 C-----WRITE OUT INVERSE MATRIX ON NFILEF CAM50227 REWIND NFILEF CAM50228 CNOVA WRITE BINARY (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM50229 CDC38 WRITE (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM50230 WRITE (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM50231 1MPRM,MPSI,NSM,(LABEL(I),I=1,MPRM),(KEY(I),I=1,MPRM),(AM(I),I=1,NSMCAM50232 2),(V(I),I=1,IVAR),SOBS,VAR,ICLB,AMU,FMUTR CAM50233 SUMSQP=SUMSQ CAM50234 C----- TEST TO SEE IF DESIRED PRECISION ATTAINED CAM50235 IF (SIG-SGTS) 380,380,390 CAM50236 380 WRITE (NTOUT,385) CAM50237 385 FORMAT (27H0DESIRED PRECISION ATTAINED) CAM50238 GO TO 415 CAM50239 C----- TEST TO SEE IF WEVE GOT ENOUGH VARIABLES CAM50240 390 IF (IVAR-NVAR) 155,395,395 CAM50241 395 WRITE (NTOUT,400) CAM50242 400 FORMAT (30H0SUFFICENT NUMBER OF VARIABLES) CAM50243 GO TO 415 CAM50244 405 CONTINUE CAM50245 WRITE (NTOUT,410) CAM50246 410 FORMAT (23H0THREE CYCLES COMPLETED) CAM50247 415 CONTINUE CAM50248 STOP CAM50249 END CAM50250 SUBROUTINE CJMV (N,NFAIL) CJMV0000 COMMON AM( 465) CJMV0001 C ********** SEGMENT 1 OF CHOLESKI INVERSION ********** CJMV0002 C ***** FACTOR MATRIX INTO LOWER TRIANGLE X TRANSPOSE ***** CJMV0003 K=1 CJMV0004 IF (N-1) 135,100,105 CJMV0005 100 AM(1)=1.0/AM(1) CJMV0006 GO TO 185 CJMV0007 C ***** LOOP M OF A(L,M) ***** CJMV0008 105 DO 150 M=1,N CJMV0009 IMAX=M-1 CJMV0010 C ***** LOOP L OF A(L,M) ***** CJMV0011 DO 145 L=M,N CJMV0012 SUMA=0.0 CJMV0013 KLI=L CJMV0014 KMI=M CJMV0015 IF (IMAX) 120,120,110 CJMV0016 C *****SUM OVER I=1,M-1 A(L,I)*A(M,I) ***** CJMV0017 110 DO 115 I=1,IMAX CJMV0018 SUMA=SUMA+AM(KLI)*AM(KMI) CJMV0019 J=N-I CJMV0020 KLI=KLI+J CJMV0021 115 KMI=KMI+J CJMV0022 C *****TERM=C(L,M)-SUM ***** CJMV0023 120 TERM=AM(K)-SUMA CJMV0024 IF (L-M) 125,125,140 CJMV0025 125 IF (TERM) 135,135,130 CJMV0026 C ***** A(M,M)=SQRT(TERM) ***** CJMV0027 130 DENOM=SQRT(TERM) CJMV0028 AM(K)=DENOM CJMV0029 GO TO 145 CJMV0030 135 NFAIL=K CJMV0031 GO TO 190 CJMV0032 C ***** A(L,M)=TERM/A(M,M) ***** CJMV0033 140 AM(K)=TERM/DENOM CJMV0034 145 K=K+1 CJMV0035 150 CONTINUE CJMV0036 C ********** SEGMENT 2 OF CHOLESKI INVERSION ********** CJMV0037 C *****INVERSION OF TRIANGULAR MATRIX***** CJMV0038 AM(1)=1.0/AM(1) CJMV0039 KDM=1 CJMV0040 C ***** STEP L OF B(L,M) ***** CJMV0041 DO 165 L=2,N CJMV0042 KDM=KDM+N-L+2 CJMV0043 C ***** RECIPROCAL OF DIAGONAL TERM ***** CJMV0044 TERM=1.0/AM(KDM) CJMV0045 AM(KDM)=TERM CJMV0046 KMI=0 CJMV0047 KLI=L CJMV0048 IMAX=L-1 CJMV0049 C ***** STEP M OF B(L,M) ***** CJMV0050 DO 160 M=1,IMAX CJMV0051 K=KLI CJMV0052 C ***** SUM TERMS ***** CJMV0053 SUMA=0.0 CJMV0054 DO 155 I=M,IMAX CJMV0055 II=KMI+I CJMV0056 SUMA=SUMA-AM(KLI)*AM(II) CJMV0057 155 KLI=KLI+N-I CJMV0058 C ***** MULT SUM * RECIP OF DIAGONAL ***** CJMV0059 AM(K)=SUMA*TERM CJMV0060 J=N-M CJMV0061 KLI=K+J CJMV0062 160 KMI=KMI+J CJMV0063 165 CONTINUE CJMV0064 C ********** SEGMENT 3 OF CHOLESKI INVERSION ********** CJMV0065 C *****PREMULTIPLY LOWER TRIANGLE BY TRANSPOSE***** CJMV0066 K=1 CJMV0067 DO 180 M=1,N CJMV0068 KLI=K CJMV0069 DO 175 L=M,N CJMV0070 KMI=K CJMV0071 IMAX=N-L+1 CJMV0072 SUMA=0.0 CJMV0073 DO 170 I=1,IMAX CJMV0074 SUMA=SUMA+AM(KLI)*AM(KMI) CJMV0075 KLI=KLI+1 CJMV0076 170 KMI=KMI+1 CJMV0077 AM(K)=SUMA CJMV0078 175 K=K+1 CJMV0079 180 CONTINUE CJMV0080 185 NFAIL=0 CJMV0081 190 RETURN CJMV0082 END CJMV0083 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM6 CAM60000 C PROGRAM CAM6 CAM60001 C----- CAM60002 C-----PART 6 OF CAMEL JOCKEY CAM60003 C-----PROGRAM TO PRINT OUT CORRELATION MATRIX CAM60004 C----- CAM60005 COMMON ICLB,LABEL(70),IVAR,NTOUT,DIAG(30),AM( 465) CAM60006 DIMENSION ROW(30), ITITLE(40), KEY(70) CAM60007 C-----SET CONSTANTS CAM60008 NTIN=9 CAM60009 NTOUT=12 CAM60010 NFILEF=6 CAM60011 ICMO=1 CAM60012 C-----SET DIMENSIONS CAM60013 NPRM=70 CAM60014 NAM=465 CAM60015 C-----SET UNIT AND OPEN CAM60016 CALL FOPEN (NFILEF,4HMATI,1HB) CAM60017 C-----READ IN NFILEF CAM60018 CNOVA READ BINARY(NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM60019 CDC38 READ (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM60020 READ (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM60021 1MPRM,MPSI,NSM,(LABEL(I),I=1,MPRM), (KEY(I),I=1,MPRM),(AM(I),I=1,NSCAM60022 2M),(ROW(I),I=1,IVAR),SOBS,VAR,ICLB,AMU,FMUTR CAM60023 C-----PRINT A TITLE CAM60024 WRITE (NTOUT,100) (ITITLE(I),I=1,40) CAM60025 100 FORMAT (1H0,40A2,//,20H CAMEL JOCKEY PART 6) CAM60026 WRITE (NTOUT,105) NFILEF CAM60027 105 FORMAT (11H0INPUT UNIT,/,1H0,2X,6HNFILEF,/,1H0,I8) CAM60028 C-----COLLAPSE LABEL ARRAY CAM60029 J=1 CAM60030 DO 115 I=1,MPRM CAM60031 IF (KEY(I)) 115,115,110 CAM60032 110 LABEL(J)=LABEL(I) CAM60033 J=J+1 CAM60034 115 CONTINUE CAM60035 C-----FORM 1./ ESD IN DIAG CAM60036 IJ=1 CAM60037 IJD=IVAR CAM60038 DO 120 J=1,IVAR CAM60039 DIAG(J)=1.0/SQRT(AM(IJ)) CAM60040 IJ=IJ+IJD CAM60041 IJD=IJD-1 CAM60042 120 CONTINUE CAM60043 C-----PRINT LARGE TERMS OF CORRL MATRIX CAM60044 CALL CJCT CAM60045 IF (ICMO) 125,155,125 CAM60046 C-----FULL MATRIX CAM60047 125 WRITE (NTOUT,130) CAM60048 130 FORMAT (20H1 CORRELATION MATRIX) CAM60049 IJ=1 CAM60050 C-----LOOP OVER ROWS CAM60051 DO 150 I=1,IVAR CAM60052 DO 135 J=1,IVAR CAM60053 ROW(J)=0.0 CAM60054 135 CONTINUE CAM60055 C-----LOOP OVER COLUMNS CAM60056 DO 140 J=I,IVAR CAM60057 C-----CALCULATE CORRELATION COEFFICENTS CAM60058 ROW(J)=AM(IJ)*DIAG(I)*DIAG(J) CAM60059 IJ=IJ+1 CAM60060 140 CONTINUE CAM60061 WRITE (NTOUT,145) I,(ROW(J),J=I,IVAR) CAM60062 145 FORMAT (1H0,I3,10F9.4/(1H ,3X,10F9.4)) CAM60063 C-----BOTTOM OF LOOPS CAM60064 150 CONTINUE CAM60065 155 CONTINUE CAM60066 STOP CAM60067 END CAM60068 SUBROUTINE CJCT CJCT0000 C----- CJCT0001 C-----IDENTIFY AND PRINT LARGE ELEMENTS OF CORRELATION MATRIX CJCT0002 C----- CJCT0003 COMMON ICLB,LABEL(70),IVAR,NTOUT,DIAG(30),AM( 465) CJCT0004 CORBIG=0.6001 CJCT0005 C-----IS THERE A MATRIX CJCT0006 IF (IVAR) 170,170,100 CJCT0007 C-----TITLE CJCT0008 100 WRITE (NTOUT,105) CORBIG CJCT0009 105 FORMAT (58H0 ELEMENTS OF CORRELATION MATRIX OF MAGNITUDE GREATER TCJCT0010 1HAN,F5.2,/1X) CJCT0011 IBIG=0 CJCT0012 IJ=0 CJCT0013 C-----LOOP OVER ROWS CJCT0014 DO 155 IV=1,IVAR CJCT0015 IROW=0 CJCT0016 C-----LOOP OVER COLUMNS IN UPPER TRIANGLE CJCT0017 DO 150 JV=IV,IVAR CJCT0018 IJ=IJ+1 CJCT0019 IF (IV-JV) 110,150,110 CJCT0020 C-----CALCULATE CORRELATION COEFFICENT CJCT0021 110 CORFC=AM(IJ)*DIAG(IV)*DIAG(JV) CJCT0022 C-----TEST VALUE CJCT0023 IF (ABS(CORFC)-CORBIG) 150,115,115 CJCT0024 C----- FIND ROW NAME FIRST TIME ONLY CJCT0025 115 IF (IROW) 125,120,125 CJCT0026 120 IROW=1 CJCT0027 C-----FIND NAME OF THE PARAMETER IN THIS ROW CJCT0028 CALL CJVL (IV,LAR,J1,J2,J3) CJCT0029 C-----FIND NAME OF PARAMETER IN THIS COLUMN CJCT0030 125 CALL CJVL (JV,LAC,I1,I2,I3) CJCT0031 IBIG=1 CJCT0032 C-----MARK AND PRINT CJCT0033 IF (IROW-1) 130,130,140 CJCT0034 130 WRITE (NTOUT,135) LAR,J1,J2,J3,LAC,I1,I2,I3,CORFC CJCT0035 135 FORMAT (1H ,A1,1X,3I1,1H-,3X,A1,1X,3I1,6X,F7.4) CJCT0036 IROW=2 CJCT0037 GO TO 150 CJCT0038 140 WRITE (NTOUT,145) LAC,I1,I2,I3,CORFC CJCT0039 145 FORMAT (1H ,5X,1H-,3X,A1,1X,3I1,6X,F7.4) CJCT0040 C-----BOTTOM OF LOOPS CJCT0041 150 CONTINUE CJCT0042 155 CONTINUE CJCT0043 IF (IBIG) 170,160,170 CJCT0044 C-----DONT HAVE ANY BIG ELEMENTS CJCT0045 160 WRITE (NTOUT,165) CJCT0046 165 FORMAT (11H NONE FOUND) CJCT0047 170 RETURN CJCT0048 END CJCT0049 SUBROUTINE CJVL (I,IAB,I1,I2,I3) CJVL0000 C------ CJVL0001 C-----SUBROUTINE TO FIND LABEL. LABEL IN PACKED FORM IN LABEL(I). CJVL0002 C-----POSITIVE A NEGATIVE B CJVL0003 C----- CJVL0004 COMMON ICLB,LABEL(70) CJVL0005 CNOVA COMMON /DAT/IA,IB CJVLA005 COMMON /DAT/IA,IB CJVLB005 DATA IA,IB/1HA,1HB/ CJVLC005 ILB=LABEL(I) CJVL0006 C-----SET A BY DEFAULT CJVL0007 IAB=IA CJVL0008 C-----IS IT A OR B COEFFIECENT CJVL0009 IF (ILB) 100,105,105 CJVL0010 100 IAB=IB CJVL0011 C-----TAKE ABSOLUTE VALUE OF LABEL CJVL0012 105 ILB=IABS(ILB) CJVL0013 C-----UNPACK THE LABEL CJVL0014 I3=MOD(ILB,ICLB) CJVL0015 ILB=ILB/ICLB CJVL0016 I2=MOD(ILB,ICLB) CJVL0017 I1=ILB/ICLB CJVL0018 RETURN CJVL0019 END CJVL0020 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM7 CAM70000 C PROGRAM CAM7 CAM70001 C----- CAM70002 C-----PART 7 OF CAMEL JOCKEY CAM70003 C-----PROGRAM TO CALCULATE VALUES OF FOURIER COEFICENTS AND THEIR CAM70004 C-----ESD AND VARIANCE COVARIANCE MATRIX CAM70005 C----- CAM70006 COMMON ICLB,LABEL(70),ROW(70) CAM70007 DIMENSION DIAG(30), KEY(70), PD(30), V(30), DV(70), ITITLE(40), AMCAM70008 1( 465) CAM70009 EQUIVALENCE (ROW(1),DV(1)), (ROW(1),V(1)) CAM70010 C-----SET CONSTANTS CAM70011 NTIN=9 CAM70012 NTOUT=12 CAM70013 NFILED=4 CAM70014 NFILEF=6 CAM70015 NFILEG=7 CAM70016 IQUIT=0 CAM70017 C-----SET DIMENSIONS CAM70018 NPRM=70 CAM70019 NAM= 465 CAM70020 C-----SET UNITS AND OPEN THEM CAM70021 CALL FOPEN (NFILED,4HDESN,1HB) CAM70022 CALL FOPEN (NFILEF,4HMATI,1HB) CAM70023 CALL FOPEN (NFILEG,4HVCOM,1HB) CAM70024 C-----READ IN FIRST RECORD OF NFILED CAM70025 CNOVA READ BINARY(NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI, CAM70026 CDC38 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI, CAM70027 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI, CAM70028 1TWMAX,AMU,FMUTR CAM70029 C-----READ IN INVERSE MATRIX CAM70030 CNOVA READ BINARY (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70031 CDC38 READ (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70032 READ (NFILEF) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70033 1MPRM,MPSI,NSM,(LABEL(I),I=1,MPRM),(KEY(I),I=1,MPRM),(AM(I),I=1,NSMCAM70034 2),(V(I),I=1,IVAR),SOBS,VAR,ICLB,AMU,FMUTR CAM70035 C-----PRINT A TITLE AND UNITS CAM70036 WRITE (NTOUT,100) (ITITLE(I),I=1,40) CAM70037 100 FORMAT (1H0,40A2,//,20H CAMEL JOCKEY PART 7) CAM70038 WRITE (NTOUT,105) NFILED,NFILEF,NFILEG CAM70039 105 FORMAT (23H0INPUT AND OUTPUT UNITS,/,1H0,2X,6HNFILED,2X,6HNFILEF,2CAM70040 1X,6HNFILEG,/,1H0,3I8) CAM70041 C-----COLLAPSE LABEL ARRAY TO INCLUDE ONLY THE VARIABLES CAM70042 J=1 CAM70043 DO 115 I=1,MPRM CAM70044 IF (KEY(I)) 115,115,110 CAM70045 110 LABEL(J)=LABEL(I) CAM70046 J=J+1 CAM70047 115 CONTINUE CAM70048 C-----TOP OF LOOP TO MULTIPLTY INVERSE MATRIX BY VECTOR CAM70049 DO 140 I=1,IVAR CAM70050 PDI=0.0 CAM70051 IJ=I CAM70052 IJD=IVAR-1 CAM70053 DO 135 J=1,IVAR CAM70054 PDI=PDI+AM(IJ)*V(J) CAM70055 IF (J-I) 120,125,130 CAM70056 120 IJ=IJ+IJD CAM70057 IJD=IJD-1 CAM70058 GO TO 135 CAM70059 C-----STORE DIAGONAL ELEMENTS OF INVERSE MATRIX CAM70060 125 DIAG(I)=AM(IJ) CAM70061 130 IJ=IJ+1 CAM70062 135 CONTINUE CAM70063 C-----STORE FOURIER COEFFICENT CAM70064 PD(I)=PDI CAM70065 C-----BOTTOM OF LOOP CAM70066 140 CONTINUE CAM70067 C-----CALCULATE SIG= SUM(WEIGHT*(AOBS - A CALC)**2) CAM70068 SIG=0.0 CAM70069 DO 155 IV=1,MPSI CAM70070 C-----READ IN DESIGN MATRIX ELEMENT CAM70071 CNOVA READ BINARY(NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,AL, CAM70072 CDC38 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,AL, CAM70073 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,AL, CAM70074 1SGAL,SQWT,(DV(I),I=1,NPRM) CAM70075 C-----SET INITIAL VALUES CAM70076 WTAL=0.0 CAM70077 C-----CALCULATE VALUE CAM70078 J=1 CAM70079 DO 150 I=1,MPRM CAM70080 IF (KEY(I)) 150,150,145 CAM70081 145 WTAL=WTAL+PD(J)*DV(I) CAM70082 J=J+1 CAM70083 150 CONTINUE CAM70084 WDY=SQWT*SQRT(AL) - WTAL CAM70085 155 SIG=SIG+WDY*WDY CAM70086 C-----ALLOW FOR NUMBER OF OBSERVATIONS CAM70087 SQSIG=SQRT(SIG/FLOAT(MPSI-IVAR)) CAM70088 VARI=SQSIG**2 CAM70089 C-----CALCULATE VARIANCE COVARIANCE MATRIX CAM70090 DO 160 I=1,NSM CAM70091 160 AM(I)=AM(I)*VARI CAM70092 C-----CALCULTE VARIANCE VECTOR CAM70093 DO 165 I=1,IVAR CAM70094 165 DIAG(I)=VARI*DIAG(I) CAM70095 C-----PRINT VALUES OF FOURIER COEFFICENTS AND THEIR ERRORS CAM70096 WRITE (NTOUT,170) (ITITLE(I),I=1,40) CAM70097 170 FORMAT (1H1,40A2,/,56H0 FOURIER COEFFICENTS OF NORMALISED TRANSMISCAM70098 1SION FACTOR ,//,11H COEFFICENT,10X,5HVALUE,10X,5HSIGMA) CAM70099 C-----TOP OF PRINTING LOOP CAM70100 DO 180 I=1,IVAR CAM70101 C-----FIND E S D CAM70102 ERN=SQRT(DIAG(I)) CAM70103 C-----FIND LABEL CAM70104 CALL CJVL (I,IAB,I1,I2,I3) CAM70105 WRITE (NTOUT,175) IAB,I1,I2,I3,PD(I),ERN CAM70106 175 FORMAT (1H ,A1,1H(,3I2,2H ),2F15.6) CAM70107 180 CONTINUE CAM70108 C-----PRINT OUT STATISTICS CAM70109 WRITE (NTOUT,185) MPSI,IVAR,SIG,SQSIG CAM70110 185 FORMAT (11H0STATISTICS,//,26H NUMBER OF OBSERVATIONS IS,I5,24H.NUMCAM70111 1BER OF VARIABLES IS,I5,/,34H0SUM(WEIGHT*(Y OBS - Y CALC)**2) =,E1CAM70112 25.7,/,34H0SQRT(SUM/(NUM OBS - NUM PARAM)) =,F12.5) CAM70113 C-----WRITE OUT NFILEG CAM70114 CNOVA WRITE BINARY(NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70115 CDC38 WRITE (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70116 WRITE (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM70117 1MPRM,NSM,(KEY(I),I=1,MPRM),(PD(I),I=1,IVAR),(AM(I),I=1,NSM) CAM70118 2,AMU,FMUTR CAM7A118 STOP CAM70119 END CAM70120 SUBROUTINE CJVL (I,IAB,I1,I2,I3) CJVL0000 C----- CJVL0001 C-----SUBROUTINE TO FIND LABEL. LABEL IN PACKED FORM IN LABEL(I). CJVL0002 C-----POSITIVE A NEGATIVE B CJVL0003 C----- CJVL0004 COMMON ICLB,LABEL(70) CJVL0005 CNOVA COMMON /DAT/IA,IB CJVLA005 COMMON /DAT/IA,IB CJVLB005 DATA IA,IB/1HA,1HB/ CJVLC005 ILB=LABEL(I) CJVL0006 C-----SET A BY DEFAULT CJVL0007 IAB=IA CJVL0008 C-----IS IT A OR B COEFFIECENT CJVL0009 IF (ILB) 100,105,105 CJVL0010 100 IAB=IB CJVL0011 C-----TAKE ABSOLUTE VALUE OF LABEL CJVL0012 105 ILB=IABS(ILB) CJVL0013 C-----UNPACK THE LABEL CJVL0014 I3=MOD(ILB,ICLB) CJVL0015 ILB=ILB/ICLB CJVL0016 I2=MOD(ILB,ICLB) CJVL0017 I1=ILB/ICLB CJVL0018 RETURN CJVL0019 END CJVL0020 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM8 CAM80000 C PROGRAM CAM8 CAM80001 C------ CAM80002 C------CAMEL JOCKEY PART 8 CAM80003 C-----PROGRAM TO PRODUCE CORRECTED INTENSITIES AND STATISTICS FOR CAM80004 C-----PSI=0 REFLECTIONS CAM80005 C----- CAM80006 DIMENSION ITITLE(40), KEY(70), DV(70), PD(30), AM( 465), COUN(30),CAM80007 1 SUMA(30), SUMB(30), SUMC(30), SUMD(30),COUM(30) CAM80008 C-----SET CONSTANTS CAM80009 NTIN=9 CAM80010 NTOUT=12 CAM80011 NFILED=4 CAM80012 NFILEG=7 CAM80013 IQUIT=0 CAM80014 NLIG=60 CAM80015 C-----SET DIMENSIONS CAM80016 NPRM=70 CAM80017 NAM= 465 CAM80018 NPAR=30 CAM80019 C-----ZERO ARRAYS CAM80020 DO 100 I=1,NPAR CAM80021 SUMA(I)=0.0 CAM80022 SUMB(I)=0.0 CAM80023 SUMC(I)=0.0 CAM80024 SUMD(I)=0.0 CAM80025 COUM(I)=0.0 CAM8A025 100 COUN(I)=0.0 CAM80026 C-----SET UNITS AND OPEN THEM CAM80027 CALL FOPEN (NFILED,4HDESN,1HB) CAM80028 CALL FOPEN (NFILEG,4HVCOM,1HB) CAM80029 C-----READ IN FIRST RECORD OF NFILED CAM80030 CNOVA READ BINARY (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI,TWCAM80031 CDC38 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI,TWCAM80032 READ (NFILED) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,MPSI,TWCAM80033 1MAX,AMU,FMUTR CAM80034 C-----READ IN VARIANCE-COVARIANCE MATRIX CAM80035 CNOVA READ BINARY (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR,MPCAM80036 CDC38 READ (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR,MPCAM80037 READ (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR,MPCAM80038 1RM,NSM,(KEY(I),I=1,MPRM),(PD(I),I=1,IVAR),(AM(I),I=1,NSM) CAM80039 2,AMU,FMUTR CAM8A039 C-----PRINT A TITLE AND UNITS CAM80040 WRITE (NTOUT,105) (ITITLE(I),I=1,40) CAM80041 105 FORMAT (1H0,40A2,//,20H CAMEL JOCKEY PART 8) CAM80042 WRITE (NTOUT,110) NFILED,NFILEG CAM80043 110 FORMAT (23H0INPUT AND OUTPUT UNITS,/,1H0,2X,6HNFILED,2X,6HNFILEG,/CAM80044 1,1H0,2I8) CAM80045 C----- CAM80046 C-----THIS SECTION PRINTS OUT THE PSI=0 REFLECTIONS TO VERIFY THE ABSORCAM80047 C-----PRTION CORRECTION AND IS FOLLOWED BY STATISTICS PRINTING OF CAM80048 C-----PARENT REFLECTIONS CAM80049 C----- CAM80050 C-----NEW PAGE CAM80051 N1=NLIG+1 CAM80052 C-----TOP OF LOOP OF PRINTING CAM80053 DO 170 II=1,MPSI CAM80054 N1=N1+1 CAM80055 IF (N1-NLIG) 130,130,115 CAM80056 115 N1=7 CAM80057 WRITE (NTOUT,120) (ITITLE(I),I=1,40) CAM80058 120 FORMAT (1H1,40A2,/43H0 PSI=0 REFLECTIONS TO VERIFY CAMEL JOCKEY) CAM80059 WRITE (NTOUT,125) CAM80060 125 FORMAT (4X,1HH,3X,1HK,3X,1HL,2X,2HPR,3X,8HOBSERVED,4X,7H(SIGMA),1XCAM80061 1,10HABSORPTION,4X,7H(SIGMA),2X,9HCORRECTED,4X,7H(SIGMA),4X,6HA DASCAM80062 2H,3X,7H(SIGMA),4X,6HA DASH,3X,7H(SIGMA),/,19X,9HINTENSITY,12X,10HCCAM80063 3ORRECTION,13X,9HINTENSITY,16X,3HOBS,17X,4HCALC,/) CAM80064 130 CONTINUE CAM80065 C-----READ IN PSI=0 REFLECTION CAM80066 CNOVA READ BINARY(NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,ALO,SGCAM80067 CDC38 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,ALO,SGCAM80068 READ (NFILED) IH,IK,IL,IPAR,DTWTH,DCHI,DPHI,FIT,SGFIT,ALO,SGCAM80069 1ALO,SQWT,(DV(I),I=1,NPRM) CAM80070 C-----COLLAPSE DV ARRAY TO INCLUDE ONLY THE VARIABLES CAM80071 J=1 CAM80072 DO 140 I=1,MPRM CAM80073 IF (KEY(I)) 140,140,135 CAM80074 135 DV(J)=DV(I) CAM80075 J=J+1 CAM80076 140 CONTINUE CAM80077 C-----SET INTITAL VALUES CAM80078 WTAL=0.0 CAM80079 VAR=0.0 CAM80080 C-----CALCULATE VALUE CAM80081 DO 145 I=1,IVAR CAM80082 145 WTAL=WTAL+PD(I)*DV(I) CAM80083 AL=WTAL/SQWT CAM80084 C-----CALCULATE VARIANCE CAM80085 K=1 CAM80086 L=IVAR CAM80087 C-----COUNT OVER ROWS CAM80088 DO 155 I=1,IVAR CAM80089 C=1.0 CAM80090 C-----COUNT OVER COLUMNS CAM80091 DO 150 J=I,IVAR CAM80092 VAR=VAR+C*DV(I)*DV(J)*AM(K) CAM80093 K=K+1 CAM80094 150 C=2.0 CAM80095 155 L=L-1 CAM80096 C-----E.S.D CAM80097 SGAL=SQRT(VAR)/SQWT CAM80098 C----- CONVERT SQRT(AL) AND ITS SIGMA INTO AL ETC CAM8A098 SGAL = 2.0*ABS(AL) * SGAL CAM8B098 AL=AL*AL CAM8C098 C-----CALCULATE ABSORPTION CORRECTION CAM80099 ABCOR=1.0/AL CAM80100 SGABC=SGAL*ABCOR*ABCOR CAM80101 C-----CORRECT INTENSITY AND ITS SIGMA CAM80102 FF=ABCOR*FIT CAM80103 SGFF=SQRT(ABCOR*ABCOR*SGFIT*SGFIT+FIT*FIT*SGABC*SGABC) CAM80104 WRITE (NTOUT,160) IH,IK,IL,IPAR,FIT,SGFIT,ABCOR,SGABC,FF,SGFF,ALO,CAM80105 1SGALO,AL,SGAL CAM80106 160 FORMAT (1H ,4I4,6F11.4,4F10.4) CAM80107 C-----FORM SUMS FOR INTENSITY R VALUES CAM80108 IF (FF) 170,170,165 CAM80109 165 COUN(IPAR)=COUN(IPAR)+1.0/(SGFF*SGFF) CAM80110 COUM(IPAR)=COUM(IPAR)+1.0/(SGFIT*SGFIT) CAM8A110 SUMA(IPAR)=SUMA(IPAR)+FIT/(SGFIT*SGFIT) CAM80111 SUMB(IPAR)=SUMB(IPAR)+FF/(SGFF*SGFF) CAM80112 SUMC(IPAR)=SUMC(IPAR)+FIT*FIT/(SGFIT*SGFIT) CAM80113 SUMD(IPAR)=SUMD(IPAR)+FF*FF/(SGFF*SGFF) CAM80114 C-----BOTTOM OF LOOP CAM80115 170 CONTINUE CAM80116 C----- CAM80117 C-----CALCULATE AND PRINT INTENSITY R VALUES CAM80118 C----- CAM80119 WRITE (NTOUT,175) (ITITLE(I),I=1,40) CAM80120 175 FORMAT (1H1,40A2,/,37H0PARENT REFLECTION INTENSITY R VALUES,/,1H0,CAM80121 14X,2HPR,4X,27HBEFORE AND AFTER CORRECTION,//) CAM80122 C-----LOOP OVER PARENTS CAM80123 DO 190 I=1,NPAR CAM80124 IF (COUN(I)) 190,190,180 CAM80125 180 R1=SQRT(COUM(I)*SUMC(I)-SUMA(I)*SUMA(I))/SUMA(I) CAM80126 R2=SQRT(COUN(I)*SUMD(I)-SUMB(I)*SUMB(I))/SUMB(I) CAM80127 WRITE (NTOUT,185) I,R1,R2 CAM80128 185 FORMAT (1H ,I6,4X,F6.2,4X,F6.2) CAM80129 190 CONTINUE CAM80130 STOP CAM80131 END CAM80132 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SCOPE PROGRAM CAM9 CAM90000 C PROGRAM CAM9 CAM90001 C----- CAM90002 C-----CAMEL JOCKEY PART 9 CAM90003 C-----PROGRAM TO CORRECT INTENSITIES FOR NORMAL DATA COLLECTION CAM90004 C----- CAM90005 COMMON J0,J1M,J2M,J3M,QMX,NPRM,NTOUT,TWTH,CHI,PHI,SQWT,DV(30),PD(3CAM90006 10),KEY(70),AM( 465),ABCOR,SGABC,AL,SGAL,AMU,FMUTR,TBAR,IQUIT CAM90007 DIMENSION ITITLE(40) CAM90008 C-----SET CONSTANTS CAM90009 NTIN=9 CAM90010 NTOUT=12 CAM90011 NFILEG=7 CAM90012 NFILEH=8 CAM90013 NFILEI=9 CAM90014 IQUIT=0 CAM90015 NLIG=60 CAM90016 C-----SET DIMENSIONS CAM90017 NPRM=70 CAM90018 NAM= 465 CAM90019 C-----SET CONSTANTS(REAL) CAM90020 RAD=0.0174532925 CAM90021 C-----OPEN NFILEG CAM90022 CALL FOPEN (NFILEG,4HVCOM,1HB) CAM90023 C-----READ IN VARIANCE COVARIANCE MATRIX CAM90024 CNOVA READ BINARY (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM90025 CDC38 READ (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM90026 READ (NFILEG) (ITITLE(I),I=1,40),J0,J1M,J2M,J3M,QMX,IVAR, CAM90027 1MPRM,NSM,(KEY(I),I=1,MPRM),(PD(I),I=1,IVAR),(AM(I),I=1,NSM) CAM90028 2,AMU,FMUTR CAM9A028 C-----PRINT TITLE AND UNITS CAM90029 WRITE (NTOUT,100) (ITITLE(I),I=1,40),NFILEG,NFILEH,NFILEI,AMU,FMUTCAM90030 1R CAM90031 100 FORMAT (1H0,40A2,//,20H CAMEL JOCKEY PART 9,/,23H0INPUT AND OUTPUTCAM90032 1 UNITS,/,1H0,2X,6HNFILEG,2X,6HNFILEH,2X,6HNFILEI,/,1H0,3I8,/,5H0MUCAM90033 2 =,F8.2,15HCM**-1, MU*R =,F6.2) CAM90034 C-----CLOSE NFILEG AND OPEN THE OTHERS CAM90035 CALL FCLOS (NFILEG) CAM90036 CALL FOPEN (NFILEH,4HNORM,1H ) CAM90037 CALL FOPEN (NFILEI,4HCORD,1H ) CAM90038 C-----NEW PAGE CAM90039 N1=NLIG+1 CAM90040 C----- CAM90041 C-----READ IN NORMAL DATA COLLECTION FROM NFILEH CAM90042 C-----CALCULATE ITS ABSORPTION CORRECTION AND PUT OUT CORRECTED VALUES OCAM90043 C------ON NFILEI. CAM90044 C----- CAM90045 C-----TOP OF CORRECTION LOOP CAM90046 105 READ (NFILEH,110) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,FIT,SGFICAM90047 1T CAM90048 110 FORMAT (1X,3I3,5F8.2,F8.4,F12.2,F10.2) CAM90049 IF (IH-999) 115,190,115 CAM90050 C-----SET IMARK CAM90051 C-----IMARK =0,ABSORPTION CORRECTION POSSIBLE CAM90052 C-----IMARK = 1 NOT POSSIBLE AS PSI NE 0. CAM90053 115 IMARK=0 CAM90055 N1=N1+1 CAM90056 C-----TEST PSI CAM90057 IF (DPSI) 120,125,120 CAM90058 120 IMARK=1 CAM90059 GO TO 140 CAM90060 C-----CONVERT ANGLES TO RADIANS CAM90061 125 TWTH=RAD*DTWTH CAM90062 CHI=RAD*DCHI CAM90063 PHI=RAD*DPHI CAM90064 C-----CALCULATE ABSORPTION CORRECTION CAM90065 CALL SPHEXT CAM90066 C-----CORRECT INTENSITY AND ITS SIGMA CAM90071 CRINT=FIT*ABCOR CAM90072 SGCRI=SQRT(FIT*FIT*SGABC*SGABC+ABCOR*ABCOR*SGFIT*SGFIT) CAM90073 C-----WRITE NFILEI CAM90074 WRITE (NFILEI,110) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,CRINT,SCAM90075 1GCRI CAM90076 C-----PRINT VALUES OR MESSAGES CAM90077 140 IF (N1-NLIG) 155,155,145 CAM90078 145 N1=7 CAM90079 WRITE (NTOUT,150) (ITITLE(I),I=1,40) CAM90080 150 FORMAT (1H1,40A2,//,26H CORRECTION OF NORMAL DATA,//,5X,1HH,4X,1HKCAM90081 1,4X,1HL,4X,8HOBSERVED,5X,7H(SIGMA),6X,9HCORRECTED,8X,7H(SIGMA),2X,CAM90082 26HA DASH,1X,7H(SIGMA),3X,7HABSORPT,3X,7H(SIGMA),6X,4HTBAR,/,16X,3XCAM90083 3,9HINTENSITY,18X,9HINTENSITY,18X,4HCALC,13X,6HCORRN.,/) CAM90084 155 CONTINUE CAM90085 III=IMARK+1 CAM90086 GO TO (160,170 ), III CAM90087 C-----PRINT VALUES CAM90088 160 WRITE (NTOUT,165) IH,IK,IL,FIT,SGFIT,CRINT,SGCRI,AL,SGAL,ABCOR,SGACAM90089 1BC,TBAR CAM90090 165 FORMAT (1H ,3I5,2F12.2,2F15.2,2F8.4,2F10.3,F10.5) CAM90091 GO TO 105 CAM90092 C-----PRINT MESSAGES FOR IMARK = 1 CAM90093 170 WRITE (NTOUT,175) IH,IK,IL,FIT,SGFIT CAM90094 175 FORMAT (1H ,3I5,2F12.2,5X,28HNO CAMEL JOCKEY AS PSI.NE.0.) CAM90095 GO TO 105 CAM90096 C-----BOTTOM OF CORRECTING LOOP CAM90102 C-----FINISH OFF NFILEI CAM90103 190 WRITE (NFILEI,110) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,CRINT,SCAM90104 1GCRI CAM90105 C-----WEVE FINISHED CAM90106 WRITE (NTOUT,195) CAM90107 195 FORMAT (22H0CAMEL JOCKEY FINISHED) CAM90108 STOP CAM90109 END CAM90110 SUBROUTINE SPHEXT SPXT0000 C----- SPXT0001 C-----SUBROUTINE TO CALCULATE ABSORPTION CORRECTION FOR ANGLE TWTH,CHI,PSPXT0002 C-----HI. PSI=0 PNLY. CALCULATES CAMEL JOCKEY CORRECTION TIMES SPHERICSPXT0003 C-----AL CRYSTAL ABSORPTION SPXT0004 C----- SPXT0005 COMMON J0,J1M,J2M,J3M,QMX,NPRM,NTOUT,TWTH,CHI,PHI,SQWT,DV(30),PD(3SPXT0006 10),KEY(70),AM( 465),ABCOR,SGABC,AL,SGAL,AMU,FMUTR,TBAR,IQUIT SPXT0007 CNOVA COMMON /STOCK/ TABLE(84),ARG(2),NENT(2),ENT(19) SPXT0008 CDC38 DIMENSION TABLE(84),ARG(2),NENT(2),ENT(19) SPXT0009 DIMENSION TABLE(84),ARG(2),NENT(2),ENT(19) SPXTA009 C-----TABLE DERIVED FROM PAGE 300 OF INTERNATIONAL TABLES VOL.2. IT IS SPXT0010 C-----A 2D. TABLE OF -LOG(A) AS A FUNTION OF MU*R AND THETA(IN DEGREES) SPXT0011 DATA NENT(1),NENT(2)/7,12/ SPXT0012 DATA ENT(1),ENT(2),ENT(3),ENT(4),ENT(5),ENT(6),ENT(7),ENT(8),ENT(9SPXT0013 1),ENT(10),ENT(11),ENT(12),ENT(13),ENT(14),ENT(15),ENT(16),ENT(17),SPXT0014 2ENT(18),ENT(19)/0.,15.,30.,45.,60.,75.,90.,0.,0.5,1.0,2.,3.,4.,5.,SPXT0015 36.,7.,8.,9.,10./ SPXT0016 DATA TABLE(1),TABLE(2)/0.,0./ SPXT0017 DATA TABLE(3),TABLE(4)/0.,0./ SPXT0018 DATA TABLE(5),TABLE(6)/0.,0./ SPXT0019 DATA TABLE(7),TABLE(8)/0.,0.730205/ SPXT0020 DATA TABLE(9),TABLE(10)/0.72501,0.70997/ SPXT0021 DATA TABLE(11),TABLE(12)/0.68818,0.66507/ SPXT0022 DATA TABLE(13),TABLE(14)/0.647051,0.64008/ SPXT0023 DATA TABLE(15),TABLE(16)/1.41679,1.39384/ SPXT0024 DATA TABLE(17),TABLE(18)/1.33287,1.25414/ SPXT0025 DATA TABLE(19),TABLE(20)/1.17847,1.12267/ SPXT0026 DATA TABLE(21),TABLE(22)/1.10136,2.63918/ SPXT0027 DATA TABLE(23),TABLE(24)/2.53313,2.30589/ SPXT0028 DATA TABLE(25),TABLE(26)/2.07449,1.88500/ SPXT0029 DATA TABLE(27),TABLE(28)/1.75510,1.70562/ SPXT0030 DATA TABLE(29),TABLE(30)/3.64736,3.39621/ SPXT0031 DATA TABLE(31),TABLE(32)/2.97104,2.61142/ SPXT0032 DATA TABLE(33),TABLE(34)/2.34237,2.16300/ SPXT0033 DATA TABLE(35),TABLE(36)/2.09346,4.46020/ SPXT0034 DATA TABLE(37),TABLE(38)/4.02575,3.43331/ SPXT0035 DATA TABLE(39),TABLE(40)/2.98796,2.66902/ SPXT0036 DATA TABLE(41),TABLE(42)/2.45842,2.37494/ SPXT0037 DATA TABLE(43),TABLE(44)/5.11883,4.49006/ SPXT0038 DATA TABLE(45),TABLE(46)/3.77357,3.27148/ SPXT0039 DATA TABLE(47),TABLE(48)/2.92007,2.68884/ SPXT0040 DATA TABLE(49),TABLE(50)/2.59535,5.66360/ SPXT0041 DATA TABLE(51),TABLE(52)/4.84533,4.03872/ SPXT0042 DATA TABLE(53),TABLE(54)/3.49694,3.12288/ SPXT0043 DATA TABLE(55),TABLE(56)/2.87706,2.77611/ SPXT0044 DATA TABLE(57),TABLE(58)/6.12568,5.12874/ SPXT0045 DATA TABLE(59),TABLE(60)/4.25451,3.68369/ SPXT0046 DATA TABLE(61),TABLE(62)/3.29279,3.03634/ SPXT0047 DATA TABLE(63),TABLE(64)/2.92938,6.52590/ SPXT0048 DATA TABLE(65),TABLE(66)/5.36211,4.43543/ SPXT0049 DATA TABLE(67),TABLE(68)/3.84203,3.43859/ SPXT0050 DATA TABLE(69),TABLE(70)/3.17390,3.06230/ SPXT0051 DATA TABLE(71),TABLE(72)/6.87917,5.55942/ SPXT0052 DATA TABLE(73),TABLE(74)/4.59127,3.97977/ SPXT0053 DATA TABLE(75),TABLE(76)/3.56630,3.29522/ SPXT0054 DATA TABLE(77),TABLE(78)/3.17966,7.19557/ SPXT0055 DATA TABLE(79),TABLE(80)/5.72941,4.72688/ SPXT0056 DATA TABLE(81),TABLE(82)/4.10197,3.66399/ SPXT0057 DATA TABLE(83),TABLE(84)/3.40340,3.28475/ SPXT0058 C-----ZERO CORRECTIONS SPXT0059 ABCOR=0. SPXT0060 SGABC=0. SPXT0061 C----- SPXT0062 C-----SPHERICAL PART OF CORRECTION SPXT0063 C----- SPXT0064 C-----INDICATE THETA AND MU*R VALUES SPXT0065 ARG(1)=0.5*TWTH SPXT0066 ARG(2)=FMUTR SPXT0067 C-----INTERPOLATE IN THE TABLE SPXT0068 ALGSP=FLNT(2,ARG,NENT,ENT,TABLE) SPXT0069 C-----CALCULATE CAMEL JOCKEY TRANSMISSION SPXT0070 CALL S1 (1) SPXT0071 IF (IQUIT) 110,100,110 SPXT0072 C---- SQUARE AL AND ITS SIGMA SPXT0073 100 SGAL = 2.0*ABS(AL)*SGAL SPXT0074 AL = AL * AL SPXTA074 C-----COMBINE C J TRANSMISSION AND SPHERICAL CORRECTION SPXT0075 ABCOR=EXP(ALGSP)/AL SPXT0076 SGABC=ABCOR*SGAL/AL SPXT0077 TBAR=(ALGSP-ALOG(AL))/AMU SPXT0078 110 RETURN SPXT0079 END SPXT0080 FUNCTION FLNT (NARG,ARG,NENT,ENT,TABLE) FLNT0000 C----- FLNT0001 C-----LINEAR INTERPOLATION FUNCTION ( E104) FROM LIBRARY OF CENTRE CANTOFLNT0002 C-----NAL D,INFORMATIQUE DE GENEVE. DESCRIPTION AVAILABLE IF YOU REALLY FLNT0003 C-----WANT TO KNOW HOW IT WORKS FLNT0004 C----- FLNT0005 DIMENSION ARG(2), NENT(2), ENT(19), TABLE(84) FLNT0006 DIMENSION D(5), NCOMB(5), IENT(5) FLNT0007 KD=1 FLNT0008 M=1 FLNT0009 JA=1 FLNT0010 DO 115 I=1,NARG FLNT0011 NCOMB(I)=1 FLNT0012 JB=JA-1+NENT(I) FLNT0013 DO 100 J=JA,JB FLNT0014 IF (ARG(I).LE.ENT(J)) GO TO 105 FLNT0015 100 CONTINUE FLNT0016 J=JB FLNT0017 105 IF (J.NE.JA) GO TO 110 FLNT0018 J=J+1 FLNT0019 110 JR=J-1 FLNT0020 D(I)=(ENT(J)-ARG(I))/(ENT(J)-ENT(JR)) FLNT0021 IENT(I)=J-JA FLNT0022 KD=KD+IENT(I)*M FLNT0023 M=M*NENT(I) FLNT0024 115 JA=JB+1 FLNT0025 FLNT=0. FLNT0026 120 FAC=1. FLNT0027 IADR=KD FLNT0028 IFADR=1 FLNT0029 DO 130 I=1,NARG FLNT0030 IF (NCOMB(I).EQ.0) GO TO 125 FLNT0031 FAC=FAC*(1.-D(I)) FLNT0032 GO TO 130 FLNT0033 125 FAC=FAC*D(I) FLNT0034 IADR=IADR-IFADR FLNT0035 130 IFADR=IFADR*NENT(I) FLNT0036 FLNT=FLNT+FAC*TABLE(IADR) FLNT0037 IL=NARG FLNT0038 135 IF (NCOMB(IL).EQ.0) GO TO 145 FLNT0039 NCOMB(IL)=0 FLNT0040 IF (IL.EQ.NARG) GO TO 120 FLNT0041 IL=IL+1 FLNT0042 DO 140 K=IL,NARG FLNT0043 140 NCOMB(K)=1 FLNT0044 GO TO 120 FLNT0045 145 IL=IL-1 FLNT0046 IF (IL.NE.0) GO TO 135 FLNT0047 RETURN FLNT0048 END FLNT0049 SUBROUTINE S1 (IN) S1 0000 C----- S1 0001 C-----THIS SUBROUTINE HAS TWO ENTRIES S1 0002 C-----FOR IN=0 IT FORMS THE VALUES OF THE DERIVATIVES TIMES THE SQUARE RS1 0003 C-----OOT OF WEIGHT FOR THOSE FOURIER COEFFICENTS OF EQUATION (14) OF THS1 0004 C-----E PAPER (AUTOMATIC ABSORPTION CORRECTION ETC) WHICH WE WANT TO DETS1 0005 C-----ERMINE S1 0006 C-----FOR IN = 1 IT DOES THE SUMMATION OF EQUATION (14) ASSUMING THE COES1 0007 C-----FFICENTS TO BE IN THE PD ARRAY S1 0008 C-----THESE CALCULATION FOR IN=0 AND 1 ARE PUT TOGETHER IN S1 SINCE THE S1 0009 C-----DERIVATIVES OF A DASH WITH RESPECT TO THE A(IJM) AND B(IJM) ARE NOS1 0010 C-----NE OTHER THAN THE TRIGONOMETRIC TERMS OF THE SUMMATION OF A DASH. S1 0011 C-----THE SUBROUTINE IS COMPLEX BECAUSE QUITE A NUMBER OF THE FOURIER COS1 0012 C-----FFICENTS ARE ZERO AND NOT REQUIRED IN THE NORMAL EQUATIONS. S1 0013 C----- S1 0014 COMMON J0,J1M,J2M,J3M,QMX,NPRM,NTOUT,TWTH,CHI,PHI,SQWT,DV(30),PD(3S1 0015 10),KEY(70),AM( 465),ABCOR,SGABC,AL,SGAL,AMU,FMUTR,TBAR,IQUIT S1 0016 C------ FLOAT VALUES S1 0017 FJ1M=J1M S1 0018 FJ2M=J2M S1 0019 FJ3M=J3M S1 0020 C-----FOR IN =1 SET A DASH AND VARIANCE S1 0021 AL=0. S1 0022 VAR=0. S1 0023 C-----SET PARAMETER COUNTER AND VARIABLE COUNTER S1 0024 IP=0 S1 0025 IV=0 S1 0026 C----- S1 0027 C-----LOOP ON VALUES OF M S1 0028 C-----F31 AND F32 WILL CONTAIN THE TRIG. TERMS IN M S1 0029 C----- S1 0030 DO 240 J3=J0,J3M S1 0031 FJ3=J3 S1 0032 QT3=FJ3/FJ3M S1 0033 C-----TEST VALUE OF QT3 AGAINST LIMIT S1 0034 IF (QT3-QMX) 105,105,240 S1 0035 C-----M IS IN RANGE S1 0036 C-----CALCULATE M*PHI S1 0037 105 FJ3=FJ3*PHI S1 0038 C-----IJ3 INDICATES THE PARITY OF M S1 0039 IJ3=MOD(J3,2) S1 0040 IF (J3) 115,110,115 S1 0041 C-----M = 0 COS(M*PHI) =1. S1 0042 110 F31=1.0 S1 0043 GO TO 120 S1 0044 C-----CALCULATE COS(M*PHI) AND SIN (M*PHI) S1 0045 115 F31=COS(FJ3) S1 0046 F32=SIN(FJ3) S1 0047 C----- S1 0048 C-----LOOP ON VALUES OF J S1 0049 C-----F2 WILL CONTAIN TRIG. TERMS IN J S1 0050 C----- S1 0051 120 DO 235 J2=J0,J2M S1 0052 C-----TEST VALUE OF QT2 AGAINST LIMIT S1 0053 FJ2=J2 S1 0054 QT2=QT3+FJ2/FJ2M S1 0055 IF (QT2-QMX) 125,125,235 S1 0056 C-----IJ2 INDICATES PARITY OF J S1 0057 125 IJ2=MOD(J2,2) S1 0058 IF (IJ2-IJ3) 145,130,145 S1 0059 C-----J AND M BOTH EVEN OR BOTH ODD S1 0060 130 IF (J2) 140,135,140 S1 0061 C-----J=0 ITS COS(J*CHI) =1.0 S1 0062 135 F2=1.0 S1 0063 GO TO 155 S1 0064 C-----J.NE.0 CALCULATE COS(J*CHI) S1 0065 140 F2=COS(FJ2*CHI) S1 0066 GO TO 155 S1 0067 C-----J AND M OF DIFFERENT PARITY S1 0068 C-----ITS A SIN(J*CHI) THUS NO PARAMETER IF J=0 S1 0069 145 IF (J2) 150,235,150 S1 0070 C-----CALCULATE SIN(J*CHI) S1 0071 150 F2=SIN(FJ2*CHI) S1 0072 C----- S1 0073 C-----LOOP ON I(TWTH) S1 0074 C-----F1 WILL CONTAIN TRIG. TERM IN I S1 0075 C----- S1 0076 155 DO 230 J1=J0,J1M S1 0077 FJ1=J1 S1 0078 QT1=QT2+FJ1/FJ1M S1 0079 C------TEST VALUE OF QT1 AGAINST LINIT S1 0080 IF (QT1-QMX) 160,160,230 S1 0081 160 IF (IJ2) 180,165,180 S1 0082 165 IF (J1) 175,170,175 S1 0083 170 F1=1.0 S1 0084 C-----J EVEN AND I=0 THUS COS(I*TWTH) =1.0 S1 0085 GO TO 190 S1 0086 C-----J EVEN I.NE.0 THUS COS(I*TWTH) S1 0087 175 F1=COS(FJ1*TWTH) S1 0088 GO TO 190 S1 0089 180 IF (J1) 185,230,185 S1 0090 C-----J ODD AND I=0 SIN(I*TWTH)=0. NO PARAMETER S1 0091 C-----J ODD AND I.NE 0 THUS ITS SIN(J*TWTH) S1 0092 185 F1=SIN(FJ1*TWTH) S1 0093 190 IF (IN) 195,220,195 S1 0094 C-----IN=1 WE ARE GOING TO FORM THE SUM KEEPING THE INDIVIDUAL DERIV. S1 0095 C-----COUNT PARAMETER S1 0096 195 IP=IP+1 S1 0097 C-----IS THE PARAMETER A VARIABLE S1 0098 IF (KEY(IP)) 205,205,200 S1 0099 C-----YES COUNT IT AND CALCULATE INDIVIDUAL TRIPLE PRODUCT TRIG.TERM A(IS1 0100 200 IV=IV+1 S1 0101 DV(IV)=F1*F2*F31 S1 0102 C-----ADD INTO SUMMATION S1 0103 AL=AL+PD(IV)*DV(IV) S1 0104 205 IF (J3) 210,230,210 S1 0105 C-----M.NE. THUS WE HAVE A B(IJM) AS WELL S1 0106 C-----DO SAME AS FOR A(IJM) S1 0107 210 IP=IP+1 S1 0108 IF (KEY(IP)) 230,230,215 S1 0109 215 IV=IV+1 S1 0110 DV(IV)=F1*F2*F32 S1 0111 AL=AL+PD(IV)*DV(IV) S1 0112 GO TO 230 S1 0113 C-----IN =0 COUNT PARAMETER S1 0114 220 IP=IP+1 S1 0115 C-----YES COUNT VARIABLE AND STORE INDIVIDUAL DREIVATIVE*SQWT S1 0116 IV=IV+1 S1 0117 DV(IV)=F1*F2*F31*SQWT S1 0118 IF (J3) 225,230,225 S1 0119 C-----SAME THING FOR B(IJM) S1 0120 225 IP=IP+1 S1 0121 IV=IV+1 S1 0122 DV(IV)=F1*F2*F32*SQWT S1 0123 C-----BOTTOM OF I LOOP S1 0124 230 CONTINUE S1 0125 C-----BOTTOM OF J LOOP S1 0126 235 CONTINUE S1 0127 C-----BOTTOM OF M LOOPP S1 0128 240 CONTINUE S1 0129 IF (IP-NPRM) 255,255,245 S1 0130 C-----TOO MANY PARAMETERS S1 0131 245 WRITE (NTOUT,250) IP,NPRM S1 0132 250 FORMAT (20H0TOO MANY PARAMETERS,2I5) S1 0133 IQUIT=1 S1 0134 GO TO 295 S1 0135 255 CONTINUE S1 0136 IF (IN) 260,295,260 S1 0137 C-----FOR IN=1 CALCULATE VARIANCE OF A DASH S1 0138 C-----AM CONTAINS THE VARIANCE COVARIANCE MATRIX S1 0139 260 K=1 S1 0140 L=IV S1 0141 C-----COUNT OVER ROWS S1 0142 DO 290 I=1,IV S1 0143 C-----BYPASS IF DERIVATIVE IS ZERO S1 0144 IF (DV(I)) 270,265,270 S1 0145 265 K=K+L S1 0146 GO TO 290 S1 0147 270 C=1.0 S1 0148 C-----COUNT OVER COLUMNS IN TOP TRIANGLE S1 0149 DO 285 J=I,IV S1 0150 IF (DV(J)) 275,280,275 S1 0151 C-----SUM VARIANCE S1 0152 275 VAR=VAR+C*DV(I)*DV(J)*AM(K) S1 0153 280 K=K+1 S1 0154 285 C=2. S1 0155 290 L=L-1 S1 0156 C-----PUT E.S.D IN SGAL S1 0157 SGAL=SQRT(VAR) S1 0158 295 CONTINUE S1 0159 RETURN S1 0160 END S1 0161 SUBROUTINE FOPEN (IA,IB,IC) FOPN0000 IF (IA.NE.8) REWIND IA FOPN0001 RETURN FOPN0002 END FOPN0003 SUBROUTINE FCLOS (IA) FCLS0000 RETURN FCLS0001 END FCLS0002 SCOPE 2 1 19.7 4.85 58.7 206.2 0. 92.5 1.0 2 1 19.7 90.0 52.4 1.0 -2 1 19.7 12.1 6.9 0. 81.7 1.0 -2 1 19.7 90.0 63.2 1.0 4 1 218.3 9.1 53.8 187.5 0. 126.1 1.0 4 1 218.3 90. 24.3 1.0 7 2 129.1 14.5 38.7 205.0 0. 118.9 1.0 7 2 129.1 90. 39.8 0. 8 2 641.9 20.9 61.2 173.6 0. 192.5 1.0 8 2 641.9 75.0 30.9 1.0 11 1 754.3 53.3 170.4 0. 212.8 1.0 11 1 754.3 95.0 37.3 1.0 999 PROGRAM CAM1 CAM10000 C PROGRAM CAM1 CAM10001 C----- CAM10002 C-----PROGRAM TO READ DATA (HKL-SCN INTERPRETED FROM YVON) DATA FROM CARCAM10003 C-----DS AND FORMS THE DATA FILE RAWD CAM10004 C----- CAM10005 CNOVA COMMON/MES/IBL,IBD CAM1A005 COMMON/MES/IBL,IBD CAM1B005 DIMENSION FLINE(13), ITITLE(40), ISYM(9), UB(9) CAM10006 DATA IBL,IBD/2H ,2HBD/ CAM1A006 C-----SET CONSTANTS CAM10007 NLIG=60 CAM10008 NTIN=9 CAM10009 NTOUT=12 CAM10010 NFILEA=1 CAM10011 NFILEB=2 CAM10012 C-----SET CONSTANTS (REAL) CAM10013 DAR=57.29577951 CAM10014 TBAR=0.0 CAM10015 C-----OPEN OUTPUT FILE CAM10016 CALL FOPEN (NFILEA,4HRAWD) CAM10017 C-----READ IN DATA CARDS AND COPY THEM TO RAWD CAM10018 READ (NTIN,100) (ITITLE(I),I=1,40) CAM10019 WRITE (NFILEA,100) (ITITLE(I),I=1,40) CAM10020 100 FORMAT (40A2) CAM10021 READ (NTIN,105) MSYM CAM10022 WRITE (NFILEA,105) MSYM CAM10023 105 FORMAT (I5) CAM10024 DO 110 J=1,MSYM CAM10025 READ (NTIN,115) (ISYM(I),I=1,9) CAM10026 110 WRITE (NFILEA,115) (ISYM(I),I=1,9) CAM10027 115 FORMAT (9I3) CAM10028 READ (NTIN,120) AMU,FMUTR CAM10029 120 FORMAT (2F10.3) CAM10030 WRITE (NFILEA,120) AMU,FMUTR CAM10031 C-----READ PHILIP AND UB MATRIX CARDS CAM10032 READ (NTIN,125) SPE,SWDA,SWDB,STAB CAM10033 125 FORMAT (9X,F6.2,2F5.2,29X,F8.3) CAM10034 READ (NTIN,130) (UB(I),I=1,9) CAM10035 130 FORMAT (6X,9F8.4) CAM10036 CALL FCLOS (NTIN) CAM10037 C-----OPEN INPUT FILE CAM10038 CALL FOPEN (NFILEB,4HYVON) CAM10039 C-----RESET STABILITY CONSTANT CAM10040 IF (STAB.EQ.0.0) STAB=0.02 CAM10041 C-----PRINT OUT HEADINGS ETC CAM10042 WRITE (NTOUT,135) (ITITLE(I),I=1,40),NFILEA,NFILEB,AMU,FMUTR,SPE,SCAM10043 1WDA,SWDB,STAB,(UB(I),I=1,9) CAM10044 135 FORMAT (1H1,40A2,/,20H0CAMEL JOCKEY PART 1,/,23H0INPUT AND OUTPUT CAM10045 1FILES,/,1H0,2X,6HNFILEA,2X,6HNFILEB,/,1H0,2I8,/,5H0MU =,F8.2,7H CMCAM10046 2**-1,3X,6HMU*R =,F5.2,/,1H0,7X,3HSPE,6X,4HSWDA,6X,4HSWDB,6X,4HSTABCAM10047 3,/,1H0,4(5X,F5.2),/,10H0UB MATRIX,3(/,3F11.6)) CAM10048 C-----CHECK VALUE OF MU*R CAM10049 IF (FMUTR-10.0) 150,150,140 CAM10050 140 WRITE (NTOUT,145) CAM10051 145 FORMAT (23H0MU*R GREATER THAN 10.0) CAM10052 GO TO 290 CAM10053 C-----FORCE A NEW PAGE CAM10054 150 N1=NLIG+1 CAM10055 C-----SET ORDER OF TYPE 4,5 AND 6 LINES CAM1A055 IORD=0 CAM1B055 C-----TOP OF LOOP FOR INTERPRETATION OF YVON CAM10056 155 READ (NFILEB,160,END=287) (FLINE(I),I=1,13) CAM10057 160 FORMAT (1X,F5.0,F3.0,11F11.3) CAM10058 ILIG=IFIX(FLINE(1)+0.01) CAM10059 C-----SWITCH FOR LINE TYPE CAM10060 ISW=IFIX(FLINE(2)+1.1) CAM10061 GO TO (165,165,165,190,205,210,215,165), ISW CAM10062 165 IF (N1-NLIG) 180,180,170 CAM10063 170 WRITE (NTOUT,175) (ITITLE(I),I=1,40) CAM10064 175 FORMAT (1H1,40A2,//,5H NLIN,4X,1HH,4X,1HK,4X,1HL,4X,2HWD,7X,3HPSI,CAM10065 13X,3HBGT,7X,3HCB1,6X,4HCSUM,7X,3HCB2,/) CAM10066 N1=4 CAM10067 180 WRITE (NTOUT,185) ILIG,FLINE(2) CAM10068 185 FORMAT (1H ,I4,2X,9HLINE TYPE,F3.0,7HIGNORED) CAM10069 N1=N1+1 CAM10070 GO TO 155 CAM10071 C-----TYPE 3 LINE INTERPRET IT CAM10072 190 IH=IFIX(FLINE(3)+0.01) CAM10073 IK=IFIX(FLINE(4)+0.01) CAM10074 IL=IFIX(FLINE(5)+0.01) CAM10075 DPSI=FLINE(6) CAM10076 BGT=FLINE(7) CAM10077 IJ=8 CAM10078 IF (SWDB) 195,200,195 CAM10079 195 IJ=IJ+1 CAM10080 200 CB1=FLINE(IJ) CAM10081 CSUM=FLINE(IJ+1) CAM10082 CB2=FLINE(IJ+2) CAM10083 GO TO 220 CAM10084 C-----TYPE 4 LINE INTERPRET IT CAM10085 205 IH=IFIX(FLINE(3)+0.01) CAM10086 IK=IFIX(FLINE(4)+0.01) CAM10087 IL=IFIX(FLINE(5)+0.01) CAM10088 IORD=1 CAM1A088 GO TO 155 CAM10089 C-----TYPE 5 LINE INTERPRET CAM10090 210 BGT=FLINE(6) CAM10091 IF(IORD) 212,212,211 CAM1A091 211 IORD=-1 CAM1B091 GO TO 155 CAM1C091 212 IORD=0 CAM1D091 WRITE(12,213) ILIG,FLINE(2) CAM1E091 213 FORMAT(1H ,I4,2X,9HLINE TYPE,F3.0,12HOUT OF ORDER) CAM1F091 GO TO 155 CAM10092 C-----TYPE 6 LINE INTERPRET IT CAM10093 215 DPSI=FLINE(3) CAM10094 IF(IORD) 216,212,212 CAM1A094 216 CB1=FLINE(4) CAM10095 CSUM=FLINE(5) CAM10096 CB2=FLINE(6) CAM10097 GO TO 220 CAM10098 C-----CALCULATE ANGLES IF PSI =0. CAM10099 220 DTWTH=0. CAM10100 DOMG=0. CAM10101 DCHI=0. CAM10102 DPHI=0. CAM10103 X=UB(1)*FLOAT(IH)+UB(2)*FLOAT(IK)+UB(3)*FLOAT(IL) CAM10104 Y=UB(4)*FLOAT(IH)+UB(5)*FLOAT(IK)+UB(6)*FLOAT(IL) CAM10105 Z=UB(7)*FLOAT(IH)+UB(8)*FLOAT(IK)+UB(9)*FLOAT(IL) CAM10106 FSINSQ=X*X+Y*Y+Z*Z CAM10107 TANTH=SQRT(FSINSQ/(4.0-FSINSQ)) CAM10108 TEMP=DAR*ATAN2(TANTH,1.0) CAM10109 DTWTH=2.0*TEMP CAM10110 IF (DPSI) 235,225,235 CAM10111 225 DOMG=TEMP CAM10112 TEMP=SQRT(FSINSQ-Z*Z) CAM10113 DCHI=DAR*ATAN2(-Z,TEMP) CAM10114 DPHI=DAR*ATAN2(X,Y) CAM10115 IF (DPHI) 230,235,235 CAM10116 230 DPHI=DPHI+360.0 CAM10117 C-----CALCULATE INTENSITY AND SIGMA AND MARK BACKGROUND CAM10118 235 WD=SWDA+SWDB*TANTH CAM10119 PMTR=WD/SPE CAM10120 BGTR=2.0*BGT CAM10121 BG=CB1+CB2 CAM10122 B2=0.25*(CB1-CB2)**2 CAM10123 IMES=IBL CAM10124 IF (B2-5.0*BG) 245,245,240 CAM10125 240 IMES=IBD CAM10126 245 FIT=WD*(CSUM/PMTR-BG/BGTR) CAM10127 IF (FIT) 250,250,255 CAM10128 250 FIT=0. CAM10129 255 IF (B2-BG) 265,265,260 CAM10130 260 BG=B2 CAM10131 265 SS=CSUM*WD*WD/(PMTR*PMTR)+BG*WD*WD/(BGTR*BGTR)+STAB*FIT*STAB*FIT CAM10132 SGFIT=SQRT(SS) CAM10133 C-----WRITE AND PRINT VALUES CAM10134 WRITE (NFILEA,270) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,FIT,SGFCAM10135 1IT CAM10136 270 FORMAT (1X,3I3,5F8.2,F8.4,F12.2,F10.2) CAM10137 IF (N1-NLIG) 280,280,275 CAM10138 275 WRITE (NTOUT,175) (ITITLE(I),I=1,40) CAM10139 N1=4 CAM10140 280 WRITE (NTOUT,285) ILIG,IH,IK,IL,WD,DPSI,BGT,CB1,CSUM,CB2,IMES CAM10141 285 FORMAT (1H ,I4,3I5,F6.2,F10.1,F7.0,3F10.0,3X,A2) CAM10142 N1=N1+1 CAM10143 GO TO 155 CAM10144 287 IH=999 CAM10145 WRITE (NFILEA,270) IH,IK,IL,DTWTH,DOMG,DCHI,DPHI,DPSI,TBAR,FIT,SGFCAM10146 1IT CAM10147 290 STOP CAM10148 END CAM10149 SUBROUTINE INST INST0000 C INST0001 C CAMEL JOCKEY INST0002 C ----- ------ INST0003 C INST0004 C (VERSION FEVRIER 1975) INST0005 C INST0006 C AUTHOR INST0007 C HOWARD FLACK INST0008 C LABORATOIRE DISCIPLINAIRE DE CRISTALLOGRAPHIE AUX RAYONS X INST0009 C 32 BD D,YVOY INST0010 C CH-1211 GENEVE 4 INST0011 C TELEPHONE. (022) 21 93 55 INST0012 C INST0013 C PROGRAMME IMPLEMENTED ON A DATA GENERAL NOVA 840 AND CDC 3800. INST0014 C NEEDS 16K MEMORY ON THE NOVA 840 AND 6K ON THE CDC3800. INST0015 C PROGRAMMED IN FORTRAN (PIDGIN FORTRAN LIKE THE X-RAY SYSTEM) INST0016 C NEEDS DISC STORAGE FOR INTERMEDIATE RESULTS INST0017 C INST0018 C REFERENCE. INST0019 C AUTOMATIC ABSORPTION CORRECTION USING INTENSITY MEASUREMENTS FROM INST0020 C AZIMUTHAL SCANS H.D.FLACK(1974) ACTA CRYST.A30,569-573. INST0021 C INST0022 C CAMEL JOCKEY IS A SYSTEM OF NINE PROGRAMMES WHICH SHOULD BE INST0023 C EXECUTED IN THE FOLLOWING ORDER. INST0024 C INST0025 C (0. ERWIN ) - (PAPER TAPE DECODING PROGRAMME) INST0026 C 1. CAM1. FORMATION OF RAW DATA FILE INST0027 C 2. CAM2. FORMS SUMMATIONS OF PARENT REFLECTIONS INST0028 C 3. CAM3. CALCULATION OF A DASH AND DESIGN MATRIX INST0029 C 4. CAM4. FORMATION OF NORMAL EQUATIONS MATRIX INST0030 C 5. CAM5. VARIABLE SELECTOR AND MATRIX INVERSION INST0031 C 6. CAM6. PRINTS CORRELATION MATRIX INST0032 C 7. CAM7. CALCULATES VARIANCE COVARIANCE MATRIX INST0033 C 8. CAM8. CORRECTS PSI = 0 DATA INST0034 C 9. CAM9. CORRECTION OF STANDARD DATA INST0035 C INST0036 C DATA CARDS INST0037 C INST0038 C A. (ALL DATA CARDS ARE READ BY THE PROGRAMME =CAM1=) INST0039 C INST0040 C 1. FORMAT(40A2) INST0041 C COLS INST0042 C 1-80 ALPHANUMERIC TITLE INST0043 C INST0044 C 2. FORMAT(I5) INST0045 C COLS INST0046 C 1-5 NUMBER OF HKL SYMMETRY TRANSFORMATIONS INST0047 C INST0048 C 3. FORMAT(9I3).THERE WILL BE MSYM CARDS OF THIS TYPE. INST0049 C A REFLECTION IH,IK,IL IS TRANSFORMED INTO A SYMMETRY INST0050 C EQUIVALENT REFLECTION BY THE MATRIX ISMHKL. INST0051 C ALWAYS INCLUDE THE IDENTITY OPERATION INST0052 C COLS INST0053 C 1-3 ISMHKL(1,1) INST0054 C 4-6 ISMHKL(1,2) INST0055 C 7-9 ISMHKL(1,3) INST0056 C 10-12 ISMHKL(2,1) INST0057 C 13-15 ISMHKL(2,2) INST0058 C 16-18 ISMHKL(2,3) INST0059 C 19-21 ISMHKL(3,1) INST0060 C 22-24 ISMHKL(3,2) INST0061 C 25-27 ISMHKL(3,3) INST0062 C INST0063 C 4. FORMAT(2F10.3) INST0064 C COLS INST0065 C 1-10 LINEAR ABSORPTION COEFFICENT IN CM**-1 INST0066 C 11-20 MU* RADIUS OF CRYSTAL (NO DIMENSIONS) INST0067 C INST0068 C 5. FORMAT(9X,F6.2,2F5.2,29X,F8.3) (A PHILIP CARD) INST0069 C COLS INST0070 C 10-15 SPE =THE SCAN SPEED IN DEGREES PER SEC INST0071 C 16-20 SWDA =FIXED PART OF SCAN WIDTH INST0072 C 21-25 SWDB =VARIABLE PART OF SCAN WIDTH INST0073 C 55-62 STABILITY CONSTANT (ZERO RESET TO 0.02) INST0074 C INST0075 C 6. FORMAT(6X,9F8.4) (A UBMAT CARD) ORIENTATION MATRIX INST0076 C COLS INST0077 C 7-14 UB(1,1) INST0078 C 15-22 UB(1,2) INST0079 C 23-30 UB(1,3) INST0080 C 31-38 UB(2,1) INST0081 C 39-46 UB(2,2) INST0082 C 47-54 UB(2,3) INST0083 C 55-62 UB(3,1) INST0084 C 63-70 UB(3,2) INST0085 C 71-78 UB(3,3) INST0086 C INST0087 C B. PROGRAMMES CAM2 TO CAM9 MAY BE TESTED BY COPYING THE INST0088 C DATA CARDS ONTO UNIT =NFILEA= NAMED RAWD, TOGETHER WITH INST0089 C THE FOLLOWING REFLECTION INTENSITY CARDS INST0090 C INST0091 C 7. FORMAT(1X,3I3,5F8.2,F8.4,F12.2,F10.2) INST0092 C COLS INST0093 C 2-4 H MILLER INDEX INST0094 C 5-7 K MILLER INDEX INST0095 C 8-10 L MILLER INDEX INST0096 C 11-18 TWO THETA IN DEGREES INST0097 C 19-26 OMEGA IN DEGREES INST0098 C 27-34 CHI IN DEGREES INST0099 C 35-42 PHI IN DEGREES INST0100 C 43-50 PSI(AZIMUTH) IN DEGREES INST0101 C 51-58 ABSORPTION AVERAGED PATH LENGTH(TBAR) IN CM. INST0102 C 59-70 INTENSITY INST0103 C 71-80 SIGMA OF INTENSITY INST0104 C INST0105 C END WITH A CARD WITH H= 999 INST0106 C ---------- - INST0107 C C. NORMAL DATA COLLECTION ON NFILEH NAMED NORM. INST0108 C SAME FORMAT AS B. 7. INST0109 C INST0110 C D. OUTPUT CORRECTED DATA ON NFILEI NAMED CORD INST0111 C SAME FORMAT AS B. 7. INST0112 C INST0113 C LOGICAL UNITS FOR CAMEL JOCKEY PROGRAMMES INST0114 C INST0115 C INST0116 C PROG UNIT NO NAME TP E USE INST0117 C INST0118 C ERWIN NFILEA 1 KLAUS A R COPY OF PAPER TAPE INST0119 C ERWIN NFILEB 2 YVON A W FORMATTED INTREPRETATION OF KLAUS INST0120 C INST0121 C CAM1 NFILEA 1 RAWD A W RAW COLLATED DATA INST0122 C CAM1 NFILEB 2 YVON A R FORMATTED INTERPRETATION OF KLAUS INST0123 C INST0124 C CAM2 NFILEA 1 RAWD A R RAW COLLATED DATA INST0125 C CAM2 NFILEB 2 PSIO B W PSI = 0 REFLECTIONS INST0126 C CAM2 NFILEC 3 SMPR B W SUMS OF PARENTS INST0127 C INST0128 C CAM3 NFILEB 2 PSIO B R PSI = 0 REFLECTIONS INST0129 C CAM3 NFILEC 3 SMPR B R SUMS OF PARENTS INST0130 C CAM3 NFILED 4 DESN B W DESIGN MATRIX INST0131 C INST0132 C CAM4 NFILED 4 DESN B R DESIGN MATRIX INST0133 C CAM4 NFILEE 5 MATR B W FULL NORMAL EQUATION MATRIX INST0134 C INST0135 C CAM5 NFILEE 5 MATR B R FULL NORMAL EQUATION MATRIX INST0136 C CAM5 NFILEF 6 MATI B W INVERSE MATRIX INST0137 C INST0138 C CAM6 NFILEF 6 MATI B R INVERSE MATRIX INST0139 C INST0140 C CAM7 NFILED 4 DESN B R DESIGN MATRIX INST0141 C CAM7 NFILEF 6 MATI B R INVERSE MATRIX INST0142 C CAM7 NFILEG 7 VCOM B W VARIANCE COVARIANCE MATRIX INST0143 C INST0144 C CAM8 NFILED 4 DESN B R DESIGN MATRIX INST0145 C CAM8 NFILEG 7 VCOM B R VARIANCE COVARIANCE MATRIX INST0146 C INST0147 C CAM9 NFILEG 7 VCOM B R VARIANCE COVARIANCE MATRIX INST0148 C CAM9 NFILEH 8 NORM A R STANDARD DATA COLLECTION INST0149 C CAM9 NFILEI 9 CORD A W CORRECTED NORMAL DATA INST0150 C INST0151 C GLOSSARY OF SYMBOLS INST0152 C --------- -- ------- INST0153 C INST0154 C ABCOR ABSORPTION CORRECTION INST0155 C AF CONSTANT FOR APPROXIMATE VALUE OF F 1,N-P,ALPHAINST0156 C AL NORMALIZED TRANSMISSION FACTOR INST0157 C ALGSP TRANSMISSION FOR A SPHERICAL CRYSTAL INST0158 C ALO OBSERVED VALUE OF AL INST0159 C AM(I) NORMAL EQUATIONS MATRIX COMPONENT (UPPER TRIANG)INST0160 C AMU MU - THE LINEAR ABSORPTION COEFFICENT INST0161 C ARG(1) THETA IN DEGREES INST0162 C ARG(2) FMUTR INST0163 C AVE(I) MEAN INTENSITY VALUE OF I TH PARENT INST0164 C AVSQ(I) MEAN VARIANCE OF ITH PARENT INST0165 C BF CONSTANT FOR APPROXIMATE VALUE OF F 1,N-P,ALPHA INST0166 C BG TOTAL BACKGROUND TIME INST0167 C BGT BACKGROUND COUNTING TIME (SECS) INST0168 C BGTR TOTAL BACKGROUND COUNTING TIME INST0169 C CB1 BACKGROUND INTENSITY RIGHT INST0170 C CB2 BACKGROUND INTENSITY LEFT INST0171 C CHI CHI IN RADIANS INST0172 C COUN(I) NUMBER OF MEASUREMENTS CONTRIBUTING TO SUM(I) INST0173 C CORBIG VALUE OF LARGE TERM OF CORRELATION MATRIX INST0174 C CRINT CORRECTED INTENSITY INST0175 C CSUM PEAK INTENSITY INST0176 C DAL SQWT*(AL - 1.0) INST0177 C DAR 57.29577951 (CONVERTS RADIANS TO DEGREES) INST0178 C DCHI CHI IN DEGREES INST0179 C DIAG DIAGONAL TERM OF MATRIX FOR TRIAL VARIABLE INSTA179 C DIAG(I) DIAGONAL TERMS OF AM INST0180 C DOMG OMEGA IN DEGREES INST0181 C DPHI PHI IN DEGREES INST0182 C DPSI ANGLE PSI IN DEGREES INST0183 C DTWTH TWO THETA IN DEGREES INST0184 C DV(I) TRIGONOMETRIC TERM IN CAMEL EXPANSION INST0185 C ENT(I) AXIAL VALUES OF TABLE INST0186 C FF CORRECTED INTENSITY INST0187 C FIT REDUCED INTENSITY INST0188 C FLINE(13) INPUT LINE FROM PAPER TAPE INST0189 C FMUTR MU* RADIUS OF CRYSTAL INST0190 C ICLB MODULUS FOR UNPACKING LABEL INST0191 C ICMO PRINT CONTROL FOR CORRELATION MATRIX INST0192 C IDG POINTER IN AM TO DIAG INSTA192 C IH H MILLER INDEX INST0193 C IHS(I) H MILLER INDEX OF I TH PARENT INST0194 C IK K MILLER INDEX INST0195 C IKS(I) K MILLER INDEX OF I TH PARENT INST0196 C IL L MILLER INDEX INST0197 C ILS(I) L MILLER INDEX OF I TH PARENT INST0198 C IMARK ABSORPTION CORRECTION MARKER INST0199 C IP PARAMETER COUNTER INST0200 C IPAR POINTER TO PARENT REFLECTION INST0201 C IPIN CONTROLS PRINTING INST0202 C IQUIT EXIT SIGNAL INST0203 C IWIND COUNTER OF CYCLES INSTA208 C IROW CORRELATION MATRIX CONTROL INST0204 C ISYM(216) MATRICES OF SYMMETRY ELEMENTS BY ROWS INST0205 C ITITLE(40) ALPHANUMERIC TITLE INST0206 C IV VARIABLE COUNTER INST0207 C IVAR VARIABLE COUNTER INST0208 C J0 0 INST0210 C J1 VALUE OF I IN CAMEL EXPANSION INST0211 C J1M MAXIMUM VALUE OF I IN CAMEL EXPANSION INST0212 C J2 VALUE OF J IN CAMEL EXPANSION INST0213 C J2M MAXIMUM VALUE OF J IN CAMEL EXPANSION INST0214 C J3 VALUE OF M IN CAMEL EXPANSION INST0215 C J3M MAXIMUM VALUE OF M IN CAMEL EXPANSION INST0216 C KEY(I) KEY FOR THE I TH PARAMETER INST0217 C KILL MARKER TO KILL A VARIABLE INSTA217 C LABEL(I) LABEL FOR THE I TH PARAMETER INST0218 C LAC LABEL OF A COLUMN INST0219 C LAR LABEL OF A ROW INST0220 C MPAR COUNTER OF PARENT REFLECTIONS INST0221 C MPSI NUMBER OF PSI = 0 REFLECTIONS INST0222 C MSYM NUMBER OF SYMMETRY ELEMENTS INST0223 C NAM DIMENSION OF AM INST0224 C NENT(2) LENGTH OF AXES OF TABLE INST0225 C NFILEA ... NFILEI LOGICAL UNIT NUMBERS OF INTERMEDIATE FILES INST0226 C NLIG NUMBER OF LINES PER PAGE INST0227 C NPAR DIMENSION OF NUMBER OF PARENT REFLECTIONS INST0228 C NPRM DIMENSION OF NUMBER OF PARAMETERS INST0229 C NSM SIZE OF NORMAL EQUATIONS MATRIX OF VARIABLES INST0230 C NTIN LOGICAL UNIT NUMBER OF CARD READER INST0231 C NTOUT LOGICAL UNIT NUMBER OF LINE PRINTER INST0232 C NVAR MAXIMUM NUMBER OF VARIABLES INSTA232 C N1 LINE COUNTER FOR OUTPUT INST0233 C RTST TEST VALUE FOR 1-R1**2 (MULTIPLE CORRELATION) INSTA238 C RVAL VALUE OF 1 - R1**2 INSTB238 C PD(I) VALUE OF I TH VARIABLE INST0234 C PHI PHI IN RADIANS INST0235 C PMTR PEAK MEASURING TIME INST0236 C QMX MAXIMUM VALUE OF I/J1M + J/J2M + M/J3M INSTA236 C RAD CONSTANT PI/180. INST0237 C ROW(I) TEMPORARY STORAGE OF A ROW OF AM,DV,V ETC INST0238 C SGABC SIGMA OF ABCOR INST0239 C SCALE SCALER FOR WEIGHTS INST0240 C SGAL E.S.D. OF AL INST0241 C SGALO OBSERVED VALUE OF SGAL INST0242 C SGCRI SIGMA OF CRINT INST0243 C SGFF SIGMA OF FF INST0244 C SGFIT E.S.D. OF FIT INST0245 C SGSUM(I) SIGMA SUM OF I TH PARENT INST0246 C SGTS TEST VALUE FOR SQUARE ROOT OF MEAN VARIANVE INSTA246 C SIG SUM OF SQUARES INST0247 C SOBS SUM OF DAL**2 INST0248 C SPE SCAN SPEED IN DEGREES PER SEC. INST0249 C SQWT SQUARE ROOT OF WEIGHT INST0250 C SSAR SUM OF SQUARES ABOUT REGRESSION INST0251 C STAB STABILITY CONSTANT INST0252 C SUM(I) INTENSITY SUM OF I TH PARENT INST0253 C SUMA(I) SUM OF UNCORRECTED PARENT INTENSITY INST0254 C SUMB(I) SUM OF CORRECTED PARENT INTENSITY INST0255 C SUMC(I) SUM OF UNCORRD INT**2 INST0256 C SUMD(I) SUM OF CORRD INT **2 INST0257 C SUMSQ SUM OF SQUARES DUE TO REGRESSION INST0258 C SUMSQP SUM OF SQUARES OF PREVIOUS CYCLE INST0259 C SWDA FIXED PART OF SCAN WIDTH INST0260 C SWDB VARIABLE PART OF SCAN WIDTH INST0261 C TABLE(I) ARRAY OF -LOG(A) V THETA AND FMUTR FOR SPHERES INST0262 C TBAR ABSORPTION AVERAGED PATH LENGTH INST0263 C TWMAX MAXIMUM VALUE OF DTWTH INST0264 C TWTH TWO THETA IN RADIANS INST0265 C UB(9) DIFFRACTOMETER ORIENTATION MATRIX INST0266 C V(I) NORMAL EQUATIONS VECTOR COMPONENT FOR I TH PARAMINST0267 C VAR VARIANCE INST0268 C VARAT VARIANCE RATIO INST0269 C VART APPROXIMATE VALUE OF F STATISTIC INST0270 C WD TOTAL SCAN WIDTH INST0271 C WTAL WEIGHTED VALUE OF AL INST0272 C Y SQUARE ROOT OF A DASH INSTA272 C ----------- INST0273 C INST0274 RETURN INST0275 END INST0276