public inbox for gcc-prs@sourceware.org help / color / mirror / Atom feed
From: ddb@R3401.rlem.titech.ac.jp To: gcc-gnats@gcc.gnu.org Subject: fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604 Date: Tue, 09 Oct 2001 20:46:00 -0000 [thread overview] Message-ID: <20011010034439.6572.qmail@sourceware.cygnus.com> (raw) >Number: 4514 >Category: fortran >Synopsis: Internal compiler error in `calculate_giv_inc', at unroll.c:1604 >Confidential: no >Severity: serious >Priority: medium >Responsible: unassigned >State: open >Class: sw-bug >Submitter-Id: net >Arrival-Date: Tue Oct 09 20:46:00 PDT 2001 >Closed-Date: >Last-Modified: >Originator: ddb@R3401.rlem.titech.ac.jp >Release: unknown-1.0 >Organization: >Environment: Debian i686 woody >Description: g77 -i686 -march=i686 -O3 -malign-loops=2 -malign-jumps=2 -malign-functions=2 -finit-local-zero -fomit-frame-pointer -fno-f2c -malign-double -funroll-loops -c cr.f cr.f: In subroutine `cr06': cr.f:3515: Internal compiler error: cr.f:3515: Internal compiler error in `calculate_giv_inc', at unroll.c:1604 Please submit a full bug report. See <URL: http://www.gnu.org/software/gcc/bugs.html > for instructions. incidentally cr.f:3515 is the return statement at end of subroutine. g77 version 2.95.4 20010902 (Debian prerelease) (from FSF-g77 version 0.5.25 20010319 (prerelease)) Driving: f77 -v -c -xf77-version /dev/null -xnone Reading specs from /usr/lib/gcc-lib/i386-linux/2.95.4/specs gcc version 2.95.4 20010902 (Debian prerelease) /usr/lib/gcc-lib/i386-linux/2.95.4/cpp0 -lang-c -v -D__GNUC__=2 -D__GNUC_MINOR__=95 -D__ELF__ -D__unix__ -D__i386__ -D__linux__ -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional -Acpu(i386) -Amachine(i386) -Di386 -D__i386 -D__i386__ /dev/null /dev/null GNU CPP version 2.95.4 20010902 (Debian prerelease) (i386 Linux/ELF) #include "..." search starts here: #include <...> search starts here: /usr/lib/gcc-lib/i386-linux/2.95.4/include /usr/include End of search list. The following default directories have been omitted from the search path: /usr/lib/gcc-lib/i386-linux/2.95.4/../../../../include/g++-3 /usr/local/include /usr/lib/gcc-lib/i386-linux/2.95.4/../../../../i386-linux/include End of omitted list. /usr/lib/gcc-lib/i386-linux/2.95.4/f771 -fnull-version -quiet -dumpbase g77-version.f -version -fversion -o /tmp/ccP2avtE.s /dev/null GNU F77 version 2.95.4 20010902 (Debian prerelease) (i386-linux) compiled by GNU C version 2.95.4 20010902 (Debian prerelease). GNU Fortran Front End version 0.5.25 20010319 (prerelease) as -V -Qy -o /tmp/ccs8GmR7.o /tmp/ccP2avtE.s GNU assembler version 2.11.90.0.31 (i386-linux) using BFD version 2.11.90.0.31 ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.2 -o /tmp/cc1XB8RC /tmp/ccs8GmR7.o /usr/lib/crt1.o /usr/lib/crti.o /usr/lib/gcc-lib/i386-linux/2.95.4/crtbegin.o -L/usr/lib/gcc-lib/i386-linux/2.95.4 -lg2c -lm -lgcc -lc -lgcc /usr/lib/gcc-lib/i386-linux/2.95.4/crtend.o /usr/lib/crtn.o /tmp/cc1XB8RC __G77_LIBF77_VERSION__: 0.5.25 20010319 (prerelease) @(#)LIBF77 VERSION 19990503 __G77_LIBI77_VERSION__: 0.5.25 20010319 (prerelease) @(#) LIBI77 VERSION pjw,dmg-mods 19990503 __G77_LIBU77_VERSION__: 0.5.25 20010319 (prerelease) @(#) LIBU77 VERSION 19980709 >How-To-Repeat: compile with options as in description >Fix: presume omit the -unroll_loops option ... >Release-Note: >Audit-Trail: >Unformatted: ----gnatsweb-attachment---- Content-Type: text/plain; name="cr.f" Content-Disposition: inline; filename="cr.f" C-------CR C-------XMACRO C-------CR00 SUBROUTINECR00 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL FILEXT(IOUNIT(4))='CMX' CALLCR01 CALLCR02 CALLCR03 CALLCR04 CALLCR05 CALLCR06 CALLCR08 CALLCR10 27000 CONTINUE CALLCR20 CALLCR21 CALLCR24 CALLCR26 IF(ICYCLE.EQ.NCYCLE)THEN GOTO27001 END IF CALLCR30 CALLCR36 CALLCR37 GOTO27000 27001 CONTINUE CALLCR40 RETURN END C-------CR01 SUBROUTINECR01 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALA(6) REALD(6) REALQ1 INTEGERI,J,K,L,L0,LTYP,MSYM,N INTEGERIP INTEGERKEY INTEGERPACK INTEGERNCR11 CHARACTER*35 CR11 INTEGERNCR12 CHARACTER*122 CR12 INTEGERNCR13 CHARACTER*31 CR13 INTEGERNCR14 CHARACTER*78 CR14 INTEGERNCR15 CHARACTER*78 CR15 INTEGERNCR16 CHARACTER*78 CR16 INTEGERNCR17 CHARACTER*78 CR17 INTEGERNCR18 CHARACTER*78 CR18 INTEGERNCR19 CHARACTER*78 CR19 INTEGERNCR110 CHARACTER*78 CR110 INTEGERNCR111 CHARACTER*78 CR111 INTEGERNCR112 CHARACTER*51 CR112 REAL FMT(6 ) REAL TR11(6 ) REAL TR12(6 ) REAL TR13(6 ) REAL TR21(2 ) REAL TR22(2 ) REAL TR23(2 ) DATANCR11/35 /, CR11/' DS CY SK TL MR FU LR WW M1 M2 ND '/ DATANCR12/122/, CR12/' M3 M4 ML XR NU FR F2 IN FH BD FM BL US SS &AD RD AX RX OV IS AN MX PP WU WS WW AP EP TR TW TT TC L1 L2 P1 P2 &MS AO AA RA '/ DATANCR13/31 /, CR13/' CRYLSQ CONTROL PARAMETERS/-YES'/ DATANCR14/78 /, CR14/' REFINE SCALE FACT &OR US DATA SET 1'/ DATANCR15/78 /, CR15/' NUMBER OF CYCLES 1 APPLY/REF DISPERS &ION NO REFL.SKIP FACT. 1'/ DATANCR16/78 /, CR16/' REFINEMENT TYPE FR APPLY/REF EXTINCT &ION NO TYPE LESS-THANS, Q= NO'/ DATANCR17/78 /, CR17/' BLOCKING TYPE BD APPLY/REF ABS.STR &.PAR NO PARTIAL CONTRIBUTION NO'/ DATANCR18/78 /, CR18/' DISP.PARM.TYPE MX LIST REFLECTIONS & NO MATRIX CONTR, W*D< NO'/ DATANCR19/78 /, CR19/' REFINE POP.PAR. NO LIST POOR REFL, W &*D> NO MATRIX CONTR(LT) NO'/ DATANCR110/78 /, CR110/' WEIGHTING SCHEME WU PUNCH PARAM CAR &DS NO DISP.PARM. NON-POS TR'/ DATANCR111/78 /, CR111/' DAMPING FACTOR 1.00 LIST MATRIX, Q= & NO TERMINATE REFINEM. NO'/ DATANCR112/51 /, CR112/' OUTPUT OLD PARAMS NO SAVE CORR.MATRI &X NO'/ DATAFMT/230213.,510213.,780213.,230442.,510442.,780442./ DATATR11/.5,.6666667,0.,0.,.5,.5/ DATATR12/.5,.3333333,.5,.5,0.,.5/ DATATR13/.5,.3333333,.5,.5,.5,0./ DATATR21/.3333333,.5/ DATATR22/.6666667,0./ DATATR23/.6666667,.5/ IOMARK(1)=QXSTR IF(IOMARK(1)+2048.GT.QXCUR)THEN IQXY=MAX(IOMARK(1)+2048,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0120',0) END IF DO27000IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27000 CONTINUE QXCUR=IQXY END IF MARK0=IOMARK(1)+2048 CALLAA12(1,2,PACK,IP,0) BTOHU=1.266514795 BTOU=0.012665148 DATSET=1 RADTYP=1 NCYCLE=1 NSKIP=1 RFLTYP=0 BLKTYP=0 REFUOV=-1 REFTMP=3 REFDSP=0 REFSKF=1 REFEXT=0 REFABS=0 REFPOP=0 EXTTYP=0 EXTESD=0. LISTMA=0 LIST=0 PNCHCD=0 SAVEMA=0 RFLIST=1000000. MALIST=.0 TYPELT=.0 RFMTRX=1000000. PARTL=0 TMPTST=0 TERMNT=0 LTMTRX=0 DAMP=-1. IWT=2 XABS=0. XABSIG=-4.E+20 ADDOLD=0 DO27002I=1,3 POLSPG(I)=0 27002 CONTINUE ICYCLE=1 I=1 27004 IF(I.LE.40)THEN IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27006 END IF IF(I.GT.0)THEN K=(BUFIN(I)*(-1.0E-22)+0.001) L=NINT(BUFIN(I)*(-1.0E-20))-K*100 END IF CALLAA09(CHRIN,K,CR11,3,2,3,NCR11,KEY) IF(KEY.GT.0)THEN IF(KEY.GT.10)THEN GOTO27005 END IF IF(KEY.EQ.8)THEN IWT=3 END IF IF(KEY.GT.8)THEN LISTMA=KEY-8 END IF IF(BUFIN(I+1).GT.-4.E+20)THEN I=I+1 IF(KEY.EQ.1)THEN DATSET=NINT(BUFIN(I)) ELSE IF(KEY.EQ.2)THEN NCYCLE=NINT(BUFIN(I)) ELSE IF(KEY.EQ.3)THEN NSKIP=NINT(BUFIN(I)) ELSE IF(KEY.EQ.4)THEN TYPELT=BUFIN(I) ELSE IF(KEY.EQ.5)THEN RFMTRX=BUFIN(I) ELSE IF(KEY.EQ.6)THEN DAMP=BUFIN(I) ELSE IF(KEY.EQ.7)THEN RFLIST=BUFIN(I) ELSE IF(KEY.EQ.8)THEN IWT=INT(BUFIN(I))+3 ELSE IF(KEY.LE.10)THEN MALIST=BUFIN(I) END IF ELSE IF(KEY.LE.7)THEN CALLAA06('-CR0101',0) END IF ELSE CALLAA09(CHRIN,K,CR12,3,2,3,NCR12,KEY) IF(KEY.LE.0)THEN CALLAA06('-CR0101',0) ELSE IF(KEY.LE.2)THEN LISTMA=KEY+2 ELSE IF(KEY.EQ.3)THEN LTMTRX=1 ELSE IF(KEY.EQ.4)THEN ELSE IF(KEY.LE.9)THEN RFLTYP=KEY-6 ELSE IF(KEY.LE.12)THEN BLKTYP=KEY-10 ELSE IF(KEY.LE.14)THEN REFSKF=KEY-12 ELSE IF(KEY.LE.16)THEN REFDSP=KEY-14 ELSE IF(KEY.LE.18)THEN REFEXT=KEY-16 ELSE IF(KEY.LE.22)THEN REFTMP=KEY-19 ELSE IF(KEY.EQ.23)THEN REFPOP=1 ELSE IF(KEY.LE.26)THEN IWT=KEY-23 ELSE IF(KEY.LE.28)THEN PARTL=KEY-26 ELSE IF(KEY.LE.31)THEN TMPTST=KEY-29 ELSE IF(KEY.EQ.32)THEN TERMNT=1 ELSE IF(KEY.LE.34)THEN LIST=KEY-32 ELSE IF(KEY.LE.36)THEN PNCHCD=KEY-34 ELSE IF(KEY.EQ.37)THEN SAVEMA=1 ELSE IF(KEY.LE.38)THEN ADDOLD=1 ELSE IF(KEY.LE.40)THEN REFABS=KEY-38 END IF END IF 27005 CONTINUE I=I+1 GOTO27004 27006 CONTINUE END IF IF(DAMP.LT..0)THEN IF(BLKTYP.EQ.1)THEN DAMP=1. ELSE DAMP=.8 END IF END IF LINRM=10 CALLAA04(2,CR13,26,3,1) CALLAA55(CR13,28,CHROT,2,26,1) CALLAA04(0,' ',0,1,1) IF(REFSKF.EQ.2)THEN CALLAA55(CR12,42,CR14,50,2,0) END IF IF(DATSET.NE.1)THEN CALLAA03(FLOAT(DATSET),1,CR14,FMT(3),1) END IF CALLAA04(0,CR14,NCR14,3,1) IF(NCYCLE.LE.0)THEN CALLAA06('CR0104',0) END IF IF(NCYCLE.GT.1)THEN CALLAA03(FLOAT(NCYCLE),1,CR15,FMT(1),1) END IF IF(REFDSP.GT.0)THEN CALLAA55(CR12,(REFDSP+14)*3,CR15,50,2,0) END IF IF(NSKIP.GT.1)THEN CALLAA03(FLOAT(NSKIP),1,CR15,FMT(3),1) END IF CALLAA04(0,CR15,NCR15,3,1) NCYCLE=NCYCLE+1 IF(RFLTYP.GT.0)THEN CALLAA55(CR12,(RFLTYP+6)*3,CR16,22,2,0) END IF IF(REFEXT.GT.0)THEN CALLAA55(CR12,(REFEXT+16)*3,CR16,50,2,0) END IF IF(TYPELT.GT..0)THEN CALLAA03(TYPELT,1,CR16,780412.,1) END IF CALLAA04(0,CR16,NCR16,3,1) IF(BLKTYP.GT.0)THEN CALLAA55(CR12,(BLKTYP+10)*3,CR17,22,2,0) END IF IF(REFABS.GT.0)THEN CALLAA55(CR12,(REFABS+38)*3,CR17,50,2,0) END IF IF(PARTL.GT.0)THEN CALLAA55(CR12,(PARTL+26)*3,CR17,77,2,0) END IF CALLAA04(0,CR17,NCR17,3,1) IF(REFTMP.LT.3)THEN CALLAA55(CR12,(REFTMP+19)*3,CR18,22,2,0) END IF IF(LIST.GT.0)THEN CALLAA55(CR12,(LIST+32)*3,CR18,50,2,0) END IF IF(RFMTRX.LT.10000.)THEN CALLAA03(RFMTRX,1,CR18,780412.,1) END IF CALLAA04(0,CR18,NCR18,3,1) IF(REFPOP.GT.0)THEN CALLAA55(CR12,69,CR19,22,2,0) END IF IF(RFLIST.LT.10000.)THEN CALLAA03(RFLIST,1,CR19,510412.,1) END IF IF(LTMTRX.GT.0)THEN CALLAA55(CR13,29,CR19,76,3,0) END IF CALLAA04(0,CR19,NCR19,3,1) IF(IWT.GT.0)THEN CALLAA55(CR12,(IWT+23)*3,CR110,22,2,0) END IF IF(IWT.GE.3)THEN CALLAA03(FLOAT(IWT-3),1,CR110,190213.,1) END IF IF(PNCHCD.GT.0)THEN CALLAA55(CR12,(PNCHCD+34)*3,CR110,50,2,0) END IF IF(TMPTST.GT.0)THEN CALLAA55(CR12,(TMPTST+29)*3,CR110,77,2,0) END IF CALLAA04(0,CR110,NCR110,3,1) IF(ABS((DAMP)-(1.)).GT.5.0E-7)THEN CALLAA03(DAMP,1,CR111,FMT(4),1) END IF IF(LISTMA.GT.2)THEN CALLAA55(CR12,((LISTMA-2)*3),CR111,50,2,0) ELSE IF(LISTMA.GT.0)THEN CALLAA55(CR11,(LISTMA+8)*3,CR111,50,2,0) MALIST=ABS(MALIST) IF(MALIST.GT..0)THEN CALLAA03(MALIST,1,CR111,460422.,1) END IF END IF IF(TERMNT.GT.0)THEN CALLAA55(CR13,29,CR111,76,3,0) END IF CALLAA04(0,CR111,NCR111,3,1) IF(TERMNT.GT.0)THEN TERMNT=10000000 END IF IF(ADDOLD.GT.0)THEN CALLAA55(CR13,29,CR112,21,3,0) END IF IF(SAVEMA.GT.0)THEN CALLAA55(CR13,29,CR112,49,3,0) END IF CALLAA04(0,CR112,NCR112,3,1) DO27007I=1,7 CALLAA12(1,4,PACK,IP,0) IF(IP.LE.0)THEN CALLAA06('-CR0102',0) END IF IF(I.EQ.1)THEN CALLAA51(QX,IP+1,D,1,6,0) END IF IF(I.EQ.3)THEN CALLAA51(QX,IP+1,A,1,6,0) END IF IF(I.EQ.4)THEN CALLAA51(QX,IP+1,CELL,13,9,0) END IF IF(I.EQ.5)THEN Q1=QX(IP+2) QX(IP+2)=QX(IP+4) QX(IP+4)=Q1 Q1=QX(IP+3) QX(IP+3)=QX(IP+7) QX(IP+7)=Q1 Q1=QX(IP+6) QX(IP+6)=QX(IP+8) QX(IP+8)=Q1 CALLAA51(QX,IP+1,CELL,22,9,0) END IF IF(I.EQ.6)THEN VOL=QX(IP+1) END IF IF(I.EQ.7)THEN CALLAA51(QX,IP+1,CELL,31,9,0) END IF 27007 CONTINUE DO27009I=1,3 CELL(I)=.25*A(I)*A(I) CELL(I+6)=BTOHU/CELL(I) 27009 CONTINUE CELL(4)=.25*A(1)*A(2)*A(6) CELL(5)=.25*A(1)*A(3)*A(5) CELL(6)=.25*A(2)*A(3)*A(4) CELL(10)=4.0*BTOHU/(A(1)*A(2)) CELL(11)=4.0*BTOHU/(A(1)*A(3)) CELL(12)=4.0*BTOHU/(A(2)*A(3)) UEQU(1)=(D(1)*A(1))**2/3. UEQU(2)=(D(2)*A(2))**2/3. UEQU(3)=(D(3)*A(3))**2/3. UEQU(4)=2.*D(1)*A(1)*D(2)*A(2)*D(6)/3. UEQU(5)=2.*D(1)*A(1)*D(3)*A(3)*D(5)/3. UEQU(6)=2.*D(2)*A(2)*D(3)*A(3)*D(4)/3. CALLAA12(1,5,PACK,IP,0) IF(IP.LE.0)THEN CALLAA06('-CR0103',0) END IF LTYP=NINT(QX(IP+1)) ICENT=NINT(QX(IP+2)) MSYM=NINT(QX(IP+3)) NSYM=NINT(QX(IP+4)) RFLMLT=NINT(QX(IP+6)) IF(MARK0+12*MSYM.GT.QXCUR)THEN IQXY=MAX(MARK0+12*MSYM,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0120',0) END IF DO27011IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27011 CONTINUE QXCUR=IQXY END IF MARK1=MARK0+12*MSYM L0=MARK0 DO27013I=1,NSYM CALLAA12(1,5,PACK,IP,0) IF(IP.LE.0)THEN CALLAA06('-CR0103',0) END IF CALLAA51(QX,IP+1,QX,L0+1,12,0) L0=L0+12 27013 CONTINUE STOP0=L0 N=L0 IF(ICENT.EQ.0)THEN K=MARK0 27015 IF(K.LT.STOP0)THEN DO27018I=1,12 QX(N+I)=-QX(K+I) 27018 CONTINUE N=N+12 K=K+12 GOTO27015 END IF END IF IF(LTYP.GT.7)THEN LTYP=LTYP-7 END IF K=N IF(LTYP.GT.1)THEN J=MARK0 27020 IF(J.LT.N)THEN CALLAA51(QX,J+1,QX,K+1,9,0) QX(K+10)=QX(J+10)+TR11(LTYP-1) QX(K+11)=QX(J+11)+TR12(LTYP-1) QX(K+12)=QX(J+12)+TR13(LTYP-1) K=K+12 IF((LTYP.EQ.2).OR.(LTYP.GT.4))THEN GOTO27021 END IF CALLAA51(QX,J+1,QX,K+1,9,0) QX(K+10)=QX(J+10)+TR21(LTYP-2) QX(K+11)=QX(J+11)+TR22(LTYP-2) QX(K+12)=QX(J+12)+TR23(LTYP-2) K=K+12 IF(LTYP.NE.4)THEN GOTO27021 END IF CALLAA51(QX,J+1,QX,K+1,9,0) QX(K+10)=QX(J+10)+0.5 QX(K+11)=QX(J+11)+0.5 QX(K+12)=QX(J+12)+0.0 K=K+12 27021 CONTINUE J=J+12 GOTO27020 END IF END IF J=MARK0 27023 IF(J.LT.MARK1)THEN DO27026I=10,12 QX(J+I)=MOD(5.+QX(J+I),1.) 27026 CONTINUE J=J+12 GOTO27023 END IF RETURN END C-------CR02 SUBROUTINECR02 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(140 )CH INTEGERI,J,K,L,M,N INTEGERIREL(71) INTEGERIP INTEGERIWANT(70) INTEGERKEY INTEGERL2,L3,L4 INTEGERPACK INTEGERNCR21 CHARACTER*98 CR21 INTEGERNCR22 CHARACTER*31 CR22 INTEGERNCR23 CHARACTER*30 CR23 INTEGERNCR24 CHARACTER*41 CR24 REAL FMT(5 ) DATANCR21/98 /, CR21/' DISPER SCALE EXTINC MAXHKL XABS SELECT D &PTYPE GROUP ATOMGR RESTR CONSTR NOREF BLOCK END '/ DATANCR22/31 /, CR22/' MAX /H/ /K/ /L/ '/ DATANCR23/30 /, CR23/' MIN/MAX SIN(T/L) '/ DATANCR24/41 /, CR24/' ZACH TYP1 TYP2 GEN ISO ANIS GAUS LORE '/ DATAFMT/210313.,250313.,290313.,230642.,290642./ CALLAA01(CR21,NCR21) IWANT(1)=11 IWANT(2)=20+DATSET IWANT(3)=60+DATSET IWANT(4)=2 IWANT(5)=7 IWANT(6)=100 IWANT(7)=10 SIGNAL(1)=1 SIGNAL(2)=7 SIGNAL(3)=7 SIGNAL(4)=0 CALLAA15(1,8,PACK,IP,0,SIGNAL,IWANT,IREL) IF(IP.LE.0)THEN CALLAA06('CR0201',0) END IF IF(IREL(7).GT.0)THEN RADTYP=2 END IF IF(RADTYP.EQ.1)THEN NSFTB=0 M=IP+IREL(6) IF(M.GT.IP)THEN DSFTB=(QX(M+1)-QX(M))*.01 27000 CONTINUE IF((QX(M).LT.99.5).OR.(QX(M).GT.299.5))THEN GOTO27001 END IF M=M+1 NSFTB=NSFTB+1 GOTO27000 27001 CONTINUE END IF ELSE NSFTB=1 END IF L=1 MARK2=MARK1+35 NSTEP2=4+NSFTB L2=MARK2 NATTYP=0 27002 CONTINUE CALLAA12(1,8,PACK,IP,0) IF(IP.EQ.0)THEN GOTO27003 END IF NATTYP=NATTYP+1 M=IP+IREL(1) CALLAA57(QX(M),1,CH,L,8,0) L=L+8 IF(L2+NSTEP2.GT.QXCUR)THEN IQXY=MAX(L2+NSTEP2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0220',0) END IF DO27004IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27004 CONTINUE QXCUR=IQXY END IF MARK3=L2+NSTEP2 QX(L2+1)=0. QX(L2+2)=0. QX(L2+3)=0. M=IREL(2)+IP IF(M.GT.IP)THEN QX(L2+1)=QX(M) END IF M=IREL(3)+IP IF(M.GT.IP)THEN QX(L2+2)=QX(M) END IF IF(REFDSP.GT.1)THEN QX(L2+3)=FLOAT(NATTYP) END IF M=IREL(4)+IP IF(M.GT.IP)THEN QX(L2+4)=QX(M) ELSE QX(L2+4)=1. END IF L2=L2+4 IF(RADTYP.EQ.1)THEN IF(NSTEP2.EQ.4)THEN GOTO27002 END IF M=IP+IREL(6) IF(M.LE.IP)THEN CALLAA06('CR0202',0) END IF CALLAA51(QX,M,QX,L2+1,NSFTB,0) ELSE QX(L2+1)=QX(IP+IREL(7)) END IF L2=L2+NSFTB GOTO27002 27003 CONTINUE 27006 CONTINUE IF(LINID.NE.1)THEN GOTO27007 END IF DO27008I=1,40,3 IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27009 END IF IF(I.GT.0)THEN N=(BUFIN(I)*(-1.0E-22)+0.001) J=NINT(BUFIN(I)*(-1.0E-20))-N*100 END IF CALLAA05(CHRIN(N:J-1),K,L,CH,KEY) IF(KEY.EQ.0)THEN CALLAA06('-CR0203',0) END IF L2=MARK2+(KEY-1)*NSTEP2 IF(BUFIN(I+1).GT.-4.E+20)THEN QX(L2+1)=BUFIN(I+1) END IF IF(BUFIN(I+2).GT.-4.E+20)THEN QX(L2+2)=BUFIN(I+2) END IF 27008 CONTINUE 27009 CONTINUE CALLAA01(CR21,NCR21) GOTO27006 27007 CONTINUE DO27010I=1,DATSET CALLAA12(1,10,PACK,IP,0) 27010 CONTINUE IF(IP.GT.0)THEN CALLAA57(QX(IP+1),1,CH,129,12,0) ELSE CALLAA55(BLANK,1,CH,129,12,1) END IF CALLAA56(CH,1,QX(MARK1+1),1,140,0) IWANT(1)=1 IWANT(2)=2 IWANT(3)=10 I=1 27012 IF(I.LE.64)THEN IWANT(I+3)=100+I I=I+1 GOTO27012 END IF IWANT(68)=50 IWANT(69)=52 SIGNAL(1)=0 SIGNAL(2)=69 SIGNAL(3)=0 SIGNAL(4)=0 CALLAA15(1,11,PACK,IP,0,SIGNAL,IWANT,IREL) IF(IP.LE.0)THEN CALLAA06('CR0204',0) END IF IF(MARK3+2.GT.QXCUR)THEN IQXY=MAX(MARK3+2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0220',0) END IF DO27015IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27015 CONTINUE QXCUR=IQXY END IF MARK4=MARK3+2 QX(MARK3+1)=1. QX(MARK3+2)=1. 27017 CONTINUE CALLAA12(1,11,PACK,IP,0) IF(IP.LE.0)THEN CALLAA06('CR0204',0) END IF IF(IREL(1).GT.0)THEN M=IP+IREL(1) IF(DATSET.NE.NINT(QX(M)))THEN GOTO27017 END IF END IF M=IP+IREL(2) LAMBDA=QX(M) M=IP+IREL(3) MU=0. IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN MU=QX(M) END IF END IF M=IP+IREL(68) IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN MONO2T=QX(M)*.01745329 ELSE MONO2T=LAMBDA/6.708 MONO2T=2.*ASIN(MONO2T) END IF END IF MONO2T=(COS(MONO2T))**2 M=IP+IREL(69) IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN RATIO=QX(M) ELSE RATIO=MONO2T/(MONO2T+1.) END IF END IF L3=MARK3 DO27019I=1,64 M=IP+IREL(I+3) IF(M.LE.IP)THEN GOTO27019 END IF IF(ABS(QX(M)-(-4.E+20)).LT.1.E13)THEN GOTO27019 END IF IF(L3+2.GT.QXCUR)THEN IQXY=MAX(L3+2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0220',0) END IF DO27021IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27021 CONTINUE QXCUR=IQXY END IF MARK4=L3+2 QX(L3+1)=QX(M) QX(L3+2)=FLOAT(I) L3=L3+2 27019 CONTINUE GOTO27018 27018 CONTINUE 27023 CONTINUE IF(LINID.NE.2)THEN GOTO27024 END IF DO27025I=1,40,2 IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27026 END IF IF(ABS(BUFIN(I+1)-(-4.E+20)).LT.1.E13)THEN BUFIN(I+1)=1. END IF IF((BUFIN(I+1).LT.0.5).OR.(BUFIN(I+1).GT.64.5))THEN GOTO27025 END IF L3=MARK3 27027 IF(L3.LT.MARK4)THEN IF(ABS((QX(L3+2))-(BUFIN(I+1))).GT.5.0E-7)THEN GOTO27028 END IF QX(L3+1)=BUFIN(I) GOTO27029 27028 CONTINUE L3=L3+2 GOTO27027 27029 CONTINUE END IF 27025 CONTINUE 27026 CONTINUE CALLAA01(CR21,NCR21) GOTO27023 27024 CONTINUE IWANT(1)=1 IWANT(2)=2 DO27030I=3,7 IWANT(I)=I+8 27030 CONTINUE DO27032I=1,17 IWANT(I+7)=100+I 27032 CONTINUE IWANT(25)=3 SIGNAL(1)=0 SIGNAL(2)=25 SIGNAL(3)=0 SIGNAL(4)=0 CALLAA15(1,12,PACK,IP,0,SIGNAL,IWANT,IREL) IF(IP.LE.0)THEN CALLAA06('CR0205',0) END IF IF(MARK4+22.GT.QXCUR)THEN IQXY=MAX(MARK4+22,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0220',0) END IF DO27034IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27034 CONTINUE QXCUR=IQXY END IF MARK5=MARK4+22 QX(MARK4+1)=.035/BTOU QX(MARK4+16)=999. QX(MARK4+17)=999. QX(MARK4+18)=999. QX(MARK4+19)=.0001 QX(MARK4+20)=10. QX(MARK4+21)=-1. 27036 CONTINUE CALLAA12(1,12,PACK,IP,0) IF(IP.LE.0)THEN GOTO27037 END IF M=IP+IREL(1) IF(DATSET.NE.NINT(QX(M)))THEN GOTO27036 END IF M=IP+IREL(2) IF(M.GT.IP)THEN QX(MARK4+1)=QX(M)/BTOU END IF DO27038I=3,7 M=IP+IREL(I) IF(M.LE.IP)THEN GOTO27038 END IF QX(MARK4+13+I)=QX(M) 27038 CONTINUE IF(REFEXT.GT.0)THEN M=IP+IREL(8) IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN EXTTYP=NINT(QX(M)) END IF END IF M=IP+IREL(9) IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN DSTEXT=NINT(QX(M)) END IF END IF IF(RADTYP.EQ.1)THEN QX(MARK4+22)=0.3 ELSE QX(MARK4+22)=1.5 END IF M=IP+IREL(24) IF(M.GT.IP)THEN IF(QX(M).GT..0)THEN QX(MARK4+22)=QX(M) END IF END IF DO27040I=10,23 M=IP+IREL(I) IF(M.GT.IP)THEN IF(QX(M)-(-4.E+20).GT.5.0E-7)THEN QX(MARK4-8+I)=QX(M)/10000. END IF END IF 27040 CONTINUE END IF IF(REFABS.GT.0)THEN M=IP+IREL(25) IF(M.GT.IP)THEN XABS=QX(M) END IF END IF GOTO27037 27037 CONTINUE IF(LINID.EQ.3)THEN IF(ABS(BUFIN(1)-(-4.E+20)).GT.1.E13)THEN IF(1.GT.0)THEN K=(BUFIN(1)*(-1.0E-22)+0.001) L=NINT(BUFIN(1)*(-1.0E-20))-K*100 END IF L=MIN0(4,L-K) CALLAA09(CHRIN,K,CR24,2,L,5,20,I) IF(I.EQ.0)THEN CALLAA06('CR0208',0) END IF EXTTYP=I-1 END IF IF(ABS(BUFIN(2)-(-4.E+20)).GT.1.E13)THEN IF(2.GT.0)THEN K=(BUFIN(2)*(-1.0E-22)+0.001) L=NINT(BUFIN(2)*(-1.0E-20))-K*100 END IF L=MIN0(4,L-K) CALLAA09(CHRIN,K,CR24,22,L,5,10,I) IF(I.EQ.0)THEN CALLAA06('CR0208',0) END IF IF(I.EQ.2)THEN EXTTYP=EXTTYP+3 END IF END IF IF(ABS(BUFIN(3)-(-4.E+20)).GT.1.E13)THEN IF(3.GT.0)THEN K=(BUFIN(3)*(-1.0E-22)+0.001) L=NINT(BUFIN(3)*(-1.0E-20))-K*100 END IF L=MIN0(4,L-K) CALLAA09(CHRIN,K,CR24,32,L,5,10,I) IF(I.EQ.0)THEN CALLAA06('CR0208',0) END IF DSTEXT=I-1 END IF L4=MARK4+1 IF(ABS(BUFIN(4)-(-4.E+20)).GT.1.E13)THEN QX(L4+1)=BUFIN(4)/10000. END IF IF(ABS(BUFIN(5)-(-4.E+20)).GT.1.E13)THEN QX(L4+2)=BUFIN(5)/10000. END IF IF(ABS(BUFIN(6)-(-4.E+20)).GT.1.E13)THEN QX(L4+21)=BUFIN(6) END IF CALLAA01(CR21,NCR21) END IF IF(LINID.EQ.4)THEN QX(MARK4+21)=1. L4=MARK4+15 DO27042I=1,5 L4=L4+1 IF(BUFIN(I).GE.0.0)THEN QX(L4)=BUFIN(I) END IF 27042 CONTINUE CALLAA03(QX,MARK4+16,CR22,FMT(1),3) CALLAA04(0,CR22,NCR22,3,1) CALLAA03(QX,MARK4+19,CR23,FMT(4),2) CALLAA04(0,CR23,NCR23,3,1) CALLAA01(CR21,NCR21) END IF IF(EXTTYP.GT.3)THEN CALLAA06('CR0208',0) END IF IF(LINID.EQ.5)THEN XABS=BUFIN(1) CALLAA01(CR21,NCR21) END IF RETURN END C-------CR03 SUBROUTINECR03 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERATTYP CHARACTER*(500 )CH INTEGERDPTYP(10) INTEGERFLGOVA INTEGERFLGISO INTEGERFLGANI INTEGERI,J,J1,K,M,N,N5 INTEGERIP INTEGERIREL(38) INTEGERIWANT(37) INTEGERJUNK INTEGERKEY INTEGERL5 CHARACTER*(128 )NAME CHARACTER*(24 )NAME1 INTEGERNCH INTEGERNSLAVE INTEGERN1,NL INTEGERPACK REALQ INTEGERTMP INTEGERNCR31 CHARACTER*70 CR31 INTEGERNCR32 CHARACTER*13 CR32 INTEGERNCR33 CHARACTER*42 CR33 INTEGER ATTMP DATANCR31/70 /, CR31/' SELECT DPTYPE GROUP ATOMGR RESTR CONSTR N &OREF BLOCK RESTR END '/ DATANCR32/13 /, CR32/' / OV IS AN '/ DATANCR33/42 /, CR33/' SLAVE ATOMS EXCLUDED FROM CALC. '/ DATAATTMP/0/ LINID=LINID-5 SELECT=0 NCH=1 CH=' ' 27000 CONTINUE IF(LINID.NE.1)THEN GOTO27001 END IF SELECT=1 DO27002I=1,40 IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27003 END IF IF(NCH.GT.500)THEN CALLAA06('CR0301',0) END IF IF(I.GT.0)THEN N=(BUFIN(I)*(-1.0E-22)+0.001) J=NINT(BUFIN(I)*(-1.0E-20))-N*100 END IF CALLAA09(CR32,2,CHRIN,N,1,1,J-N,J1) IF(J1.GT.0)THEN CH(NCH:)=CHRIP(N:N+J1-2) CH(NCH+24:)='/' NCH=NCH+25 N=N+J1 END IF CH(NCH:)=CHRIP(N:J-1) NCH=NCH+25 27002 CONTINUE 27003 CONTINUE CALLAA01(CR31,NCR31) GOTO27000 27001 CONTINUE NCH=NCH-1 DO27004I=1,NATTYP DPTYP(I)=-1 27004 CONTINUE CALLAA57(QX(MARK1+1),1,NAME,1,8*NATTYP,0) 27006 CONTINUE IF(LINID.NE.2)THEN GOTO27007 END IF REFTMP=4 DO27008I=1,40,2 IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27009 END IF IF(I.GT.0)THEN N=(BUFIN(I)*(-1.0E-22)+0.001) J=NINT(BUFIN(I)*(-1.0E-20))-N*100 END IF CALLAA05(CHRIN(N:),J,K,NAME,KEY) IF(KEY.EQ.0)THEN CALLAA06('-CR0304',0) END IF IF(I+1.GT.0)THEN N=(BUFIN(I+1)*(-1.0E-22)+0.001) J=NINT(BUFIN(I+1)*(-1.0E-20))-N*100 END IF CALLAA09(CHRIN,N,CR32,5,2,3,9,J) IF(J.EQ.0)THEN CALLAA06('-CR0304',0) END IF DPTYP(KEY)=J-1 27008 CONTINUE 27009 CONTINUE CALLAA01(CR31,NCR31) GOTO27006 27007 CONTINUE IWANT(1)=14 IWANT(2)=22 DO27010I=1,13 IWANT(I+2)=I 27010 CONTINUE DO27012I=1,13 IWANT(I+15)=I+100 27012 CONTINUE IWANT(29)=21 IWANT(30)=23 IWANT(31)=24 IWANT(32)=25 IWANT(33)=17 IWANT(34)=215 SIGNAL(1)=5 SIGNAL(2)=34 SIGNAL(3)=0 SIGNAL(4)=0 CALLAA15(1,16,PACK,IP,0,SIGNAL,IWANT,IREL) IF(IP.LE.0)THEN CALLAA06('CR0302',0) END IF IF(SIGNAL(4).LT.0)THEN CALLAA06('CR0302',0) END IF IF(IREL(30).EQ.0)THEN IF(IREL(7).GT.0)THEN ATTMP=2 ELSE IF(IREL(6).GT.0)THEN ATTMP=1 END IF IF(REFTMP.EQ.3)THEN REFTMP=ATTMP END IF END IF IF(REFTMP.EQ.2)THEN TMP=6 ELSE TMP=REFTMP END IF IF((REFPOP.EQ.0).AND.(IREL(13).EQ.0))THEN POP=0 ELSE POP=1 END IF IF(IREL(29).EQ.0)THEN MLT=0 ELSE MLT=1 END IF L5=MARK5+1 NAT=0 FLGOVA=0 FLGISO=0 FLGANI=0 N1=1 NL=NCH NSLAVE=0 27014 CONTINUE CALLAA12(1,16,PACK,IP,0) IF(IP.EQ.0)THEN GOTO27015 END IF M=IP+IREL(33) IF(M.GT.IP)THEN IF(DATSET.NE.NINT(QX(M)))THEN GOTO27014 END IF END IF M=IP+IREL(2) ATTYP=NINT(QX(M)) M=IP+IREL(34) IF(M.GT.IP)THEN IF(ABS((QX(M))-(-9.)).LE.5.0E-7)THEN NSLAVE=NSLAVE+1 GOTO27014 END IF END IF IF(SELECT.EQ.1)THEN KEY=0 M=IP+IREL(1) CALLAA57(QX(M),1,NAME,1,24,0) CALLAA09(NAME,1,CH,N1,24,25,NL,KEY) IF((N1.EQ.1).AND.(KEY.GT.0))THEN K=25*KEY IF(CH(K:K).EQ.'/')THEN N1=K+1 NL=25 END IF ELSE IF(N1.GT.1)THEN IF(KEY.EQ.0)THEN KEY=1 ELSE N1=1 NL=NCH END IF END IF IF(KEY.EQ.0)THEN GOTO27014 END IF END IF NAT=NAT+1 IF(L5+26.GT.QXCUR)THEN IQXY=MAX(L5+26,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0320',0) END IF DO27016IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27016 CONTINUE QXCUR=IQXY END IF JUNK=L5+26 M=IP+IREL(1) CALLAA51(QX,M,QX,L5,6,0) CALLAA57(QX(M),1,NAME1,1,24,0) CALLAA05(NAME1,I,J,' ',IWIWIW) N5=L5+6 L5=N5+1 CALLAA73(ATTYP,QX(L5),0,5) DO27018I=1,3 M=IP+IREL(I+2) QX(L5+I)=QX(M) 27018 CONTINUE M=IP+IREL(30) IF(M.GT.IP)THEN ATTMP=NINT(QX(M)) END IF IF(REFTMP.GE.3)THEN IF(DPTYP(ATTYP).GE.0)THEN TMP=DPTYP(ATTYP) ELSE TMP=ATTMP END IF IF(TMP.EQ.2)THEN TMP=6 END IF END IF CALLAA73(TMP,QX(L5),5,3) L5=L5+3 IF(TMP.EQ.0)THEN FLGOVA=1 ELSE IF(TMP.EQ.1)THEN L5=L5+1 FLGISO=1 QX(L5)=QX(MARK4+1) IF(ATTMP.EQ.1)THEN M=IP+IREL(6) IF(M.GT.IP)THEN QX(L5)=QX(M)/BTOU END IF ELSE IF(ATTMP.EQ.2)THEN M=IP+IREL(7) QX(L5)=(QX(M)+QX(M+1)+QX(M+2))/3.0/BTOU END IF ELSE FLGANI=1 IF(ATTMP.LE.1)THEN Q=QX(MARK4+1) IF(ATTMP.EQ.1)THEN M=IP+IREL(6) IF(M.GT.IP)THEN Q=QX(M)/BTOU END IF END IF DO27020I=1,6 QX(L5+I)=Q*CELL(I) 27020 CONTINUE ELSE DO27022I=1,6 M=IP+IREL(I+6) QX(L5+I)=100.*QX(M)/CELL(I+6) 27022 CONTINUE END IF L5=L5+6 END IF IF(POP.GT.0)THEN L5=L5+1 QX(L5)=1. M=IP+IREL(13) IF(M.GT.IP)THEN QX(L5)=QX(M) END IF END IF IF(MLT.GT.0)THEN L5=L5+1 QX(L5)=1. M=IP+IREL(29) IF(M.GT.IP)THEN QX(L5)=QX(M) END IF END IF L5=L5+1 QX(N5)=FLOAT(L5+6) GOTO27014 27015 CONTINUE IF(NAT.EQ.0)THEN CALLAA06('CR0303',0) END IF MARK6=L5-1 IF(FLGOVA.GT.0)THEN REFUOV=1 END IF IF((FLGOVA+FLGISO+FLGANI).EQ.1)THEN MIXTMP=0 IF(FLGOVA.EQ.1)THEN REFTMP=0 ELSE IF(FLGISO.EQ.1)THEN REFTMP=1 ELSE REFTMP=6 END IF ELSE MIXTMP=1 IF(FLGOVA.EQ.0)THEN REFTMP=5 ELSE IF(FLGANI.EQ.0)THEN REFTMP=3 ELSE REFTMP=4 END IF END IF CALLAA03(FLOAT(NSLAVE),1,CR33,350513.,1) IF(NSLAVE.GT.0)THEN CALLAA04(1,CR33,NCR33,3,3) END IF RETURN END C-------CR04 SUBROUTINECR04 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALATWT CHARACTER*(24 )CH CHARACTER*(24 )CH1 REALCOSR REALCOSSQ REALDX,DY,DZ INTEGERI,I1,I2,I6 INTEGERII,IJ,IR INTEGERIAT INTEGERI6FRST INTEGERIGR INTEGERIROT,I6ROT INTEGERIT INTEGERJ,J1,JC,JI,JJ,JUNK INTEGERK,KR INTEGERKIK1,KIK2 INTEGERL2,L5,L6 INTEGERL6FRST INTEGERM,M1,M2 INTEGERN,NM INTEGERNATGR INTEGERNTMP REALPHI REALPSI REALQ,QQ,Q0,Q1,Q2,Q3 INTEGERS REALSINCOS REALSINR REALSINSQ REALTHETA INTEGERNCR41 CHARACTER*49 CR41 INTEGERNCR42 CHARACTER*1 CR42 REAL PI REAL DAT(24 ) INTEGER NN INTEGER LL REAL SUMQSQ DATANCR41/49 /, CR41/' GROUP ATOMGR RESTR CONSTR NOREF BLOCK E &ND '/ DATANCR42/1 /, CR42/'/'/ DATAPI/3.1415926535/ DATADAT/1.,-1.,-1.,-1.,1.,-1.,-1.,-1.,1.,1.,1.,1.,-1.,-1.,-1.,-1., &1.,1.,1.,-1.,1.,1.,1.,-1./ DATANN/0/ DATALL/0/ DATASUMQSQ/0./ LINID=LINID-2 NTMP=6 L6=MARK6 ISTEP6=30 NSTEP6=8 IGR=0 I6FRST=0 27000 CONTINUE IF(LINID.NE.1)THEN GOTO27001 END IF I6=L6 IGR=IGR+1 IF(I6+ISTEP6.GT.QXCUR)THEN IQXY=MAX(I6+ISTEP6,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0420',0) END IF DO27002IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27002 CONTINUE QXCUR=IQXY END IF L6=I6+ISTEP6 CALLAA51(0.,1,QX,I6+1,ISTEP6,2) IF(ABS(BUFIN(1)-(-4.E+20)).GT.1.E13)THEN QX(I6+2)=BUFIN(1) END IF I1=I6+8 DO27004I=2,4 I1=I1+1 IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN QX(I1)=1. ELSE QX(I1-6)=BUFIN(I) END IF 27004 CONTINUE IF(ABS(BUFIN(5)-(-4.E+20)).LT.1.E13)THEN QX(I6+12)=1. QX(I6+13)=1. QX(I6+14)=1. END IF IF(BUFIN(5).GT.0.)THEN IF(BUFIN(5).LE.2.)THEN QX(I6+13)=1. ELSE QX(I6+12)=1. END IF END IF IF(ABS(BUFIN(6)-(-4.E+20)).LT.1.E13)THEN BUFIN(6)=1. END IF IF(ABS((BUFIN(6))-(0.)).GT.5.0E-7)THEN CALLAA51(BUFIN,6,QX,I6+15,NTMP,2) END IF IF(ABS(BUFIN(7)-(-4.E+20)).LT.1.E13)THEN QX(I6+21)=FLOAT(REFPOP) ELSE QX(I6+21)=BUFIN(7) END IF IF((NINT(QX(I6+21)).NE.0).AND.(REFPOP.EQ.0))THEN CALLAA06('CR0402',0) END IF IF(ABS((QX(I6+2))-(0.)).LE.5.0E-7)THEN I6FRST=0 ELSE IF(ABS((QX(I6+2))-(1.)).LE.5.0E-7)THEN I6FRST=I6 ELSE IF(I6FRST.LE.0)THEN CALLAA06('CR0401',0) END IF CALLAA51(QX,I6FRST+6,QX,I6+6,18,1) END IF NATGR=0 S=0 Q=0. CALLAA01(CR41,NCR41) IF(LINID.NE.2)THEN CALLAA06('CR0408',0) END IF IF(ABS(BUFIN(1)-(-4.E+20)).LT.1.E13)THEN CALLAA06('CR0406',0) END IF IF(1.GT.0)THEN N=(BUFIN(1)*(-1.0E-22)+0.001) NN=NINT(BUFIN(1)*(-1.0E-20))-N*100 END IF J=NN-N CALLAA09(CR42,1,CHRIN,N,1,1,J,NM) IF(NM.EQ.0)THEN CALLAA06('CR0407',0) END IF J=NM-1 NM=N+NM CH=CHRIP(N:N+J-1) IAT=0 L5=MARK5+7 27006 IF(L5.LT.MARK6)THEN IAT=IAT+1 CALLAA57(QX(L5-6),1,CH1,1,24,0) IF(CH.EQ.CH1.OR.S.EQ.1)THEN IF(L6+NSTEP6.GT.QXCUR)THEN IQXY=MAX(L6+NSTEP6,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0420',0) END IF DO27009IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27009 CONTINUE QXCUR=IQXY END IF JUNK=L6+NSTEP6 NATGR=NATGR+1 QX(L6+1)=FLOAT(L5) QX(L6+2)=FLOAT(IAT) CALLAA74(QX(L5+1),L2,0,5) L2=MARK2+(L2-1)*NSTEP2 ATWT=QX(L2+4) QX(L6+6)=ATWT I1=I6+2 I2=L5+1 DO27011J=1,3 I1=I1+1 I2=I2+1 IF(ABS((QX(I1+6))-(0.)).LE.5.0E-7)THEN GOTO27011 END IF QX(I1)=QX(I1)+ATWT*QX(I2) 27011 CONTINUE L6=L6+NSTEP6 Q=Q+ATWT IF(S.EQ.0)THEN S=1 CH=CHRIP(NM:NN) ELSE IF(CH.EQ.CH1)THEN GOTO27008 END IF END IF L5=NINT(QX(L5)) GOTO27006 27008 CONTINUE END IF IF(CH.NE.CH1)THEN CALLAA06('CR0403',0) END IF IF(NATGR.LT.3)THEN CALLAA06('CR0404',0) END IF IF(QX(I6+2).LT.1.5)THEN QX(I6+1)=FLOAT(NATGR) ELSE QX(I6+1)=FLOAT(I6FRST) END IF J=I6+3 27013 IF(J.LE.I6+5)THEN IF(ABS((QX(J+6))-(0.)).LE.5.0E-7)THEN GOTO27014 END IF QX(J)=QX(J)/Q 27014 CONTINUE J=J+1 GOTO27013 END IF QX(I6+37)=Q LL=L6 L6=I6+ISTEP6-NSTEP6 IF(LL+27.GT.QXCUR)THEN IQXY=MAX(LL+27,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0420',0) END IF DO27016IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27016 CONTINUE QXCUR=IQXY END IF JUNK=LL+27 CALLAA51(0.,1,QX,LL+1,18,2) DO27018I=1,NATGR L6=L6+NSTEP6 L5=NINT(QX(L6+1)) DX=QX(L5+2)-QX(I6+3) DY=QX(L5+3)-QX(I6+4) DZ=QX(L5+4)-QX(I6+5) QX(L6+3)=CELL(13)*DX+CELL(16)*DY+CELL(19)*DZ QX(L6+4)=CELL(14)*DX+CELL(17)*DY+CELL(20)*DZ QX(L6+5)=CELL(15)*DX+CELL(18)*DY+CELL(21)*DZ ATWT=QX(L6+6) QX(LL+1)=QX(LL+1)+ATWT*(QX(L6+4)*QX(L6+4)+QX(L6+5)*QX(L6+5)) QX(LL+5)=QX(LL+5)+ATWT*(QX(L6+3)*QX(L6+3)+QX(L6+5)*QX(L6+5)) QX(LL+9)=QX(LL+9)+ATWT*(QX(L6+3)*QX(L6+3)+QX(L6+4)*QX(L6+4)) QX(LL+2)=QX(LL+2)-ATWT*QX(L6+3)*QX(L6+4) QX(LL+3)=QX(LL+3)-ATWT*QX(L6+3)*QX(L6+5) QX(LL+6)=QX(LL+6)-ATWT*QX(L6+4)*QX(L6+5) 27018 CONTINUE QX(LL+4)=QX(LL+2) QX(LL+7)=QX(LL+3) QX(LL+8)=QX(LL+6) Q=SQRT(QX(LL+2)*QX(LL+2)+QX(LL+3)*QX(LL+3)+QX(LL+6)*QX(LL+6))/.666 &666 Q0=.0001*Q QX(LL+10)=1. QX(LL+14)=1. QX(LL+18)=1. 27020 IF(Q.GT.Q0)THEN Q=.333333*Q 27022 CONTINUE IT=0 IR=LL DO27024I=2,3 IR=IR+3 JC=LL-3 J1=I-1 DO27026J=1,J1 JC=JC+3 IJ=IR+J IF(ABS(QX(IJ)).LT.Q)THEN GOTO27026 END IF IT=1 II=IR+I JJ=JC+J Q1=.5*(QX(JJ)-QX(II)) Q2=QX(IJ)/SQRT(QX(IJ)*QX(IJ)+Q1*Q1) IF(Q1.GT.0.)THEN Q2=-Q2 END IF SINR=Q2/SQRT(2.+2.*SQRT(1.-Q2*Q2)) SINSQ=SINR*SINR COSSQ=1.-SINSQ COSR=SQRT(COSSQ) SINCOS=SINR*COSR KIK1=9+JC+1 KIK2=9+IR+1 Q1=QX(KIK1) Q2=QX(KIK2) QX(KIK1)=Q1*COSR-Q2*SINR QX(KIK2)=Q1*SINR+Q2*COSR KIK1=9+JC+2 KIK2=9+IR+2 Q1=QX(KIK1) Q2=QX(KIK2) QX(KIK1)=Q1*COSR-Q2*SINR QX(KIK2)=Q1*SINR+Q2*COSR KIK1=9+JC+3 KIK2=9+IR+3 Q1=QX(KIK1) Q2=QX(KIK2) QX(KIK1)=Q1*COSR-Q2*SINR QX(KIK2)=Q1*SINR+Q2*COSR K=6-I-J KR=LL+(K-1)*3 KIK1=0+KR+J KIK2=0+KR+I Q1=QX(KIK1) Q2=QX(KIK2) QX(KIK1)=Q1*COSR-Q2*SINR QX(KIK2)=Q1*SINR+Q2*COSR M1=JC+K M2=KR+J QX(M1)=QX(M2) M1=IR+K M2=KR+I QX(M1)=QX(M2) Q1=QX(JJ) Q2=QX(II) Q3=QX(IJ) QQ=2.*SINCOS*Q3 QX(JJ)=COSSQ*Q1+SINSQ*Q2-QQ QX(II)=SINSQ*Q1+COSSQ*Q2+QQ QX(IJ)=SINCOS*(Q1-Q2)+(COSSQ-SINSQ)*Q3 JI=JC+I QX(JI)=QX(IJ) 27026 CONTINUE 27024 CONTINUE IF(IT.EQ.0)THEN GOTO27023 END IF GOTO27022 27023 CONTINUE GOTO27020 END IF DO27028K=1,3 IF(K.EQ.2)THEN I=1 J=2 II=LL+1 JJ=LL+5 ELSE I=2 J=3 II=LL+5 JJ=LL+9 END IF IF(QX(II).LT.QX(JJ))THEN GOTO27028 END IF Q1=QX(II) QX(II)=QX(JJ) QX(JJ)=Q1 M1=LL+3*(I-1)+9 M2=LL+3*(J-1)+9 DO27030M=1,3 M1=M1+1 M2=M2+1 QX(M2)=-QX(M2) Q1=QX(M1) QX(M1)=QX(M2) QX(M2)=Q1 27030 CONTINUE 27028 CONTINUE I6ROT=I6+ISTEP6-9 IF(QX(I6+2).LT.2.)THEN CALLAA51(QX,LL+10,QX,I6ROT+1,9,1) ELSE IROT=I6FRST+ISTEP6-9 K=0 27032 IF(K.LT.24)THEN I1=LL+9 I2=LL+18 DO27034J=1,3 K=K+1 DO27036J1=1,3 I1=I1+1 I2=I2+1 QX(I2)=DAT(K)*QX(I1) 27036 CONTINUE 27034 CONTINUE I=I6ROT I1=IROT-1 DO27038J=1,3 I2=LL+17 I1=I1+1 DO27040J1=1,3 I=I+1 I2=I2+1 QX(I)=QX(I2+1)*QX(I1+1)+QX(I2+4)*QX(I1+4)+QX(I2+7)*QX(I1+7) 27040 CONTINUE 27038 CONTINUE L6=I6+ISTEP6-NSTEP6 L6FRST=I6FRST+ISTEP6-NSTEP6 SUMQSQ=0. DO27042N=1,NATGR I=I6ROT-3 L6=L6+NSTEP6 L6FRST=L6FRST+NSTEP6 DO27044J=1,3 I=I+3 I2=L6FRST+2+J Q=QX(I+1)*QX(L6+3)+QX(I+2)*QX(L6+4)+QX(I+3)*QX(L6+5)-QX(I2) SUMQSQ=SUMQSQ+Q*Q 27044 CONTINUE 27042 CONTINUE IF(SUMQSQ.LT.1.)THEN GOTO27033 END IF GOTO27032 27033 CONTINUE END IF IF(SUMQSQ.GT.1.)THEN CALLAA06('CR0405',0) END IF END IF IF(ABS((QX(I6ROT+9))-(1.)).LE.5.0E-7)THEN THETA=0. PSI=0. PHI=ACOS(QX(I6ROT+1)) IF(QX(I6ROT+4).LT.0.)THEN PHI=-PHI END IF ELSE THETA=ACOS(QX(I6ROT+9)) IF(ABS((QX(I6ROT+6))-(0.)).LE.5.0E-7)THEN IF(QX(I6ROT+3).GE.0.)THEN PHI=PI/2 ELSE PHI=-PI/2. END IF ELSE PHI=ATAN2(QX(I6ROT+3),-QX(I6ROT+6)) END IF IF(ABS((QX(I6ROT+6))-(0.)).LE.5.0E-7)THEN IF(QX(I6ROT+7).GE.0.)THEN PSI=PI/2. ELSE PSI=-PI/2. END IF ELSE PSI=ATAN2(QX(I6ROT+7),QX(I6ROT+8)) END IF END IF IF(PHI.LT.0.)THEN PHI=PHI+2.*PI END IF IF(PSI.LT.0.)THEN PSI=PSI+2.*PI END IF QX(I6+6)=PHI QX(I6+7)=THETA QX(I6+8)=PSI L6=I6+ISTEP6+NATGR*NSTEP6 CALLAA01(CR41,NCR41) GOTO27000 27001 CONTINUE MARK7=L6 RETURN END C-------CR05 SUBROUTINECR05 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(1 )C CHARACTER*(24 )CH CHARACTER*(24 )CH1 INTEGERCLASS INTEGERI,J,L,N,NT INTEGERNATM INTEGERKEY INTEGERI7 INTEGERJUNK INTEGERL5,L7 INTEGERNCR51 CHARACTER*35 CR51 INTEGERNCR52 CHARACTER*17 CR52 DATANCR51/35 /, CR51/' RESTR CONSTR NOREF BLOCK END '/ DATANCR52/17 /, CR52/' BON ANG DIH PLA '/ LINID=LINID-2 L7=MARK7 27000 CONTINUE IF(LINID.NE.1)THEN GOTO27001 END IF IF(L7+30.GT.QXCUR)THEN IQXY=MAX(L7+30,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0520',0) END IF DO27002IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27002 CONTINUE QXCUR=IQXY END IF JUNK=L7+30 I=2 I7=L7 L7=I7+4 NATM=0 IF(1.GT.0)THEN J=(BUFIN(1)*(-1.0E-22)+0.001) N=NINT(BUFIN(1)*(-1.0E-20))-J*100 END IF CALLAA09(CHRIN,J,CR52,2,3,4,NCR52,CLASS) IF(CLASS.LE.0)THEN CALLAA06('CR0501',0) END IF IF(2.GT.0)THEN J=(BUFIN(2)*(-1.0E-22)+0.001) N=NINT(BUFIN(2)*(-1.0E-20))-J*100 END IF 27004 CONTINUE CH1=CHRIP(J:N) L5=MARK5+7 27006 IF(L5.LT.MARK6)THEN CALLAA57(QX(L5-6),1,CH,1,24,0) IF(CH.EQ.CH1)THEN GOTO27008 END IF L5=NINT(QX(L5)) GOTO27006 27008 CONTINUE END IF IF(L5.GE.MARK6)THEN CALLAA06('CR0502',0) END IF QX(L7+1)=FLOAT(L5) QX(L7+2)=1555. I=I+1 NATM=NATM+1 IF(BUFIN(I).GE.-4.E+20)THEN GOTO27005 END IF IF(I.GT.0)THEN J=(BUFIN(I)*(-1.0E-22)+0.001) N=NINT(BUFIN(I)*(-1.0E-20))-J*100 END IF IF(CHRIN(J:J).EQ.'(')THEN QX(L7+2)=0. NT=0 DO27009L=J+1,N-1 C=CHRIN(L:L) IF(C.EQ.' '.OR.C.EQ.')')THEN GOTO27009 END IF IF(NT.GT.0)THEN NT=NT+1 END IF IF(C.EQ.'_')THEN NT=1 GOTO27009 END IF KEY=INDEX('0123456789',C) IF(KEY.EQ.0)THEN CALLAA06('CR0505',0) END IF QX(L7+2)=10.*QX(L7+2)+FLOAT(KEY-1) 27009 CONTINUE IF(NT.EQ.0)THEN QX(L7+2)=QX(L7+2)*1000.+555. ELSE IF(NT.NE.4)THEN CALLAA06('CR0506',0) END IF I=I+1 IF(BUFIN(I).GE.-4.E+20)THEN GOTO27005 END IF IF(I.GT.0)THEN J=(BUFIN(I)*(-1.0E-22)+0.001) N=NINT(BUFIN(I)*(-1.0E-20))-J*100 END IF END IF L7=L7+2 GOTO27004 27005 CONTINUE IF(NATM.LE.CLASS)THEN CALLAA06('CR0503',0) END IF QX(I7+1)=FLOAT(CLASS) QX(I7+2)=FLOAT(NATM) IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN CALLAA06('CR0504',0) END IF QX(I7+3)=BUFIN(I) IF(ABS(BUFIN(I+1)-(-4.E+20)).GT.1.E13)THEN QX(I7+4)=BUFIN(I+1) ELSE QX(I7+4)=.03*QX(I7+3) END IF L7=L7+2+3*NATM CALLAA01(CR51,NCR51) GOTO27000 27001 CONTINUE MARK8=L7 RETURN END C-------CR06 SUBROUTINECR06 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(128 )CH CHARACTER*(24 )NAME1 CHARACTER*(24 )NAME2 INTEGERATTYP INTEGERCONTLI INTEGERFIRST INTEGERI,II,III1,III2,IP,I1,I6 INTEGERIAT,IATSUB INTEGERIREL(9) INTEGERIWANT(8) INTEGERISUB INTEGERI6FRST INTEGERJ,K INTEGERJUNK INTEGERLINLAS INTEGERKEY INTEGERL,LIM,LL,L2,L6,L8,LL2 INTEGERM INTEGERNATGR INTEGERNBLK INTEGERNC,NN INTEGERNCH INTEGERNP INTEGERNTMP INTEGERP INTEGERPACK INTEGERPAR,PARSUB INTEGERPARTOT INTEGERPFLAG REALQ,Q1 INTEGERTYPE INTEGERNCR61 CHARACTER*28 CR61 INTEGERNCR62 CHARACTER*39 CR62 INTEGERNCR63 CHARACTER*8 CR63 INTEGERNCR64 CHARACTER*16 CR64 INTEGERNCR65 CHARACTER*5 CR65 INTEGER L6FRST INTEGER I8 INTEGER L5 INTEGER IL INTEGER SPANA INTEGER SPANP INTEGER DSPFLG INTEGER IAT1 DATANCR61/28 /, CR61/' CONSTR NOREF BLOCK END '/ DATANCR62/39 /, CR62/'X Y Z U U11U22U33U12U13U23POPAPPNEU'/ DATANCR63/8 /, CR63/'(),-+=* '/ DATANCR64/16 /, CR64/'SKF UOV EXT DSP '/ DATANCR65/5 /, CR65/'(),/ '/ DATAL6FRST/0/ DATAI8/0/ DATAL5/0/ DATAIL/0/ DATASPANA/0/ DATASPANP/0/ DATADSPFLG/0/ DATAIAT1/0/ LINID=LINID-1 L6=MARK6 L8=MARK8 IF(REFTMP.EQ.6)THEN NTMP=6 ELSE IF(REFTMP.GT.0)THEN NTMP=1 ELSE NTMP=0 END IF 27000 IF(L6.LT.MARK7)THEN I6=L6 L6=L6+ISTEP6-NSTEP6 Q=QX(I6+37) IF(QX(I6+2).LT.1.5)THEN NATGR=NINT(QX(I6+1)) ELSE I6FRST=NINT(QX(I6+1)) NATGR=NINT(QX(I6FRST+1)) L6FRST=I6FRST+ISTEP6-NSTEP6 END IF FIRST=1 DO27002I=1,NATGR PAR=0 PARTOT=3+NTMP+REFPOP L6=L6+NSTEP6 L6FRST=L6FRST+NSTEP6 DO27004P=1,PARTOT PAR=PAR+1 IF((P.EQ.4).AND.(NTMP.EQ.6))THEN PAR=5 END IF IF((P.EQ.PARTOT).AND.(REFPOP.EQ.1))THEN PAR=11 END IF IF(ABS((QX(I6+2))-(1.)).LE.5.0E-7)THEN IF(PAR.LE.3)THEN GOTO27004 END IF END IF I8=L8 IF(I8+5.GT.QXCUR)THEN IQXY=MAX(I8+5,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27006IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27006 CONTINUE QXCUR=IQXY END IF L8=I8+5 QX(I8+1)=1. QX(I8+2)=3. QX(I8+3)=QX(L6+2) QX(I8+4)=FLOAT(PAR) QX(I8+5)=0. IF(PAR.LE.3)THEN QX(I8+5)=-9999. J=PAR 27008 IF(J.LE.6)THEN I1=I6+8+J IF(QX(I1).GT.0.5)THEN QX(I8+1)=QX(I8+1)+1. IF(L8+3.GT.QXCUR)THEN IQXY=MAX(L8+3,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27010IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27010 CONTINUE QXCUR=IQXY END IF JUNK=L8+3 QX(L8+1)=FLOAT(I1) IF(FIRST.EQ.1)THEN QX(L8+2)=FLOAT(J) ELSE QX(L8+2)=0. END IF IF(J.EQ.PAR)THEN QX(L8+3)=1. ELSE QX(L8+3)=0. END IF L8=L8+3 END IF IF((J.LT.4).AND.(FIRST.EQ.0))THEN J=4 ELSE J=J+1 END IF GOTO27008 END IF FIRST=0 IF(QX(I6+2).GT.1.5)THEN QX(I8+1)=QX(I8+1)+3. IF(L8+9.GT.QXCUR)THEN IQXY=MAX(L8+9,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27012IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27012 CONTINUE QXCUR=IQXY END IF JUNK=L8+9 DO27014J=1,3 QX(L8+1)=QX(L6FRST+2) QX(L8+2)=FLOAT(J) QX(L8+3)=0. L8=L8+3 27014 CONTINUE END IF ELSE IF(PAR.EQ.4)THEN I1=I6+15 ELSE I1=I6+10+PAR END IF IF(QX(I1).LT.-.5)THEN IF(QX(I6+2).GT.1.5)THEN QX(I8+1)=QX(I8+1)+1. IF(L8+3.GT.QXCUR)THEN IQXY=MAX(L8+3,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27016IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27016 CONTINUE QXCUR=IQXY END IF JUNK=L8+3 QX(L8+1)=QX(L6FRST+2) QX(L8+2)=FLOAT(PAR) QX(L8+3)=1. L8=L8+3 ELSE L8=I8 END IF ELSE IF(QX(I1).GT.0.5)THEN QX(I8+1)=QX(I8+1)+1. IF(L8+3.GT.QXCUR)THEN IQXY=MAX(L8+3,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27018IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27018 CONTINUE QXCUR=IQXY END IF JUNK=L8+3 QX(L8+1)=FLOAT(I1) IF(I.EQ.1)THEN QX(L8+2)=FLOAT(PAR) ELSE QX(L8+2)=0. END IF QX(L8+3)=1. L8=L8+3 ELSE QX(I8+2)=2. L8=L8-1 END IF END IF 27004 CONTINUE 27002 CONTINUE L6=L6+NSTEP6 GOTO27000 END IF MARK14=L8 IWANT(1)=1 IWANT(2)=2 IWANT(3)=3 IWANT(4)=4 IWANT(5)=5 IWANT(6)=11 IWANT(7)=12 IWANT(8)=13 SIGNAL(1)=8 SIGNAL(2)=0 SIGNAL(3)=8 SIGNAL(4)=0 CALLAA15(1,17,PACK,IP,0,SIGNAL,IWANT,IREL) IF(IP.GT.0)THEN 27020 CONTINUE CALLAA12(1,17,PACK,IP,0) IF(IP.LE.0)THEN GOTO27021 END IF M=IP+IREL(5) TYPE=NINT(QX(M)) M=IP+IREL(2) ISUB=NINT(QX(M)) IF(TYPE.EQ.4)THEN IF(BLKTYP.EQ.1)THEN POLSPG(ISUB)=1 END IF ELSE IF(TYPE.GT.0)THEN M=IP+IREL(1) CALLAA57(QX(M),1,NAME1,1,24,0) IAT=1 L5=MARK5+7 27022 IF(L5.LT.MARK6)THEN CALLAA57(QX(L5-6),1,NAME2,1,24,0) IF(NAME1.EQ.NAME2)THEN GOTO27024 END IF IAT=IAT+1 L5=NINT(QX(L5)) GOTO27022 27024 CONTINUE END IF IF(L5.GE.MARK6)THEN GOTO27020 END IF IF(TYPE.EQ.3)THEN IF(L8+4.GT.QXCUR)THEN IQXY=MAX(L8+4,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27025IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27025 CONTINUE QXCUR=IQXY END IF JUNK=L8+4 QX(L8+1)=1. QX(L8+2)=2. QX(L8+3)=FLOAT(IAT) QX(L8+4)=FLOAT(ISUB) IF(ISUB.GE.4)THEN QX(L8+4)=QX(L8+4)+1. END IF L8=L8+4 ELSE IF(TYPE.EQ.1)THEN IF(L8+8.GT.QXCUR)THEN IQXY=MAX(L8+8,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27027IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27027 CONTINUE QXCUR=IQXY END IF JUNK=L8+8 QX(L8+1)=2. QX(L8+2)=3. QX(L8+3)=FLOAT(IAT) QX(L8+4)=FLOAT(ISUB) IF(ISUB.GE.4)THEN QX(L8+4)=QX(L8+4)+1. END IF M=IP+IREL(4) QX(L8+5)=QX(M) J=IP+IREL(6) CALLAA57(QX(J),1,NAME1,1,24,0) IAT=1 L5=MARK5+7 27029 IF(L5.LT.MARK6)THEN CALLAA57(QX(L5-6),1,NAME2,1,24,0) IF(NAME1.EQ.NAME2)THEN GOTO27031 END IF IAT=IAT+1 L5=NINT(QX(L5)) GOTO27029 27031 CONTINUE END IF IF(L5.GE.MARK6)THEN GOTO27020 END IF QX(L8+6)=FLOAT(IAT) M=IP+IREL(7) QX(L8+7)=QX(M) IF(QX(M).GE.4)THEN QX(L8+7)=QX(L8+7)+1. END IF M=IP+IREL(8) QX(L8+8)=QX(M) M=IP+IREL(3) QX(L8+5)=QX(L8+5)/QX(M) QX(L8+8)=QX(L8+8)/QX(M) IF(QX(L8+7).GT.QX(L8+4))THEN IF(ABS((QX(L8+7))-(QX(L8-4))).GT.5.0E-7)THEN Q1=QX(L8+4) QX(L8+4)=QX(L8+7) QX(L8+7)=Q1 QX(L8+8)=1./QX(L8+8) ELSE QX(L8+7)=QX(L8-1) QX(L8+8)=QX(L8+8)*QX(L8) END IF END IF L8=L8+8 END IF END IF GOTO27020 27021 CONTINUE END IF 27032 CONTINUE IF(LINID.NE.1)THEN GOTO27033 END IF CALLAA55(CHRIP,1,CHROT,2,CHRMAX,0) CALLAA04(0,' ',0,1,3) DO27034NN=1,CHRMAX-1 IF(CHRIN(NN+1:NN+1).EQ.':')THEN GOTO27035 END IF 27034 CONTINUE 27035 CONTINUE IF(NN.EQ.CHRMAX)THEN NN=CHRMAX-1 END IF CHRIN(NN+1:CHRMAX)=' ' CHRIP(NN+1:CHRMAX)=' ' 27036 IF(CHRIN(NN:NN).EQ.' ')THEN NN=NN-1 GOTO27036 END IF PFLAG=0 I=CHRCOL 27038 IF(I.LE.NN)THEN CALLAA09(CHRIN,I,CR63,1,1,1,8,KEY) IF(KEY.EQ.0)THEN GOTO27039 ELSE IF(KEY.EQ.8)THEN CALLAA55(CHRIN,(I+1),CHRIN,I,(NN-I),0) CALLAA55(BLANK,1,CHRIN,NN,1,0) CALLAA55(CHRIP,(I+1),CHRIP,I,(NN-I),0) CALLAA55(BLANK,1,CHRIP,NN,1,0) I=I-1 NN=NN-1 GOTO27039 END IF IF((KEY.EQ.4.OR.KEY.EQ.5).AND.PFLAG.EQ.0)THEN J=NN-1 27041 IF(J.GE.I)THEN CALLAA55(CHRIN,J,CHRIN,(J+1),1,0) J=J-1 GOTO27041 END IF CALLAA55(BLANK,1,CHRIN,I,1,0) J=NN-1 27044 IF(J.GE.I)THEN CALLAA55(CHRIP,J,CHRIP,(J+1),1,0) J=J-1 GOTO27044 END IF CALLAA55(BLANK,1,CHRIP,I,1,0) I=I+1 NN=NN+1 GOTO27039 ELSE IF(KEY.EQ.6)THEN CALLAA09(CHRIN,I+9,CR63,6,1,1,1,KEY) IF(KEY.GT.0)THEN I=I+9 GOTO27039 END IF END IF IF(KEY.EQ.2)THEN PFLAG=0 END IF IF(PFLAG.EQ.0)THEN CALLAA55(BLANK,1,CHRIN,I,1,0) CALLAA55(BLANK,1,CHRIP,I,1,0) END IF IF(KEY.EQ.1)THEN PFLAG=1 END IF 27039 CONTINUE I=I+1 GOTO27038 END IF CALLAA02 Q=BUFIN(1) BUFIN(1)=BUFIN(3) BUFIN(3)=BUFIN(2) BUFIN(2)=Q I=1 27047 IF(I.LE.40)THEN IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27049 END IF IF(BUFIN(I).LT.-4.E+20)THEN BUFIN(I)=-9999. END IF IF(BUFIN(I+1).GE.-4.E+20)THEN CALLAA06('-CR0601',0) END IF IF(BUFIN(I+2).GE.-4.E+20)THEN CALLAA06('-CR0601',0) END IF IF(I+1.GT.0)THEN NC=(BUFIN(I+1)*(-1.0E-22)+0.001) NN=NINT(BUFIN(I+1)*(-1.0E-20))-NC*100 END IF CALLAA09(CHRIN,NC,CR62,1,(NN-NC),3,NCR62,PAR) IF(PAR.EQ.0)THEN CALLAA06('-CR0601',0) END IF IF((I+2).GT.0)THEN NC=(BUFIN((I+2))*(-1.0E-22)+0.001) NN=NINT(BUFIN((I+2))*(-1.0E-20))-NC*100 END IF NAME1=CHRIP(NC:NN-1) L5=MARK5+7 IAT=1 27050 IF(IAT.LE.NAT)THEN CALLAA57(QX(L5-6),1,NAME2,1,24,0) IF(NAME1.EQ.NAME2)THEN GOTO27051 END IF L5=NINT(QX(L5)) IAT=IAT+1 GOTO27050 27051 CONTINUE END IF IF(IAT.GT.NAT)THEN CALLAA06('CR0601',0) END IF IF(I.EQ.1)THEN IATSUB=IAT PARSUB=PAR I8=L8 IF(PARSUB.GT.4.AND.PARSUB.LT.11)THEN BUFIN(1)=BUFIN(1)*100./CELL(6+PARSUB-4) END IF IF(I8+5.GT.QXCUR)THEN IQXY=MAX(I8+5,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27052IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27052 CONTINUE QXCUR=IQXY END IF JUNK=I8+5 QX(I8+1)=1. QX(I8+2)=3. QX(I8+3)=FLOAT(IAT) QX(I8+4)=FLOAT(PAR) QX(I8+5)=BUFIN(1) L8=L8+5 ELSE IF(IAT.GT.IATSUB)THEN CALLAA06('CR0610',0) END IF IF(IAT.EQ.IATSUB.AND.PAR.GT.PARSUB)THEN CALLAA06('CR0610',0) END IF QX(I8+1)=QX(I8+1)+1. IF(L8+3.GT.QXCUR)THEN IQXY=MAX(L8+3,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27054IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27054 CONTINUE QXCUR=IQXY END IF JUNK=L8+3 IF(PARSUB.GT.4.AND.PARSUB.LT.11)THEN BUFIN(I)=BUFIN(I)*100./CELL(6+PARSUB-4) END IF IF(PAR.GT.4.AND.PAR.LT.11)THEN BUFIN(I)=BUFIN(I)*CELL(6+PAR-4)/100. END IF QX(L8+1)=FLOAT(IAT) QX(L8+2)=FLOAT(PAR) QX(L8+3)=BUFIN(I) L8=L8+3 END IF I=I+3 GOTO27047 27049 CONTINUE END IF CALLAA01(CR61,NCR61) GOTO27032 27033 CONTINUE IF(LINID.LE.3)THEN NCH=8*NATTYP CALLAA57(QX(MARK1+1),1,CH,1,NCH,0) END IF NBLK=0 LINLAS=2 L=L8 CONTLI=0 27056 CONTINUE IF(LINID.GT.3)THEN GOTO27057 END IF CALLAA55(CHRIP,1,CHROT,2,CHRMAX,0) CALLAA04(0,' ',0,1,3) IF(LINID.EQ.1)THEN CALLAA06('CR0607',0) END IF IF((LINID.EQ.2).AND.(LINLAS.EQ.3))THEN CALLAA06('CR0602',0) END IF IF((LINID.EQ.3).AND.(LINLAS.EQ.2))THEN LINLAS=3 MARK9=L END IF I=1 27058 IF(I.LE.40)THEN IF(ABS(BUFIN(I)-(-4.E+20)).LT.1.E13)THEN GOTO27060 END IF IF(CONTLI.EQ.0)THEN IL=L IF(IL+2.GT.QXCUR)THEN IQXY=MAX(IL+2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27061IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27061 CONTINUE QXCUR=IQXY END IF L=IL+2 QX(IL+1)=0. QX(IL+2)=2. SPANP=0 SPANA=0 DSPFLG=0 ATTYP=0 NP=1 IF(LINID.EQ.3)THEN NBLK=NBLK+1 END IF END IF IF(I.GT.0)THEN NC=(BUFIN(I)*(-1.0E-22)+0.001) NN=NINT(BUFIN(I)*(-1.0E-20))-NC*100 END IF 27063 CONTINUE CONTLI=0 CALLAA09(CHRIN,NN,CR63,3,1,1,1,LIM) IF(LIM.EQ.0)THEN CALLAA09(CHRIN,NN,CR63,6,1,1,1,LIM) END IF IF(LIM.EQ.0)THEN GOTO27064 END IF I=I+1 IF(BUFIN(I).LT.-4.E+20)THEN IF(I.GT.0)THEN K=(BUFIN(I)*(-1.0E-22)+0.001) NN=NINT(BUFIN(I)*(-1.0E-20))-K*100 ELSE CONTLI=1 GOTO27064 END IF END IF GOTO27063 27064 CONTINUE 27065 CONTINUE CALLAA09(CHRIN,NC,CR65,1,1,1,4,LIM) IF(LIM.GT.0)THEN NC=NC+1 END IF IF(LIM.EQ.4)THEN SPANP=1 END IF CALLAA09(CHRIN,NC,CR64,1,3,4,NCR64,KEY) IF(KEY.GT.0)THEN IF(KEY.EQ.1)THEN REFSKF=0 ELSE IF(KEY.EQ.2)THEN REFUOV=0 ELSE IF(KEY.EQ.3)THEN REFEXT=0 ELSE IF(KEY.EQ.4)THEN DSPFLG=1 END IF NC=NC+3 L=IL ELSE 27067 CONTINUE CALLAA09(CHRIN,NC,CR62,1,3,3,NCR62,PAR) IF(PAR.GT.0)THEN NC=NC+2 ELSE CALLAA09(CHRIN,NC,CR62,1,1,3,12,PAR) IF(PAR.GT.0)THEN CALLAA09(CHRIN,NC+1,CR65,1,1,1,5,K) IF(K.EQ.0)THEN PAR=0 END IF END IF END IF IF(L+2.GT.QXCUR)THEN IQXY=MAX(L+2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27069IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27069 CONTINUE QXCUR=IQXY END IF L=L+2 QX(L-1)=0. IF(SPANP.EQ.0)THEN QX(L)=FLOAT(PAR) ELSE QX(L)=-FLOAT(PAR) END IF IF(PAR.EQ.0)THEN GOTO27068 END IF IF(LINID.EQ.3)THEN BLKTYP=3 END IF NC=NC+1 CALLAA09(CHRIN,NC,CR65,1,1,1,4,LIM) IF(LIM.GT.0)THEN NC=NC+1 END IF IF(LIM.LE.2)THEN GOTO27068 END IF IF(LIM.EQ.4)THEN SPANP=1 END IF NP=NP+1 GOTO27067 27068 CONTINUE END IF IF(NC.GE.NN)THEN QX(IL+1)=FLOAT(NP) GOTO27066 END IF LL=L L=L-2*NP CALLAA09(CHRIN,NC,CR65,1,1,1,1,LIM) IF(LIM.EQ.1)THEN NC=NC+1 END IF 27071 CONTINUE LIM=0 J=NC 27073 IF((LIM.EQ.0).AND.(J.LE.NN))THEN CALLAA09(CHRIN,J,CR65,1,1,1,5,LIM) J=J+1 GOTO27073 END IF IF(CHRIP(NC:NC).EQ.'=')THEN NAME2=CHRIP(NC+1:NC+8) K=10 ELSE K=J-NC-1 NAME2=CHRIP(NC:NC+K-1) END IF IF(SPANA.EQ.0)THEN IAT=1 L5=MARK5+7 END IF 27076 IF(IAT.LE.NAT)THEN CALLAA57(QX(L5-6),1,NAME1,1,24,0) IF(NAME1.EQ.NAME2)THEN GOTO27077 END IF IAT=IAT+1 L5=NINT(QX(L5)) GOTO27076 27077 CONTINUE END IF IF(IAT.GT.NAT)THEN CALLAA05(NAME2,III1,III2,CH,ATTYP) IF(III1.NE.III2.OR.ATTYP.EQ.0)THEN CALLAA06('CR0603',0) END IF IAT=ATTYP IF(DSPFLG.EQ.1)THEN L2=MARK2+(ATTYP-1)*NSTEP2 QX(L2+3)=0. L2=L2+NSTEP2+3 DO27078LL2=L2,MARK3,NSTEP2 QX(LL2)=QX(LL2)-1. 27078 CONTINUE L=L+2 NC=NC+K+1 GOTO27072 END IF END IF IF(SPANA.EQ.0)THEN IAT1=IAT END IF IF(LIM.EQ.4)THEN SPANA=1 ELSE SPANA=0 END IF IF(SPANA.EQ.0)THEN M=NP*(IAT-IAT1+1) IF(L+2*M.GT.QXCUR)THEN IQXY=MAX(L+2*M,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0620',0) END IF DO27080IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27080 CONTINUE QXCUR=IQXY END IF JUNK=L+2*M QX(IL+1)=QX(IL+1)+FLOAT(M) DO27082II=IAT1,IAT DO27084J=1,NP IF(ATTYP.EQ.0)THEN QX(L+1)=FLOAT(II) ELSE QX(L+1)=-FLOAT(II) END IF QX(LL+2)=QX(L+2) L=L+2 LL=LL+2 27084 CONTINUE 27082 CONTINUE END IF NC=NC+K+1 IF(NC.GE.NN)THEN GOTO27072 END IF IF(LIM.LE.2)THEN GOTO27072 END IF GOTO27071 27072 CONTINUE NP=1 IF(NC.GE.NN)THEN GOTO27066 END IF GOTO27065 27066 CONTINUE I=I+1 GOTO27058 27060 CONTINUE END IF CALLAA01(CR61,NCR61) GOTO27056 27057 CONTINUE IF(LINLAS.LE.2)THEN MARK9=L END IF MARK10=L IF(QUITF(1:1).NE.' ')THEN CALLAA06('CR0605',0) END IF RETURN END C-------CR08 SUBROUTINECR08 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERATTYP INTEGERBLKMOD INTEGEREULPT INTEGERFLAG INTEGERFLAG2 INTEGERGROUP INTEGERI,II,I6,I7,I8,J,JUNK,K7 INTEGERIAT INTEGERIBL,IBLK INTEGERLL,L2,L5,L7,L10,L11,L12 INTEGERM,M1,M2 INTEGERMARKAA INTEGERMARK8A INTEGERMODE INTEGERN,N10 INTEGERNGRP INTEGERNEWBLK INTEGERNRFMOD INTEGERNTMP INTEGERPAR,PARTOT INTEGERPAREUL INTEGERSTOP10,STOP12 INTEGERSUBPAR INTEGERVAR INTEGERVARBLK INTEGER PART INTEGER GRP INTEGER L8 INTEGER I12 INTEGER N1 INTEGER N2 DATAPART/0/ DATAGRP/1/ DATAL8/0/ DATAI12/0/ DATAN1/0/ DATAN2/0/ IF(REFSKF.GT.1)THEN REFSKF=(MARK4-MARK3)/2 END IF IF((BLKTYP.EQ.1).AND.(REFUOV.LT.0))THEN REFUOV=0 ELSE IF((BLKTYP.NE.1).AND.(REFUOV.LT.0).AND.(REFSKF.EQ.0))THEN REFUOV=0 END IF VARGEN=REFSKF+IABS(REFUOV) IF(REFABS.EQ.2)THEN VARGEN=VARGEN+1 END IF IF(REFDSP.EQ.2)THEN LL=MARK3-1 DO27000L2=MARK2,LL,NSTEP2 IF(QX(L2+3).GT.0)THEN VARGEN=VARGEN+2 END IF 27000 CONTINUE END IF IF(REFEXT.EQ.2)THEN IF(EXTTYP.LE.2)THEN VARGEN=VARGEN+1 ELSE IF(EXTTYP.EQ.3)THEN VARGEN=VARGEN+2 ELSE IF(EXTTYP.LE.5)THEN VARGEN=VARGEN+6 ELSE IF(EXTTYP.EQ.6)THEN VARGEN=VARGEN+12 END IF END IF NONATM=VARGEN VARBLK=VARGEN VARTOT=VARGEN IF(BLKTYP.EQ.0)THEN N10=3+2*NAT ELSE IF(BLKTYP.EQ.1)THEN N10=3 ELSE N10=20*NAT END IF IF(MARK10+N10.GT.QXCUR)THEN IQXY=MAX(MARK10+N10,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27002IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27002 CONTINUE QXCUR=IQXY END IF MARK11=MARK10+N10 IF(BLKTYP.LT.3)THEN MARKAA=MARK11 ELSE IF(MARK11+N10/2.GT.QXCUR)THEN IQXY=MAX(MARK11+N10/2,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27004IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27004 CONTINUE QXCUR=IQXY END IF MARKAA=MARK11+N10/2 END IF IF(MARKAA+3*NAT.GT.QXCUR)THEN IQXY=MAX(MARKAA+3*NAT,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27006IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27006 CONTINUE QXCUR=IQXY END IF MARK12=MARKAA+3*NAT L10=MARK10+1 L11=MARK11 L12=MARK12 QX(L10)=0. STOP10=MARK10 MARK8A=MARK14 GROUP=0 I8=MARK8A L8=I8 27008 IF(L8.LT.MARK9)THEN N1=INT(QX(L8+1)) N2=INT(QX(L8+2)) L8=L8+2 DO27010N=2,N1 L8=L8+N2 IAT=INT(QX(L8+1)) PAR=INT(QX(L8+2)) M=1 CALLCR09(M,IAT,PAR,MARK8A,FLAG) IF(FLAG.GT.0)THEN QX(I8+5)=QX(I8+5)+QX(FLAG+5) QX(L8+1)=QX(FLAG+6) QX(L8+2)=QX(FLAG+7) QX(L8+3)=QX(L8+3)*QX(FLAG+8) END IF 27010 CONTINUE I8=I8+2+N1*N2 L8=I8 GOTO27008 END IF IAT=0 PART=3+REFPOP NRFMOD=3 BLKMOD=4 IF(MARK6.NE.MARK7)THEN I6=MARK6 NGRP=NINT(QX(I6+1)) END IF L5=MARK5+7 27012 IF(L5.LT.MARK6)THEN IAT=IAT+1 CALLAA74(QX(L5+1),ATTYP,0,5) CALLCR09(NRFMOD,-ATTYP,0,MARK8A,FLAG) IF(FLAG.EQ.0)THEN CALLCR09(NRFMOD,IAT,0,MARK8A,FLAG) END IF IF(FLAG.GT.0)THEN IF(L12+1.GT.QXCUR)THEN IQXY=MAX(L12+1,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27015IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27015 CONTINUE QXCUR=IQXY END IF L12=L12+1 QX(L12)=-FLOAT(L5) VAR=0 DO27017I=1,3 POLSPG(I)=0 27017 CONTINUE IF(NINT(QX(L5)).GE.MARK6)THEN GOTO999 END IF GOTO27013 END IF PAR=0 VAR=0 CALLAA74(QX(L5+1),NTMP,5,3) PARTOT=PART+NTMP DO27019I=1,PARTOT PAR=PAR+1 SUBPAR=0 IF((I.EQ.4).AND.(NTMP.EQ.6))THEN PAR=5 END IF IF((I.EQ.PARTOT).AND.(REFPOP.GT.0))THEN PAR=11 END IF CALLCR09(NRFMOD,0,PAR,MARK8A,FLAG) IF(FLAG.EQ.0)THEN CALLCR09(NRFMOD,-ATTYP,PAR,MARK8A,FLAG) END IF IF(FLAG.EQ.0)THEN CALLCR09(NRFMOD,IAT,PAR,MARK8A,FLAG) END IF IF(FLAG.GT.0)THEN IF(L12+1.GT.QXCUR)THEN IQXY=MAX(L12+1,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27021IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27021 CONTINUE QXCUR=IQXY END IF L12=L12+1 QX(L12)=-FLOAT(L5+I+1) IF(PAR.LT.4)THEN POLSPG(PAR)=0 END IF GOTO27019 END IF M=1 IF(GROUP.EQ.0)THEN CALLCR09(M,IAT,PAR,MARK8,FLAG) ELSE CALLCR09(M,IAT,PAR,L8+N2,FLAG) END IF IF(FLAG.EQ.0)THEN VAR=VAR+1 ELSE L8=FLAG I12=L12 N1=NINT(QX(L8+1)) N2=NINT(QX(L8+2)) IF(L12+2+2*N1.GT.QXCUR)THEN IQXY=MAX(L12+2+2*N1,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR0820',0) END IF DO27023IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27023 CONTINUE QXCUR=IQXY END IF JUNK=L12+2+2*N1 QX(I12+1)=FLOAT(L5+I+1) IF(NINT(QX(L8+6)).LE.MARK6)THEN QX(I12+2)=QX(L8+7)+1. ELSE GROUP=1 QX(I12+2)=0. END IF QX(I12+3)=FLOAT(2+2*N1) QX(I12+4)=2. L8=L8+2 L12=I12+2 DO27025N=2,N1 L8=L8+N2 L12=L12+2 IF(GROUP.EQ.1)THEN IF(NINT(QX(L8+1)).LE.MARK6.AND.QX(L8+2).GT.0.)THEN QX(L12+1)=QX(L8+1) QX(L12+2)=QX(L8+3) GOTO27025 END IF EULPT=NINT(QX(L8+1)) PAREUL=NINT(QX(L8+2)) IF(EULPT.LT.MARK12)THEN IF(PAREUL.GT.0)THEN M=1 IF((PAREUL.GT.3).AND.(PAR.LT.4))THEN FLAG2=0 ELSE CALLCR09(M,IAT,PAR,MARK8A,FLAG2) END IF IF(FLAG2.EQ.0)THEN VAR=VAR+1 QX(EULPT)=FLOAT(VARTOT+VAR) QX(I12+2)=QX(I12+2)+1. QX(L12+1)=FLOAT(VARTOT+VAR) QX(L12+2)=QX(L8+3) ELSE QX(EULPT)=0. QX(I12+2)=0. M1=NINT(QX(FLAG2+1)) M2=NINT(QX(FLAG2+2)) QX(I12+3)=FLOAT(2+2*M1) FLAG2=FLAG2+2 L12=I12+2 DO27027II=2,M1 FLAG2=FLAG2+M2 L12=L12+2 QX(L12+1)=QX(FLAG2+1) QX(L12+2)=QX(FLAG2+3) 27027 CONTINUE END IF QX(FLAG+5)=-9999. M=MARK8 27029 CONTINUE MODE=2 CALLCR09(MODE,EULPT,0,M,FLAG2) IF(FLAG2.EQ.0)THEN GOTO27030 END IF IF(QX(EULPT).GT.0)THEN QX(MODE+1)=QX(EULPT) ELSE QX(MODE+1)=FLOAT(I12) END IF QX(MODE+2)=-1. IF(PAR.LT.4)THEN QX(FLAG2+5)=-9999. ELSE M=L5+1+I QX(FLAG2+5)=QX(M) END IF M=FLAG2+2+NINT(QX(FLAG2+1)*QX(FLAG2+2)) GOTO27029 27030 CONTINUE ELSE QX(L12+1)=QX(L8+1) QX(L12+2)=QX(L8+3) END IF ELSE M=NINT(QX(EULPT+3)) CALLAA51(QX,EULPT+2,QX,I12+2,(M-1),0) L12=I12+M-2 GOTO27026 END IF ELSE QX(L12+1)=QX(L8+1) QX(L12+2)=QX(L8+3) END IF 27025 CONTINUE 27026 CONTINUE IF(QX(FLAG+5).GT.-9999.)THEN M=L5+1+I QX(M)=QX(FLAG+5) END IF L12=L12+2 SUBPAR=1 END IF IF(SUBPAR.EQ.0.OR.GROUP.EQ.1)THEN M=MARK8A 27031 CONTINUE MODE=2 CALLCR09(MODE,IAT,PAR,M,FLAG2) IF(FLAG2.EQ.0)THEN GOTO27032 END IF QX(MODE+1)=FLOAT(VARTOT+VAR) QX(MODE+2)=-2. IF(QX(FLAG2+5).GT.-9999.)THEN M=L5+1+I QX(FLAG2+5)=QX(FLAG2+5)+QX(MODE+3)*QX(M) END IF M=FLAG2+2+NINT(QX(FLAG2+1)*QX(FLAG2+2)) GOTO27031 27032 CONTINUE END IF IF(PAR.LT.4)THEN IF(POLSPG(PAR).GT.0)THEN IF(NINT(QX(L5)).LT.MARK6)THEN IF(SUBPAR.EQ.1)THEN POLSPG(PAR)=0 ELSE M=MARKAA+(PAR-1)*NAT+IAT QX(M)=FLOAT(VARTOT+VAR) END IF ELSE VAR=VAR-1 QX(L12+1)=FLOAT(L5+I+1) QX(L12+2)=-1. QX(L12+3)=FLOAT(NAT+3) QX(L12+4)=1. M=MARKAA+(PAR-1)*NAT+1 CALLAA51(QX,M,QX,L12+5,(NAT-1),0) L12=L12+NAT+3 END IF END IF END IF IF(BLKTYP.EQ.3)THEN CALLCR09(BLKMOD,IAT,PAR,MARK9,FLAG) IF(FLAG.LT.MARK9)THEN L10=MARK10+3+FLAG*2 STOP10=MAX0(STOP10,L10) END IF QX(L10)=QX(L10)+1. END IF I7=MARK7 27033 IF(I7.LT.MARK8)THEN IF(PAR.GT.3.OR.SUBPAR.EQ.1)THEN GOTO27035 END IF N=NINT(QX(I7+2)) K7=I7+2 L7=I7+1+2*N DO27036J=1,N K7=K7+2 L7=L7+3 IF(L5.NE.NINT(QX(K7+1)))THEN GOTO27036 END IF QX(L7+PAR)=FLOAT(VARTOT+VAR) GOTO27037 27036 CONTINUE 27037 CONTINUE I7=I7+4+5*N GOTO27033 27035 CONTINUE END IF 27019 CONTINUE 999 CONTINUE NEWBLK=0 IF((BLKTYP.EQ.0).AND.(GRP.LE.1))THEN NEWBLK=1 ELSE IF(BLKTYP.EQ.2)THEN CALLCR09(BLKMOD,IAT,0,MARK9,FLAG) IF(FLAG.GT.0)THEN NEWBLK=1 END IF END IF DO27038M=1,2 IF((NEWBLK.EQ.1).AND.(VARBLK.GT.0))THEN IF(VARBLK.EQ.NINT(QX(L10)))THEN QX(L10-1)=QX(L10-1)+1 ELSE QX(L10+1)=1. QX(L10+2)=FLOAT(VARBLK) L10=L10+2 END IF QX(MARK10+1)=QX(MARK10+1)+1. VARBLK=0 END IF IF(M.EQ.2)THEN GOTO27039 END IF VARBLK=VARBLK+VAR VARTOT=VARTOT+VAR IF(NINT(QX(L5)).LT.MARK6)THEN GOTO27039 END IF IF(BLKTYP.LT.3)THEN NEWBLK=1 END IF 27038 CONTINUE 27039 CONTINUE IF(GROUP.EQ.1)THEN IF(GRP.LT.NGRP)THEN GRP=GRP+1 ELSE GROUP=0 GRP=1 I6=I6+ISTEP6+NSTEP6*NGRP NGRP=NINT(QX(I6+1)) END IF END IF 27013 CONTINUE L5=NINT(QX(L5)) GOTO27012 END IF IF(BLKTYP.LE.2)THEN STOP10=L10 END IF STOP12=L12 IF(BLKTYP.EQ.3)THEN IAT=0 VAR=VARGEN QX(MARK10+3)=FLOAT(VARGEN) L5=MARK5+7 27040 IF(L5.LT.MARK6)THEN IAT=IAT+1 PAR=0 DO27043I=1,PARTOT PAR=PAR+1 IF((I.EQ.4).AND.(NTMP.EQ.6))THEN PAR=5 END IF IF((I.EQ.PARTOT).AND.(REFPOP.GT.0))THEN PAR=11 END IF CALLCR09(BLKMOD,IAT,PAR,MARK9,FLAG) IF(FLAG.LT.MARK9)THEN L10=MARK10-1 VAR=0 IBLK=FLAG DO27045IBL=1,IBLK L10=L10+2 VAR=VAR+NINT(QX(L10+2)) 27045 CONTINUE L10=L10+2 VAR=VAR+NINT(QX(L10+1))+1 L11=L11+1 QX(L11)=FLOAT(VAR) ELSE IF(BLKMOD.GT.0)THEN L11=L11+1 QX(L11)=-FLOAT(L5+I+1) END IF QX(L10+1)=QX(L10+1)+1. 27043 CONTINUE L5=NINT(QX(L5)) GOTO27040 END IF L10=MARK10+2 27047 IF(L10.LT.STOP10)THEN QX(L10)=1. L10=L10+2 GOTO27047 END IF QX(MARK10+1)=FLOAT((STOP10-MARK10-1)/2) END IF N=STOP10-MARK10 CALLAA51(QX,MARK10+1,QX,MARK8+1,N,1) MARK9=MARK8+N N=L11-MARK11 CALLAA51(QX,MARK11+1,QX,MARK9+1,N,1) MARK10=MARK9+N N=STOP12-MARK12 CALLAA51(QX,MARK12+1,QX,MARK10+1,N,1) MARK11=MARK10+N+1 QX(MARK11)=FLOAT(MARK6+6+1) RETURN END C-------CR09 SUBROUTINECR09(MODE,IAT,PAR,MARK,FLAG) INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERFLAG INTEGERIAT INTEGERIL INTEGERL INTEGERLAST INTEGERMARK INTEGERMODE INTEGERN,N1,N2,N3 INTEGERNBLK INTEGERPAR INTEGERST INTEGERSTEP IF(MODE.GT.0)THEN L=MARK FLAG=0 IF(MODE.LE.3)THEN LAST=MARK9 ELSE LAST=MARK10 END IF IF(MODE.LE.2)THEN ST=3 ELSE ST=2 END IF NBLK=0 27000 IF(L.LT.LAST)THEN NBLK=NBLK+1 N1=1 N2=NINT(QX(L+1)) STEP=NINT(QX(L+2)) IF(STEP.NE.ST)THEN L=L+N2*STEP+2 GOTO27000 END IF IL=L L=L+2 IF(MODE.EQ.1)THEN STEP=N2*STEP N2=1 ELSE IF(MODE.EQ.2)THEN N1=2 L=L+STEP END IF N=N1 27002 IF(N.LE.N2)THEN N3=NINT(QX(L+2)) IF((NINT(QX(L+1)).EQ.IAT).AND.(N3.EQ.PAR))THEN GOTO27004 END IF L=L+STEP N=N+1 GOTO27002 27004 CONTINUE END IF IF(N.GT.N2)THEN GOTO27000 END IF FLAG=IL IF(MODE.EQ.2)THEN MODE=L ELSE IF(MODE.GT.2)THEN IF(MODE.EQ.4)THEN FLAG=NBLK END IF L=L+STEP IF(QX(L+2).LT.0.)THEN MODE=-L END IF END IF L=LAST GOTO27000 END IF ELSE L=-MODE FLAG=MARK IF(NINT(QX(L+1)).EQ.IAT)THEN IF(PAR.EQ.0)THEN FLAG=0 ELSE IF(NINT(QX(L+2)).EQ.-PAR)THEN IF(L.LT.MARK9)THEN MODE=3 ELSE MODE=4 END IF END IF ELSE IF((IAT.LE.0).OR.(QX(L+1).LE.0.))THEN FLAG=0 END IF END IF RETURN END C-------CR10 SUBROUTINECR10 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(120 )CH INTEGERATTYP INTEGERI,J,K,M,N INTEGERI1,I2,I6,I7 INTEGERI6FRST INTEGERIGR INTEGERJK,JL,JN INTEGERL1,L2,L3,L5,L6,L7 INTEGERLCON INTEGERNATM INTEGERNATGR INTEGERNCH INTEGERNCHP INTEGERNTMP INTEGERPAR INTEGERPARTOT INTEGERPCON INTEGERVAR INTEGERNCR101 CHARACTER*69 CR101 INTEGERNCR102 CHARACTER*25 CR102 INTEGERNCR103 CHARACTER*15 CR103 INTEGERNCR104 CHARACTER*41 CR104 INTEGERNCR105 CHARACTER*108 CR105 INTEGERNCR106 CHARACTER*76 CR106 INTEGERNCR107 CHARACTER*18 CR107 INTEGERNCR108 CHARACTER*29 CR108 INTEGERNCR109 CHARACTER*74 CR109 REAL FMT1(10 ) REAL FMT(16 ) REAL RAD INTEGER L6FRST DATANCR101/69 /, CR101/' INITIAL PARAMETERS (I=INVARIANT C=CONSTRA &INED G=GROUP R=RESTRAINED )'/ DATANCR102/25 /, CR102/' ***GENERAL PARAMETERS***'/ DATANCR103/15 /, CR103/' ***GROUP ***'/ DATANCR104/41 /, CR104/' ***INDIVIDUAL ATOM PARAMETERS*** (U*100)' &/ DATANCR105/108/, CR105/' -SCALE FACTOR(S) 100*U(OVERALL) ABS.S &TRUCT.PARAM.EXT(G/10000)DISPERSION - ZACH TYP1 TYP2 GEN GAUS LOR &'/ DATANCR106/76 /, CR106/' ORTHOGONAL COORDS - CRYST. AXES & ORTHOGONAL COORDS - EULER AXES'/ DATANCR107/18 /, CR107/' CENTER OF GRAVITY'/ DATANCR108/29 /, CR108/' EULER ANGLES (PHI THETA PSI)'/ DATANCR109/74 /, CR109/' X Y Z U11 U22 & U33 U12 U13 U23'/ DATAFMT1/942.,942.,942.,942.,942.,942.,942.,942.,942.,722./ DATAFMT/160742.,250742.,340742.,430742.,520742.,610742.,700742.,79 &0742.,880742.,970742.,340741.,430741.,520741.,610741.,700741.,7907 &41./ DATARAD/57.29578/ DATAL6FRST/0/ LINRM=8 CALLAA55(CR105,2,CHROT,2,19,1) CALLAA04(1,CR101,NCR101,1,3) CALLAA04(1,CR102,NCR102,3,1) CALLAA04(0,' ',0,3,1) CALLAA55(CR105,3,CHROT,2,15,0) I=0 L3=MARK3 27000 IF(L3.LT.MARK4)THEN I=I+1 CALLAA03(QX(L3+1),1,CHROT,FMT(I+2),1) IF(REFSKF.EQ.0)THEN M=NINT(FMT(I+2))/10000+1 CHROT(M:M)='I' END IF IF(I.LT.6.AND.L3.LT.MARK4-2)THEN GOTO27001 END IF CALLAA04(0,' ',0,1,3) I=0 27001 CONTINUE L3=L3+2 GOTO27000 END IF CALLAA55(CR105,19,CHROT,2,18,0) BUFOT(1)=BTOHU*QX(MARK4+1) CALLAA03(BUFOT,1,CHROT,FMT(3),1) IF(REFUOV.EQ.0)THEN CHROT(35:35)='I' END IF CALLAA04(0,' ',0,1,1) IF(REFEXT.GT.0)THEN CALLAA55(CR105,55,CHROT,2,12,0) JL=80+EXTTYP*5 CALLAA55(CR105,JL,CHROT,15,4,0) JL=100+DSTEXT*5 CALLAA55(CR105,JL,CHROT,21,4,0) IF(EXTTYP.LT.3)THEN N=1 ELSE IF(EXTTYP.EQ.3)THEN N=2 ELSE IF(EXTTYP.LT.6)THEN N=6 ELSE N=12 END IF IF(EXTTYP.LE.1.OR.EXTTYP.EQ.3)THEN JN=MARK4+2 ELSE IF(EXTTYP.EQ.2)THEN JN=MARK4+3 ELSE IF(EXTTYP.EQ.5)THEN JN=MARK4+10 ELSE JN=MARK4+4 END IF JK=35 DO27003I=1,N BUFOT(I)=QX(JN) IF(REFEXT.EQ.1)THEN CHROT(JK:JK)='I' END IF JK=JK+9 JN=JN+1 27003 CONTINUE CALLAA03(BUFOT,1,CHROT,FMT(11),N) CALLAA04(0,' ',0,1,1) END IF IF(REFABS.GT.0)THEN CALLAA55(CR105,38,CHROT,2,17,0) IF(REFABS.EQ.1)THEN CHROT(35:35)='I' END IF CALLAA03(XABS,1,CHROT,FMT(3),1) CALLAA04(0,' ',0,1,1) END IF IF(REFDSP.GT.0)THEN CALLAA55(CR105,67,CHROT,2,10,0) L2=MARK2-NSTEP2 K=-7 DO27005I=1,NATTYP K=K+8 L2=L2+NSTEP2 IF((ABS(QX(L2+1)).LT.5.0E-7).AND.(ABS(QX(L2+2)).LT.5.0E-7))THEN GOTO27005 END IF CALLAA57(QX(MARK1+1),K,CHROT,18,8,0) CALLAA03(QX(L2+1),1,CHROT,FMT(3),2) IF(ABS((QX(L2+3))-(0.)).LE.5.0E-7)THEN CHROT(35:35)='I' CHROT(44:44)='I' END IF CALLAA04(0,' ',0,1,1) 27005 CONTINUE END IF I6=MARK6 IGR=0 27007 IF(I6.LT.MARK7)THEN IGR=IGR+1 BUFOT(1)=FLOAT(IGR) LINRM=12 CALLAA03(BUFOT,1,CR103,120213.,1) CALLAA04(1,CR103,NCR103,3,3) IF(QX(I6+2).LT.1.5)THEN NATGR=NINT(QX(I6+1)) ELSE I6FRST=NINT(QX(I6+1)) NATGR=NINT(QX(I6FRST+1)) L6FRST=I6FRST+ISTEP6-NSTEP6 END IF I1=I6+2 DO27009I=1,2 DO27011J=1,3 I1=I1+1 BUFOT(J)=QX(I1) VAR=NINT(QX(I1+6)) 27011 CONTINUE IF(I.EQ.1)THEN CALLAA55(CR107,1,CHROT,1,NCR107,0) ELSE IF(ABS((QX(I6+2))-(1.)).GT.5.0E-7)THEN CALLAA55(CR108,1,CHROT,1,NCR108,0) DO27013J=1,3 BUFOT(J)=BUFOT(J)*RAD 27013 CONTINUE ELSE GOTO27010 END IF CALLAA03(BUFOT,1,CHROT,FMT(5),3) CALLAA04(1,' ',0,1,3) 27009 CONTINUE 27010 CONTINUE L6=I6+ISTEP6-NSTEP6 CALLAA04(0,' ',0,1,3) LINRM=5 DO27015I=1,NATGR I2=I6+18 L6=L6+NSTEP6 IF(QX(I6+2).GT.1.5)THEN L6FRST=L6FRST+NSTEP6 END IF L5=NINT(QX(L6+1)) CALLAA57(QX(L5-6),1,CHROT,2,24,0) LCHROT=LABMAX+4 CALLAA03(QX(L6+3),1,CHROT,FMT1,3) DO27017J=1,3 I2=I2+3 BUFOT(J)=QX(I2+1)*QX(L6+3)+QX(I2+2)*QX(L6+4)+QX(I2+3)*QX(L6+5) IF(ABS((QX(I6+2))-(0.)).LE.5.0E-7)THEN IF(QX(I6+2).LT.1.5)THEN CALLAA51(BUFOT,1,QX(L6+6),1,3,0) END IF END IF CALLAA03(BUFOT,1,CHROT,FMT1,3) 27017 CONTINUE CALLAA04(0,CR106,NCR106,1,3) 27015 CONTINUE I6=L6+NSTEP6 GOTO27007 END IF LINRM=6 CALLAA04(1,CR104,NCR104,3,1) CALLAA04(0,' ',0,3,1) CH=' ' CALLAA55(CR109,1,CH,LABMAX+11,20,0) NCH=LABMAX+31 PARTOT=3 IF(REFTMP.GE.4)THEN CALLAA55(CR109,21,CH,NCH,54,0) NCH=NCH+54 PARTOT=9 ELSE IF(REFTMP.GT.0)THEN CH(NCH+8:)='U' NCH=NCH+8 PARTOT=4 END IF IF(POP.GT.0)THEN CH(NCH+5:)='POP' NCHP=NCH NCH=NCH+9 END IF L5=MARK5+7 LCON=MARK10 LCON=LCON+0 PCON=NINT(QX(LCON+1)) 27019 IF(L5.LT.MARK6)THEN CALLAA57(QX(L5-6),1,CHROT,2,24,0) CALLAA74(QX(L5+1),ATTYP,0,5) CALLAA74(QX(L5+1),NTMP,5,3) PARTOT=3+NTMP CALLAA51(QX(L5+2),1,BUFOT,1,PARTOT,0) IF(NTMP.EQ.1)THEN BUFOT(4)=BTOHU*BUFOT(4) ELSE IF(NTMP.EQ.6)THEN DO27021I=1,6 BUFOT(I+3)=CELL(I+6)*BUFOT(I+3) 27021 CONTINUE END IF LCHROT=LABMAX+3 CALLAA03(BUFOT,1,CHROT,FMT1,PARTOT) IF(POP.GT.0)THEN LCHROT=NCHP M=L5+5+NTMP CALLAA03(QX(M),1,CHROT,942.,1) END IF 27023 CONTINUE IF(IABS(PCON).GE.NINT(QX(L5)))THEN GOTO27024 END IF PAR=IABS(PCON)-L5-1 L1=PAR L2=PAR IF(PCON.LT.0)THEN N=22 IF(IABS(PCON).EQ.L5)THEN L1=1 L2=PARTOT+POP END IF LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE IF(QX(LCON+2).LT.0.)THEN N=34 ELSE N=48 END IF LCON=LCON+NINT(QX(LCON+3)) PCON=NINT(QX(LCON+1)) END IF DO27025I=L1,L2 M=LABMAX+4+I*9 IF(I.LE.PARTOT)THEN CHROT(M:M)=CR101(N:N) ELSE CHROT(NCH+1:)=CR101(N:N) END IF 27025 CONTINUE GOTO27023 27024 CONTINUE IF(POP.EQ.1.AND.REFPOP.EQ.0)THEN CHROT(NCH+1:)='I' END IF I7=MARK7 27027 IF(I7.LT.MARK8)THEN NATM=NINT(QX(I7+2)) L7=I7+2 DO27030I=1,NATM L7=L7+2 IF(NINT(QX(L7+1)).EQ.L5)THEN L1=I7+4+2*NATM+(I-1)*3 DO27032J=1,3 IF(QX(L1+J).GT.0.)THEN M=LABMAX+4+I*9 CALLAA55(CR101,56,CHROT,M,1,0) END IF 27032 CONTINUE GOTO100 END IF 27030 CONTINUE I7=I7+4+5*NATM GOTO27027 END IF 100 CONTINUE CALLAA04(0,CH,NCH,1,3) L5=NINT(QX(L5)) GOTO27019 END IF RETURN END C-------CR20 SUBROUTINECR20 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALAR(36) REALCOSPHI REALCOSPSI REALCOSTHE INTEGEREULPT INTEGERI,I3,J,J1,JUNK,L,L1,M,N,NN INTEGERIATGR INTEGERI1,I2,I6,I6FRST INTEGERIP INTEGERIWANT(98) INTEGERL5,L6,L6FRST,L8,L10 INTEGERNATGR INTEGERPACK INTEGERPAR INTEGERPCON REALPHI REALPSI REALR(9) REALSINPHI REALSINPSI REALSINTHE REALTHETA INTEGERVAR INTEGERNCR20E CHARACTER*76 CR20E REAL FMT(6 ) DATANCR20E/76 /, CR20E/'MemMax=NNNNNNN MemReq=NNNNNNN (Mtx=NNNNNNN & Vec=NNNNNN Der=NNNNNN Sym=NNNNNN)'/ DATAFMT/140713.,290713.,420713.,530613.,640613.,750613./ IF((ICYCLE.EQ.1).OR.(ICYCLE.EQ.NCYCLE))THEN M=1000*DATSET IWANT(1)=1 IWANT(2)=2 IWANT(3)=3 IWANT(4)=M+304-2*RFLTYP IWANT(5)=IWANT(4)+1 IF(RFLTYP.EQ.3)THEN IWANT(4)=800 END IF IWANT(6)=IWANT(4)+10 IWANT(7)=IWANT(5)+10 IWANT(8)=M+897+IWT IWANT(9)=M+204 IWANT(10)=M+308 IWANT(11)=IWANT(10)+10 IWANT(12)=IWANT(10)+1 IWANT(13)=M+202 IWANT(14)=M+200 IWANT(15)=M+201 DO27000I=1,NATTYP IWANT(I+15)=500+I 27000 CONTINUE NN=18 N=NATTYP+NN+15 IWANT(N+1)=M+800 IWANT(N+10)=-M-810 DO27002I=2,7 IWANT(N+I)=-M-800-I+1 IWANT(N+I+9)=-M-810-I+1 27002 CONTINUE IWANT(N+8)=-M-701 IWANT(N+9)=M+700 DO27004I=1,2 IF(ICENT.EQ.1)THEN IWANT(N+2)=+M+801 IWANT(N+3)=+M+802 END IF IF(REFDSP.GT.0.OR.REFEXT.GT.0)THEN IWANT(N+4)=+M+803 IWANT(N+5)=+M+804 IWANT(N+6)=+M+805 IWANT(N+7)=+M+806 IF(I.EQ.2)THEN GOTO27005 END IF IWANT(N+8)=+M+701 END IF IF(PARTL.EQ.0)THEN GOTO27005 END IF M=M+10 N=N+9 IWANT(N+1)=+M+800 27004 CONTINUE 27005 CONTINUE IWANT(N+17)=IWANT(13) IWANT(N+18)=M+820 DO27006I=1,NN IWANT(N+I-NN)=IWANT(N+I) 27006 CONTINUE SIGNAL(1)=4 IF(ICYCLE.EQ.1)THEN SIGNAL(2)=NATTYP+15 SIGNAL(3)=N SIGNAL(4)=0 ELSE SIGNAL(2)=N SIGNAL(3)=N+NN SIGNAL(4)=1 END IF IF(ICYCLE.LT.NCYCLE)THEN M=0 ELSE M=2 END IF CALLAA15(1,20,PACK,IP,M,SIGNAL,IWANT,REL) IF(SIGNAL(4).LT.0)THEN CALLAA06('CR2001',0) END IF IF(IWT.EQ.2)THEN REL(8)=REL(5) END IF IF(ICYCLE.EQ.1)THEN IF(IP.LE.0)THEN CALLAA06('CR2001',0) END IF IF((IWT.EQ.2.OR.TYPELT.GT.0.).AND.REL(5).EQ.0)THEN CALLAA06('CR2002',0) END IF IF((IWT.GT.2).AND.(REL(8).EQ.0))THEN CALLAA06('CR2003',0) END IF IF((RFLTYP.EQ.2).AND.(REL(9).EQ.0))THEN CALLAA06('CR2004',0) END IF IF(PARTL.EQ.1.AND.REL(NATTYP+16).LE.0)THEN CALLAA06('CR2006',0) END IF IF(REFABS.GT.0.AND.REL(6).LE.0)THEN CALLAA06('CR2007',0) END IF IF(ICENT.EQ.0.AND.REFDSP.EQ.0)THEN IMAGP=1 ELSE IF(REFABS.EQ.0)THEN IMAGP=2 ELSE IMAGP=4 END IF N=0 L8=MARK8+2 27008 IF(L8.LT.MARK9)THEN N=N+QX(L8)*QX(L8+1)*(QX(L8+1)+1)/2 L8=L8+2 GOTO27008 END IF MARK12=MARK11+N MARK13=MARK12+VARTOT+2 MARK14=MARK13+IMAGP*VARTOT IF(REFTMP.GT.3)THEN M=10 ELSE M=4 END IF MARK15=MARK14+MAX0(6,(NATTYP+M*NSYM)) IF(MARK15.GT.QXMAX)THEN BUFOT(1)=FLOAT(QXMAX) BUFOT(2)=FLOAT(MARK15) BUFOT(3)=FLOAT(N) BUFOT(4)=FLOAT(VARTOT+2) BUFOT(5)=FLOAT(IMAGP*VARTOT) BUFOT(6)=FLOAT(MARK15-MARK14) CALLAA03(BUFOT,1,CR20E,FMT,6) CALLAA04(2,CR20E,NCR20E,3,3) END IF IF(MARK15.GT.QXCUR)THEN IQXY=MAX(MARK15,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR2020',0) END IF DO27011IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27011 CONTINUE QXCUR=IQXY END IF JUNK=MARK15 END IF END IF N=MARK15-MARK11 CALLAA51(0.,1,QX,MARK11+1,N,2) I6=MARK6 L10=MARK10-1 N=1 27013 IF(I6.LT.MARK7)THEN L6=I6+ISTEP6-NSTEP6 IF(QX(I6+2).LT.1.5)THEN NATGR=NINT(QX(I6+1)) L1=L6+5 ELSE I6FRST=NINT(QX(I6+1)) NATGR=NINT(QX(I6FRST+1)) L6FRST=I6FRST+ISTEP6-NSTEP6 L1=L6FRST+2 END IF IF(ABS((QX(I6+2))-(1.)).LE.5.0E-7)THEN I6=I6+ISTEP6+NATGR*NSTEP6 GOTO27013 END IF PHI=QX(I6+6) THETA=QX(I6+7) PSI=QX(I6+8) COSPHI=COS(PHI) SINPHI=SIN(PHI) COSTHE=COS(THETA) SINTHE=SIN(THETA) COSPSI=COS(PSI) SINPSI=SIN(PSI) L=0 DO27015I=1,3 IF(I.EQ.1)THEN R(1)=-COSPSI*SINPHI-SINPSI*COSTHE*COSPHI R(2)=SINPSI*SINPHI-COSPSI*COSTHE*COSPHI R(3)=SINTHE*COSPHI R(4)=COSPSI*COSPHI-SINPSI*COSTHE*SINPHI R(5)=-SINPSI*COSPHI-COSPSI*COSTHE*SINPHI R(6)=SINTHE*SINPHI R(7)=0. R(8)=0. R(9)=0. ELSE IF(I.EQ.2)THEN R(1)=SINPSI*SINTHE*SINPHI R(2)=COSPSI*SINTHE*SINPHI R(3)=COSTHE*SINPHI R(4)=-SINPSI*SINTHE*COSPHI R(5)=-COSPSI*SINTHE*COSPHI R(6)=-COSTHE*COSPHI R(7)=SINPSI*COSTHE R(8)=COSPSI*COSTHE R(9)=-SINTHE ELSE R(1)=-SINPSI*COSPHI-COSPSI*COSTHE*SINPHI R(2)=-COSPSI*COSPHI+SINPSI*COSTHE*SINPHI R(3)=0. R(4)=-SINPSI*SINPHI+COSPSI*COSTHE*COSPHI R(5)=-COSPSI*SINPHI-SINPSI*COSTHE*COSPHI R(6)=0. R(7)=COSPSI*SINTHE R(8)=-SINPSI*SINTHE R(9)=0. END IF I2=-3 DO27017J=1,3 I1=20 I2=I2+3 DO27019J1=1,3 L=L+1 I1=I1+1 AR(L)=CELL(I1+1)*R(I2+1)+CELL(I1+4)*R(I2+2)+CELL(I1+7)*R(I2+3) 27019 CONTINUE 27017 CONTINUE 27015 CONTINUE IF(QX(I6+2).GT.1.)THEN I2=I6+18 I3=0 DO27021J=1,3 I1=20 I2=I2+3 DO27023J1=1,3 I1=I1+1 I3=I3+1 R(I3)=CELL(I1+1)*QX(I2+1)+CELL(I1+4)*QX(I2+2)+CELL(I1+7)*QX(I2+3) 27023 CONTINUE 27021 CONTINUE I2=9 DO27025J=1,3 I1=-1 I2=I2+3 DO27027J1=1,3 L=L+1 I1=I1+1 AR(L)=R(I1+1)*CELL(I2+1)+R(I1+4)*CELL(I2+2)+R(I1+7)*CELL(I2+3) 27027 CONTINUE 27025 CONTINUE END IF DO27029IATGR=1,NATGR L6=L6+NSTEP6 L5=NINT(QX(L6+1)) L1=L1+NSTEP6 L10=L10+N 27031 IF(L10.LT.MARK11-1)THEN N=1 PCON=NINT(QX(L10+1)) IF(PCON.LT.0)THEN GOTO27032 END IF N=NINT(QX(L10+3)) PAR=PCON-L5-1 IF((PAR.LT.0).OR.(PAR.GT.3))THEN GOTO27032 END IF L=L10+4 EULPT=I6+12 DO27034J=1,3 IF(QX(EULPT).GT.0.)THEN VAR=NINT(QX(EULPT)) 27036 IF(NINT(QX(L+1)).NE.VAR)THEN L=L+2 GOTO27036 END IF I2=(J-1)*9+PAR-1 QX(L+2)=AR(I2+1)*QX(L1+1)+AR(I2+4)*QX(L1+2)+AR(I2+7)*QX(L1+3) L=L+2 END IF EULPT=EULPT+1 27034 CONTINUE IF(L.GT.L10+4.AND.L.LT.L10+N)THEN I2=26+PAR DO27038I=1,9,3 QX(L+2)=AR(I2+I) L=L+2 27038 CONTINUE END IF IF(PAR.GE.3)THEN GOTO27033 END IF 27032 CONTINUE L10=L10+N GOTO27031 27033 CONTINUE END IF 27029 CONTINUE I6=L6+NSTEP6 GOTO27013 END IF RETURN END C-------CR21 SUBROUTINECR21 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALAA(4) REALA,B,C,D REALAH,AK,AL REALADIS,ANTID,AREFD REALBDIS,BNTID,BREFD INTEGERATTYP REALBH,BK,BL INTEGERBUILD REALCA(4) REALCALC REALCOS2P REALDA(4) REALD1,D2 REALDELA(9),DELB(9) REALDELTA REALDERFAC REALDEREXT REALDERSKF REALDERTMP REALDFC REALEFLACK REALEXTCOR REALFA(6) REALFACT REALFACT2 REALFACT1 REALFCAL REALFCT REALFC2 REALFCFR2 REALFCND REALFDEL REALFOBS REALFO2 REALFO2NE REALFOND REALH(3) REALWFRDL INTEGERI,J,K,L,LPP,LPPSV,M,N,P INTEGERIP,IPP INTEGERIFRDL INTEGERISKF INTEGERISKIP INTEGERL0,L2,L3 INTEGERL5,L5P,L5M INTEGERL8,L9,L11,L12,L13,L14 INTEGERL13DSP,L13UOV INTEGERLCON INTEGERLT INTEGERMAXH,MAXK,MAXL INTEGERMAXHKL INTEGERNBLK INTEGERNFRDL INTEGERNTMP INTEGERN1,N2 INTEGERN9 REALOBS INTEGERPACK INTEGERPAR INTEGERPARTOT INTEGERPCON REALPHI REALQ INTEGERRCODE INTEGERREF INTEGERREL1,REL2,REL3,REL4,REL5 INTEGERREL6,REL7,REL8,REL9,REL10,REL11,REL12 REALS REALSIN2P REALSIGMA REALSKF REALSMIN,SMAX INTEGERSTEP13 INTEGERSTOP13 INTEGERSTEP14 INTEGERSTOP14 REALSTOL REALSTOLSQ REALSUMCOS,SUMSIN INTEGERVARBLK REALWEIGHT SAVEDEREXT,DERFAC,DERSKF,DERTMP,PCON INTEGERNCR211 CHARACTER*102 CR211 INTEGERNCR212 CHARACTER*6 CR212 REAL TWOPI REAL FORM(17 ) DATANCR211/102/, CR211/' H K L ST/L RC SG OBS CALC & CALCA CALCB EXTF FONO FCNO PHI DELTA WW*D SIGMA'/ DATANCR212/6 /, CR212/' FF2 I'/ DATATWOPI/6.28318531/ DATAFORM/50413.,90413.,130413.,190642.,210203.,250203.,330822.,410 &822.,490822.,570822.,620422.,700822.,780822.,820413.,890722.,96072 &2.,1020622./ REL1=REL(1) REL2=REL(2) REL3=REL(3) REL4=REL(4) REL5=REL(5) REL6=REL(6) REL7=REL(7) REL8=REL(8) REL9=REL(9) REL10=REL(10) REL11=REL(11) REL12=REL(12) ISKF=NINT(QX(MARK3+2)) SKF=1./QX(MARK3+1) IF(RFLTYP.GT.0)THEN SKF=SKF*SKF END IF WEIGHT=1. SIGMA=.1 RCODE=1 EXTCOR=1. FCFR2=0. NFRDL=1 IF(REFABS.GT.0)THEN NFRDL=2 END IF IF(QX(MARK4+21).LT.0.)THEN MAXHKL=0 ELSE MAXHKL=1 MAXH=NINT(QX(MARK4+16)) MAXK=NINT(QX(MARK4+17)) MAXL=NINT(QX(MARK4+18)) SMIN=QX(MARK4+19) SMAX=QX(MARK4+20) END IF STEP13=VARTOT*IMAGP STOP13=MARK13+VARTOT IF(REFUOV.NE.0)THEN L13UOV=MARK13+REFSKF+1 ELSE L13UOV=0 END IF L13DSP=MARK13+REFSKF+IABS(REFUOV)+1 IF(REFABS.EQ.2)THEN L13DSP=L13DSP+1 END IF IF(REFEXT.EQ.2)THEN IF(EXTTYP.LE.2)THEN L13DSP=L13DSP+1 ELSE IF(EXTTYP.EQ.3)THEN L13DSP=L13DSP+2 ELSE IF(EXTTYP.LE.5)THEN L13DSP=L13DSP+6 ELSE L13DSP=L13DSP+12 END IF END IF IF(RADTYP.EQ.2)THEN L2=MARK2+5 L14=MARK14+1 27000 IF(L14.LE.MARK14+NATTYP)THEN QX(L14)=QX(L2) L2=L2+NSTEP2 L14=L14+1 GOTO27000 END IF END IF IF(REFTMP.LT.4)THEN STEP14=4 ELSE STEP14=10 END IF STOP14=MARK14+NATTYP+NSYM*STEP14 ISKIP=0 CALLAA51(0.,1,RSUMS,1,60,2) CALLAA04(0,' ',0,1,3) LINRM=5 I=2*RFLTYP+1 CALLAA55(CR212,I,CR211,32,2,0) CALLAA55(CR212,I,CR211,40,2,0) IF(REFEXT.GT.0)THEN CALLCR22(0,0,0.) END IF 27003 CONTINUE CALLAA12(1,20,PACK,IP,0) IF(IP.EQ.0)THEN GOTO27004 END IF IF(ICYCLE.EQ.NCYCLE)THEN CALLAA11(2,20,SIGNAL(4),IPP) K=SIGNAL(2)+1 LPP=IPP+1 DO27005I=1,SIGNAL(4) QX(IPP+I)=-4.E+20 27005 CONTINUE DO27007I=1,PACK CALLAA52(QX(IP+I),QX(LPP)) IF(REL(K).EQ.I)THEN K=K+1 ELSE LPP=LPP+1 END IF 27007 CONTINUE ELSE IPP=IP END IF BUILD=1 ISKIP=ISKIP+1 IF(ISKIP.NE.NSKIP)THEN BUILD=0 ELSE ISKIP=0 END IF IF(REL10.GT.0)THEN RCODE=NINT(QX(IP+REL10)) IF(RCODE.GT.3.AND.REFABS.EQ.0)THEN GOTO27003 END IF END IF DO27009KQJ=1,3 CALLAA74(QX(IP+REL1),JQK,(KQJ-1)*9+3,9) CALLAA74(QX(IP+REL1),KZJ,KQJ-1,1) IF(KZJ.NE.0)THEN JQK=-JQK END IF H(4-KQJ)=FLOAT(JQK) 27009 CONTINUE STOL=QX(IP+REL2) IF(MAXHKL.EQ.1)THEN IF(ABS(H(1)).GT.MAXH)THEN BUILD=0 END IF IF(ABS(H(2)).GT.MAXK)THEN BUILD=0 END IF IF(ABS(H(3)).GT.MAXL)THEN BUILD=0 END IF IF(STOL.LT.SMIN)THEN BUILD=0 END IF IF(STOL.GT.SMAX)THEN BUILD=0 END IF END IF IF((BUILD.EQ.0).AND.(ICYCLE.LT.NCYCLE))THEN GOTO27003 END IF AH=H(1) AK=H(2) AL=H(3) STOLSQ=STOL*STOL IF(REL12.GT.0)THEN ISKF=NINT(QX(IP+REL12)) L3=MARK3 27011 IF(L3.LT.MARK4)THEN IF(ISKF.EQ.NINT(QX(L3+2)))THEN GOTO27013 END IF L3=L3+2 GOTO27011 27013 CONTINUE END IF SKF=1.0/QX(L3+1) IF(RFLTYP.GT.0)THEN SKF=SKF*SKF END IF END IF IF(IWT.GT.1)THEN IF(QX(IP+REL8).GT.0.0)THEN WEIGHT=QX(IP+REL8) ELSE WEIGHT=1.0 END IF IF(IWT.EQ.2)THEN WEIGHT=SKF/WEIGHT END IF END IF IF(RADTYP.EQ.1)THEN L2=MARK2+5 L14=MARK14+1 DO27014I=1,NATTYP IF(REL(I+15).GT.0)THEN M=IP+REL(I+15) ELSE M=L2+NINT(STOL/DSFTB) END IF QX(L14)=QX(M) L2=L2+NSTEP2 L14=L14+1 27014 CONTINUE END IF L14=MARK14+NATTYP-STEP14 L0=MARK0 27016 IF(L0.LT.STOP0)THEN L14=L14+STEP14 BH=AH*QX(L0+1)+AK*QX(L0+2)+AL*QX(L0+3) BK=AH*QX(L0+4)+AK*QX(L0+5)+AL*QX(L0+6) BL=AH*QX(L0+7)+AK*QX(L0+8)+AL*QX(L0+9) QX(L14+1)=TWOPI*BH QX(L14+2)=TWOPI*BK QX(L14+3)=TWOPI*BL QX(L14+4)=TWOPI*(AH*QX(L0+10)+AK*QX(L0+11)+AL*QX(L0+12)) IF(REFTMP.LE.3)THEN GOTO27017 END IF QX(L14+5)=BH*BH QX(L14+6)=BK*BK QX(L14+7)=BL*BL QX(L14+8)=2.*BH*BK QX(L14+9)=2.*BH*BL QX(L14+10)=2.*BK*BL 27017 CONTINUE L0=L0+12 GOTO27016 END IF DO27019I=1,6 FA(I)=0. 27019 CONTINUE IF(PARTL.GT.0)THEN S=1. IF(PARTL.EQ.2)THEN M=IP+REL(NATTYP+24) IF(QX(M).GT..1)THEN S=-1. END IF END IF N=SIGNAL(3) IF(PARTL.EQ.1)THEN M=21+NATTYP+1 ELSE M=12+NATTYP+1 END IF M=IP+REL(M) IF(M.GT.IP)THEN FA(5)=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=FA(5) END IF IF(ICENT.EQ.0)THEN IF(PARTL.EQ.2)THEN FA(5)=S*FA(5) END IF IF(ICYCLE.EQ.NCYCLE)THEN QX(M)=FA(5) END IF ELSE IF(PARTL.EQ.1)THEN M=21+NATTYP+2 ELSE M=12+NATTYP+2 END IF M=IP+REL(M) IF(M.GT.IP)THEN FA(5)=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=FA(5) END IF IF(PARTL.EQ.1)THEN M=21+NATTYP+3 ELSE M=12+NATTYP+3 END IF M=IP+REL(M) IF(M.GT.IP)THEN FA(6)=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=FA(6) END IF END IF FA(1)=FA(5) FA(2)=FA(6) IF(REFDSP.GT.0)THEN IF(PARTL.EQ.1)THEN M=21+NATTYP+4 ELSE M=12+NATTYP+4 END IF M=IP+REL(M) IF(M.GT.IP)THEN ADIS=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=ADIS END IF IF(PARTL.EQ.1)THEN M=21+NATTYP+5 ELSE M=12+NATTYP+5 END IF M=IP+REL(M) IF(M.GT.IP)THEN BDIS=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=BDIS END IF IF(PARTL.EQ.1)THEN M=21+NATTYP+6 ELSE M=12+NATTYP+6 END IF M=IP+REL(M) IF(M.GT.IP)THEN FA(1)=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=FA(1) END IF IF(PARTL.EQ.1)THEN M=21+NATTYP+7 ELSE M=12+NATTYP+7 END IF M=IP+REL(M) IF(M.GT.IP)THEN FA(2)=QX(M) END IF IF(ICYCLE.EQ.NCYCLE)THEN N=N+1 M=N M=IPP+REL(M) QX(M)=FA(2) END IF END IF END IF IF(ICYCLE.NE.NCYCLE)THEN CALLAA51(0.,1,QX,MARK13+1,STEP13,2) L9=MARK9+1 N9=NINT(QX(L9)) LCON=MARK10 LCON=LCON+0 PCON=NINT(QX(LCON+1)) L13=MARK13+VARGEN DERFAC=WEIGHT IF(RFLTYP.GT.0)THEN DERFAC=2.*DERFAC END IF DERSKF=DERFAC IF(RFLTYP.EQ.2)THEN DERFAC=DERFAC/QX(IP+REL9) END IF DERTMP=-STOLSQ/CELL(1)*DERFAC END IF L5=MARK5+7 27021 IF(L5.LT.MARK6)THEN CALLAA74(QX(L5+1),ATTYP,0,5) CALLAA74(QX(L5+1),NTMP,5,3) IF(NTMP.LE.1)THEN PAR=3 ELSE PAR=9 END IF L5P=L5+5+NTMP L5M=L5P+POP PARTOT=3+NTMP+REFPOP REF=1 IF(-PCON.EQ.L5)THEN REF=0 LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE IF(ICYCLE.EQ.NCYCLE)THEN REF=0 END IF SUMCOS=0. SUMSIN=0. CALLAA51(0.,1,DELA,1,PAR,2) IF(IMAGP.GT.1)THEN CALLAA51(0.,1,DELB,1,PAR,2) END IF L14=MARK14+NATTYP 27024 IF(L14.LT.STOP14)THEN Q=QX(L14+1)*QX(L5+2)+QX(L14+2)*QX(L5+3)+QX(L14+3)*QX(L5+4)+QX(L14+ &4) COS2P=COS(Q) SIN2P=SIN(Q) IF(NTMP.EQ.6)THEN Q=QX(L14+5)*QX(L5+5)+QX(L14+6)*QX(L5+6)+QX(L14+7)*QX(L5+7)+QX(L14+ &8)*QX(L5+8)+QX(L14+9)*QX(L5+9)+QX(L14+10)*QX(L5+10) Q=EXP(-Q) COS2P=Q*COS2P SIN2P=Q*SIN2P END IF SUMCOS=SUMCOS+COS2P SUMSIN=SUMSIN+SIN2P IF(REF.EQ.0)THEN GOTO27025 END IF DO27027I=1,3 DELA(I)=DELA(I)-QX(L14+I)*SIN2P IF(ICENT.EQ.1)THEN DELB(I)=DELB(I)+QX(L14+I)*COS2P END IF 27027 CONTINUE DO27029I=4,PAR DELA(I)=DELA(I)-QX(L14+I+1)*COS2P IF(ICENT.EQ.1)THEN DELB(I)=DELB(I)-QX(L14+I+1)*SIN2P END IF 27029 CONTINUE 27025 CONTINUE L14=L14+STEP14 GOTO27024 END IF IF(NTMP.EQ.0)THEN FACT=EXP(-STOLSQ*QX(MARK4+1))*RFLMLT ELSE IF(NTMP.EQ.1)THEN FACT=EXP(-STOLSQ*QX(L5+5))*RFLMLT ELSE FACT=RFLMLT END IF IF(POP.GT.0)THEN FACT=FACT*QX(L5P) END IF IF(MLT.GT.0)THEN FACT=FACT*QX(L5M) END IF L14=MARK14+ATTYP FACT1=QX(L14)*FACT FACT2=0. A=FACT1*SUMCOS FA(5)=FA(5)+A B=0. C=0. D=0. IF(ICENT.EQ.1)THEN B=FACT1*SUMSIN FA(6)=FA(6)+B END IF L2=MARK2+(ATTYP-1)*NSTEP2 IF(REFDSP.GT.0)THEN IF((ABS(QX(L2+1)).GT.5.0E-7).AND.(ABS(QX(L2+2)).GT.5.0E-7))THEN FACT1=(QX(L14)+QX(L2+1))*FACT FACT2=QX(L2+2)*FACT A=FACT1*SUMCOS C=FACT2*SUMCOS IF(ICENT.EQ.1)THEN B=FACT1*SUMSIN D=FACT2*SUMSIN END IF END IF END IF AA(1)=A-D AA(2)=B+C IF(REFABS.GT.0)THEN AA(3)=A+D AA(4)=-B+C END IF DO27031I=1,IMAGP FA(I)=FA(I)+AA(I) 27031 CONTINUE IF((NTMP.EQ.REFUOV-1).AND.(BLKTYP.EQ.1))THEN L=MARK13+REFSKF+1 DO27033I=1,IMAGP QX(L)=QX(L)+AA(I)*DERTMP L=L+VARTOT 27033 CONTINUE END IF IF(REF.EQ.0)THEN GOTO27022 END IF IF(QX(L2+3).GT.0.5)THEN D1=FACT*SUMCOS*DERFAC D2=FACT*SUMSIN*DERFAC L=L13DSP+(NINT(QX(L2+3))-1)*2 QX(L)=QX(L)+D1 QX(L+1)=QX(L+1)-D2 L=L+VARTOT QX(L)=QX(L)+D2 QX(L+1)=QX(L+1)+D1 IF(REFABS.EQ.2)THEN L=L+VARTOT QX(L)=QX(L)+D1 QX(L+1)=QX(L+1)+D2 L=L+VARTOT QX(L)=QX(L)-D2 QX(L+1)=QX(L+1)+D1 END IF END IF FACT1=FACT1*DERFAC FACT2=FACT2*DERFAC DO27035P=1,PARTOT IF(P.LE.PAR)THEN IF(IMAGP.EQ.1)THEN DA(1)=FACT1*DELA(P) ELSE DA(1)=FACT1*DELA(P)-FACT2*DELB(P) DA(2)=FACT1*DELB(P)+FACT2*DELA(P) IF(REFABS.GT.0)THEN DA(3)=FACT1*DELA(P)+FACT2*DELB(P) DA(4)=-FACT1*DELB(P)+FACT2*DELA(P) END IF END IF ELSE IF((P.EQ.4).AND.(NTMP.EQ.1))THEN DO27037I=1,IMAGP DA(I)=DERTMP*AA(I) 27037 CONTINUE ELSE Q=DERFAC/QX(L5P) DO27039I=1,IMAGP DA(I)=AA(I)*Q 27039 CONTINUE END IF IF((L5+P+1).EQ.IABS(PCON))THEN IF(PCON.LT.0)THEN LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE IF(QX(LCON+2).GE.0.)THEN L13=L13+NINT(QX(LCON+2)) END IF N1=NINT(QX(LCON+3)) N2=NINT(QX(LCON+4)) LCON=LCON+4 DO27041J=5,N1,N2 IF(N2.GT.1)THEN FCT=QX(LCON+2) ELSE FCT=-1. END IF L=MARK13+NINT(QX(LCON+1)) DO27043I=1,IMAGP QX(L)=QX(L)+FCT*DA(I) L=L+VARTOT 27043 CONTINUE LCON=LCON+N2 27041 CONTINUE LCON=LCON+0 PCON=NINT(QX(LCON+1)) END IF GOTO27035 END IF IF(BLKTYP.EQ.3)THEN IF(N9.GT.0)THEN L13=MARK13+N9-1 L9=L9+1 N9=NINT(QX(L9)) ELSE IF((L5+1+P).EQ.-N9)THEN L9=L9+1 N9=NINT(QX(L9)) END IF END IF L13=L13+1 L=L13 DO27045I=1,IMAGP QX(L)=QX(L)+DA(I) L=L+VARTOT 27045 CONTINUE 27035 CONTINUE 27022 CONTINUE L5=NINT(QX(L5)) GOTO27021 END IF IF(IMAGP.EQ.1)THEN FC2=FA(1)*FA(1) ELSE FC2=FA(1)*FA(1)+FA(2)*FA(2) IF(REFABS.GT.0)THEN FCFR2=FA(3)*FA(3)+FA(4)*FA(4) END IF END IF IF(REFEXT.GT.0)THEN Q=FC2 CALLCR22(1,IP,Q) EXTCOR=Q FC2=FC2*Q*Q IF(REFABS.GT.0)THEN FCFR2=FCFR2*Q*Q END IF END IF WFRDL=1. DO27047IFRDL=1,NFRDL IF(IFRDL.EQ.1)THEN DFC=0. IF(ABS(QX(IP+REL4)-(-4.E+20)).LT.1.E13)THEN GOTO27047 END IF OBS=QX(IP+REL4)/SKF CALC=FC2 IF(REL5.GT.0)THEN SIGMA=QX(IP+REL5)/SKF END IF IF(REFABS.GT.0)THEN CALC=(1.-XABS)*FC2+XABS*FCFR2 IF(ABS(QX(IP+REL6)-(-4.E+20)).GT.1.E13)THEN DFC=-FC2+FCFR2 WFRDL=0.5 END IF END IF ELSE IF(ABS(QX(IP+REL6)-(-4.E+20)).LT.1.E13)THEN GOTO27048 END IF OBS=QX(IP+REL6)/SKF IF(REL7.GT.0)THEN SIGMA=QX(IP+REL7)/SKF END IF IF(REL11.GT.0)THEN RCODE=QX(IP+REL11) END IF CALC=(1.-XABS)*FCFR2+XABS*FC2 DFC=-DFC AH=-AH AK=-AK AL=-AL END IF FCAL=SQRT(MAX(0.,CALC)) IF(RFLTYP.EQ.0)THEN CALC=FCAL FOBS=OBS FO2=OBS*OBS ELSE IF(RFLTYP.EQ.1)THEN FO2=OBS FOBS=SQRT(MAX(0.,FO2)) ELSE CALC=CALC/QX(IP+REL9) FO2=OBS*QX(IP+REL9) FOBS=SQRT(MAX(0.,FO2)) END IF FDEL=FOBS-FCAL DELTA=OBS-CALC LT=RCODE IF(RCODE.GT.2)THEN LT=2 BUILD=0 END IF IF((TYPELT.GT.0.).AND.(RCODE.LE.2))THEN IF(OBS.LT.TYPELT*SIGMA)THEN LT=2 ELSE LT=1 END IF END IF IF(BUILD.EQ.1)THEN IF(LT.EQ.1)THEN IF(ABS(WEIGHT*DELTA).GT.RFMTRX)THEN BUILD=0 END IF ELSE IF(LT.EQ.2)THEN IF((LTMTRX.EQ.0).OR.(ABS(CALC).LT.OBS))THEN BUILD=0 END IF ELSE BUILD=0 END IF END IF FACT=WEIGHT*WEIGHT RSUMS(LT+1)=RSUMS(LT+1)+ABS(FOBS) RSUMS(LT+4)=RSUMS(LT+4)+ABS(FCAL) RSUMS(LT+7)=RSUMS(LT+7)+ABS(FDEL) RSUMS(LT+16)=RSUMS(LT+16)+FACT*DELTA*DELTA RSUMS(LT+19)=RSUMS(LT+19)+FACT*OBS*OBS RSUMS(LT+22)=RSUMS(LT+22)+WFRDL IF(BUILD.EQ.0)THEN RSUMS(LT+26)=RSUMS(LT+26)+ABS(FOBS) RSUMS(LT+29)=RSUMS(LT+29)+ABS(FCAL) RSUMS(LT+32)=RSUMS(LT+32)+ABS(FDEL) RSUMS(LT+41)=RSUMS(LT+41)+FACT*DELTA*DELTA RSUMS(LT+44)=RSUMS(LT+44)+FACT*OBS*OBS RSUMS(LT+47)=RSUMS(LT+47)+WFRDL END IF IF((LIST.EQ.2).OR.(ABS(WEIGHT*DELTA).GT.RFLIST).OR.(ICYCLE.EQ.NCYC &LE))THEN FO2NE=FO2/(EXTCOR*EXTCOR) FCND=SQRT(FA(5)*FA(5)+FA(6)*FA(6)) IF(REFDSP.EQ.0)THEN FOND=SQRT(AMAX1(0.,FO2NE)) ELSE IF(IFRDL.EQ.1)THEN IF(REFABS.EQ.0)THEN ADIS=FA(1)-FA(5) BDIS=FA(2)-FA(6) EFLACK=0.0 ELSE AREFD=FA(1)-FA(5) BREFD=FA(2)-FA(6) ANTID=FA(3)-FA(5) BNTID=FA(4)+FA(6) ADIS=(1.-XABS)*AREFD+XABS*ANTID BDIS=(1.-XABS)*BREFD-XABS*BNTID EFLACK=(1.-XABS)*(AREFD**2+BREFD**2)+XABS*(ANTID**2+BNTID**2)-ADIS &**2-BDIS**2 END IF ELSE IF(REFABS.EQ.0)THEN ADIS=FA(3)-FA(5) BDIS=FA(4)+FA(6) EFLACK=0.0 ELSE ADIS=(1.-XABS)*ANTID+XABS*AREFD BDIS=(1.-XABS)*BNTID-XABS*BREFD EFLACK=(1.-XABS)*(ANTID**2+BNTID**2)+XABS*(AREFD**2+BREFD**2)-ADIS &**2-BDIS**2 END IF END IF IF(ABS((FCND)-(0.0)).LE.5.0E-7)THEN A=0. B=0. ELSE IF(IFRDL.EQ.1)THEN A=(ADIS*FA(6)-BDIS*FA(5))/FCND B=(ADIS*FA(5)+BDIS*FA(6))/FCND ELSE A=(-ADIS*FA(6)-BDIS*FA(5))/FCND B=(ADIS*FA(5)-BDIS*FA(6))/FCND END IF END IF FOND=AMAX1(0.,FO2NE-A*A-EFLACK) FOND=SQRT(FOND)-B END IF IF((ABS(FA(5)).LT..01).AND.(ABS(FA(6)).LT..01))THEN FA(5)=.01 END IF PHI=AMOD(ATAN2(FA(6),FA(5))/TWOPI+1.000001,1.) END IF IF((LIST.GE.2).OR.(ABS(WEIGHT*DELTA).GT.RFLIST))THEN BUFOT(1)=AH BUFOT(2)=AK BUFOT(3)=AL BUFOT(4)=STOL IF(RCODE.LT.3)THEN BUFOT(5)=FLOAT(LT) ELSE BUFOT(5)=FLOAT(RCODE) END IF IF(BUILD.EQ.0)THEN BUFOT(5)=-BUFOT(5) END IF BUFOT(6)=FLOAT(ISKF) BUFOT(7)=OBS BUFOT(8)=CALC IF(IFRDL.EQ.1)THEN BUFOT(9)=FA(1)*EXTCOR BUFOT(10)=FA(2)*EXTCOR ELSE BUFOT(9)=FA(3)*EXTCOR BUFOT(10)=FA(4)*EXTCOR END IF BUFOT(11)=EXTCOR BUFOT(12)=FOND BUFOT(13)=FCND BUFOT(14)=PHI*360. BUFOT(15)=OBS-CALC BUFOT(16)=WEIGHT*BUFOT(15) BUFOT(17)=SIGMA CALLAA03(BUFOT,1,CHROT,FORM(1),17) CALLAA04(0,CR211,NCR211,1,3) END IF IF(ICYCLE.EQ.NCYCLE)THEN IF(IFRDL.EQ.1)THEN QX(LPP)=ABS(FCND) LPP=LPP+1 IF(ICENT.EQ.1)THEN QX(LPP)=FA(5) LPP=LPP+1 QX(LPP)=FA(6) LPP=LPP+1 END IF IF(REFDSP.GT.0.OR.REFEXT.GT.0)THEN QX(LPP)=ADIS LPP=LPP+1 QX(LPP)=BDIS LPP=LPP+1 QX(LPP)=FA(1) LPP=LPP+1 QX(LPP)=FA(2) LPP=LPP+1 IF(RFLTYP.GT.0)THEN QX(LPP)=FOND*SQRT(SKF) ELSE QX(LPP)=FOND*SKF END IF LPPSV=LPP LPP=LPP+1 END IF QX(LPP)=PHI LPP=LPP+1 QX(LPP)=EXTCOR**2 LPP=LPP+1 QX(LPP)=FCAL LPP=LPP+1 GOTO100 ELSE IF((REFDSP.GT.0.OR.REFEXT.GT.0).AND.(RFLTYP.GT.0))THEN QX(LPPSV)=0.5*(QX(LPPSV)+FOND*SQRT(SKF)) ELSE QX(LPPSV)=0.5*(QX(LPPSV)+FOND*SKF) END IF END IF END IF IF(BUILD.EQ.0)THEN GOTO100 END IF DELTA=WEIGHT*DELTA IF(REFSKF.GT.0)THEN IF(REFSKF.GT.1)THEN L13=MARK13+ISKF ELSE L13=MARK13+1 END IF QX(L13)=CALC*DERSKF END IF L13=MARK13+REFSKF+1 IF((REFUOV.NE.0).AND.(BLKTYP.NE.1))THEN L=L13 DO27049I=1,IMAGP QX(L)=FA(I)*DERTMP L=L+VARTOT 27049 CONTINUE END IF L13=L13+IABS(REFUOV) IF(REFABS.EQ.2)THEN QX(L13)=WEIGHT*DFC IF(RFLTYP.EQ.0)THEN IF(CALC.GT.0.)THEN QX(L13)=QX(L13)/(2.*CALC) ELSE QX(L13)=0. END IF END IF IF(RFLTYP.EQ.2)THEN QX(L13)=QX(L13)/QX(IP+REL9) END IF L13=L13+1 END IF IF(REFEXT.GT.1)THEN Q=DERFAC CALLCR22(2,L13,Q) DEREXT=Q DO27051I=1,IMAGP CA(I)=DEREXT*FA(I) 27051 CONTINUE ELSE IF(RFLTYP.EQ.0)THEN DO27053I=1,IMAGP CA(I)=0. 27053 CONTINUE IF(CALC.GT.5.0E-7)THEN CA(1)=FA(1)/CALC CA(2)=FA(2)/CALC END IF IF(REFABS.EQ.2.AND.FCFR2.GT.5.0E-7)THEN CA(3)=FA(3)/SQRT(FCFR2) CA(4)=FA(4)/FCFR2 END IF ELSE DO27055I=1,IMAGP CA(I)=FA(I) 27055 CONTINUE END IF L13=MARK13+REFSKF+1 DO27057L=L13,STOP13 IF(L.LT.L13DSP.AND.L.NE.L13UOV)THEN GOTO27057 END IF IF(IMAGP.EQ.1)THEN QX(L)=CA(1)*QX(L) ELSE IF(IMAGP.EQ.2)THEN QX(L)=CA(1)*QX(L)+CA(2)*QX(L+VARTOT) ELSE IF(IFRDL.EQ.1)THEN K=L+2*VARTOT QX(L+VARTOT)=CA(1)*QX(L)+CA(2)*QX(L+VARTOT) QX(K+VARTOT)=CA(3)*QX(K)+CA(4)*QX(K+VARTOT) QX(L)=(1.-XABS)*QX(L+VARTOT)+XABS*QX(K+VARTOT) ELSE K=L+2*VARTOT QX(L)=(1.-XABS)*QX(K+VARTOT)+XABS*QX(L+VARTOT) END IF 27057 CONTINUE L11=MARK11 L12=MARK12 L13=MARK13 L8=MARK8+2 27059 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8)) VARBLK=NINT(QX(L8+1)) DO27062I=1,NBLK DO27064J=1,VARBLK Q=QX(L13+J) DO27066L=J,VARBLK QX(L11+L)=QX(L11+L)+Q*QX(L13+L) 27066 CONTINUE L11=L11+VARBLK-J 27064 CONTINUE DO27068J=1,VARBLK QX(L12+J)=QX(L12+J)+DELTA*QX(L13+J) 27068 CONTINUE L11=L11+VARBLK L12=L12+VARBLK L13=L13+VARBLK 27062 CONTINUE L8=L8+2 GOTO27059 END IF 100 CONTINUE 27047 CONTINUE 27048 CONTINUE GOTO27003 27004 CONTINUE RETURN END C-------CR22 SUBROUTINECR22(KEY,II,Q) INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALAP,AS REALBP,BS REALCP,CS REALCOST REALCOS2T REALDELTXT REALDEREXT REALDERFAC REALDPSIG REALDPSIR REALFACT REALFCSQ REALFC REALG REALGAMMAP REALGAMMAS REALGFACT INTEGERII INTEGERKEY INTEGERL13EXT REALOM1,OM2,OM3 REALPAREXT REALPOL1 REALPOL2 INTEGERPRMEXT REALPSI REALQ REALRHO REALSCOS2T REALSINT REALSIN2T REALTBAR REALXP,XS REALXP1,XP2,XS1,XS2 REALYEXT REALYP,YS REALYP1,YP2,YS1,YS2 REALZP,ZS REALZP1,ZP2,ZS1,ZS2 SAVE IF(KEY.EQ.0)THEN PRMEXT=1 IF(EXTTYP.LE.1.OR.EXTTYP.EQ.4)THEN PRMEXT=0 END IF GFACT=LAMBDA**3/VOL**2 IF(RADTYP.EQ.1)THEN GFACT=GFACT*79.4075 ELSE GFACT=GFACT*10000. END IF GAMMAP=1.5*LAMBDA*GFACT/10000. POL1=RATIO ELSE IF(KEY.EQ.1)THEN FCSQ=Q TBAR=QX(MARK4+22) IF(REL(15).GT.0.AND.MU.GT.0.)THEN IF(QX(II+REL(15))-(-4.E+20).GT.5.0E-7)THEN TBAR=ALOG(QX(II+REL(15)))/MU+.00001 END IF END IF IF(REL(14).GT.0)THEN IF(QX(II+REL(14))-(-4.E+20).GT.5.0E-7)THEN TBAR=QX(II+REL(14)) END IF END IF GAMMAS=GFACT*TBAR SINT=QX(II+REL(2))*LAMBDA COST=SQRT(1.-SINT*SINT) SIN2T=2.*SINT*COST COS2T=COST*COST-SINT*SINT IF(EXTTYP.EQ.0)THEN DELTXT=GAMMAS*2./SIN2T IF(RADTYP.EQ.1)THEN POL2=(1.-POL1)*COS2T*COS2T FACT=1./(POL1+POL2) SCOS2T=COS2T*COS2T DELTXT=DELTXT*(POL1+POL2*SCOS2T)*FACT END IF PAREXT=QX(MARK4+2)*DELTXT*FCSQ YEXT=(1.+PAREXT)**(-.25) ELSE IF(PRMEXT.EQ.1)THEN AP=.20+.45*COS2T BP=.22-.12*(.5-COS2T)**2 CP=2.0 END IF IF(DSTEXT.EQ.0)THEN AS=.58+.48*COS2T+.24*COS2T*COS2T BS=.020-.025*COS2T CS=2.12 ELSE AS=.025+.285*COS2T IF(COS2T.GE.0.)THEN BS=.15-.2*(.75-COS2T)**2 ELSE BS=-.45*COS2T END IF CS=2.0 END IF IF(EXTTYP.EQ.3.OR.EXTTYP.EQ.6)THEN G=QX(MARK4+2) RHO=QX(MARK4+3) IF(DSTEXT.EQ.0)THEN PSI=RHO/SQRT(1.+(RHO*SIN2T/G)**2) ELSE PSI=RHO/(1.+RHO*SIN2T/G) END IF ELSE IF(EXTTYP.EQ.2.OR.EXTTYP.EQ.5)THEN RHO=QX(MARK4+3) G=0. PSI=RHO ELSE RHO=0 G=QX(MARK4+2) PSI=G/SIN2T END IF XP=GAMMAP*FCSQ*RHO*RHO XS=GAMMAS*FCSQ*PSI IF(RADTYP.EQ.1)THEN POL2=(1.-POL1)*COS2T*COS2T FACT=1./(POL1+POL2) YP1=1. YP2=1. IF(PRMEXT.EQ.1)THEN XP1=POL1*XP YP1=1./SQRT(1.+CP*XP1+AP*XP1*XP1/(1.+BP*XP1)) XP2=POL2*XP YP2=1./SQRT(1.+CP*XP2+AP*XP2*XP2/(1.+BP*XP2)) END IF XS1=POL1*XS*YP1 YS1=1./SQRT(1.+CS*XS1+AS*XS1*XS1/(1.+BS*XS1)) XS2=POL2*XS*YP2 YS2=1./SQRT(1.+CS*XS2+AS*XS2*XS2/(1.+BS*XS2)) YEXT=FACT*(POL1*YP1*YS1+POL2*YP2*YS2) ELSE YP=1. IF(PRMEXT.EQ.1)THEN YP=1./SQRT(1.+CP*XP+AP*XP*XP/(1.+BP*XP)) END IF XS=XS*YP YS=1./SQRT(1.+CS*XS+AS*XS*XS/(1.+BS*XS)) YEXT=YP*YS END IF YEXT=SQRT(YEXT) END IF Q=YEXT ELSE IF(KEY.EQ.2)THEN DERFAC=Q IF(EXTTYP.EQ.0)THEN OM1=(1.+.5*PAREXT)/(1.+PAREXT) OM2=-.5/(1.+PAREXT)**1.5 GAMMAS=DELTXT ELSE DPSIR=0. DPSIG=0. IF(EXTTYP.EQ.3.OR.EXTTYP.EQ.6)THEN IF(DSTEXT.EQ.0)THEN DPSIR=(PSI/RHO)**3 DPSIG=(PSI/G)**3*SIN2T*SIN2T ELSE DPSIR=(PSI/RHO)**2 DPSIG=(PSI/G)**2*SIN2T END IF ELSE IF(PRMEXT.EQ.1)THEN DPSIR=1. ELSE DPSIG=1./SIN2T END IF IF(RADTYP.EQ.1)THEN ZP1=0. ZP2=0. IF(PRMEXT.EQ.1)THEN ZP1=-.5*YP1**3*(CP+AP*XP1*(2.+BP*XP1)/(1.+BP*XP1)**2) ZP2=-.5*YP2**3*(CP+AP*XP2*(2.+BP*XP2)/(1.+BP*XP2)**2) END IF ZS1=-.5*YS1**3*(CS+AS*XS1*(2.+BS*XS1)/(1.+BS*XS1)**2) ZS2=-.5*YS2**3*(CS+AS*XS2*(2.+BS*XS2)/(1.+BS*XS2)**2) OM1=FACT*(POL1*(XS1*ZS1+YS1)*(XP1*ZP1+YP1)+POL2*(XS2*ZS2+YS2)*(XP2 &*ZP2+YP2)) IF(EXTTYP.EQ.1.OR.EXTTYP.EQ.4.OR.EXTTYP.EQ.3.OR.EXTTYP.EQ.6)THEN OM2=FACT*(POL1**2*YP1*ZS1*YP1+POL2**2*YP2*ZS2*YP2)*DPSIG END IF IF(PRMEXT.EQ.1)THEN OM3=FACT*(2.*POL1**2*GAMMAP*RHO*ZP1*(XS1*ZS1+YS1)+POL1**2*GAMMAS*D &PSIR*ZS1*YP1*YP1+2.*POL2**2*GAMMAP*RHO*ZP2*(XS2*ZS2+YS2)+POL2**2*G &AMMAS*DPSIR*ZS2*YP2*YP1) END IF ELSE ZP=0. IF(PRMEXT.EQ.1)THEN ZP=-.5*YP**3*(CP+AP*XP*(2.+BP*XP)/(1.+BP*XP)**2) END IF ZS=-.5*YS**2*(CS+AS*XS*(2.+BS*XS)/(1.+BS*XS)**2) OM1=(XS*ZS+YS)*(XP*ZP+YP) IF(EXTTYP.EQ.1.OR.EXTTYP.EQ.4.OR.EXTTYP.EQ.3.OR.EXTTYP.EQ.6)THEN OM2=YP*YP*ZS*DPSIG END IF IF(PRMEXT.EQ.1)THEN OM3=GAMMAP*RHO*ZP*(XS*ZS+YS)+GAMMAS*YP*YP*ZS*DPSIR END IF END IF END IF FC=SQRT(FCSQ) IF(RFLTYP.EQ.0)THEN FACT=1. ELSE FACT=FC*YEXT END IF DEREXT=FACT*YEXT*OM1/FC L13EXT=II IF(EXTTYP.LE.1.OR.EXTTYP.EQ.3.OR.EXTTYP.EQ.4.OR.EXTTYP.EQ.6)THEN QX(L13EXT)=.5*FACT*DERFAC*FC*FCSQ*GAMMAS*OM2/YEXT IF(EXTTYP.EQ.3.OR.EXTTYP.EQ.6)THEN L13EXT=L13EXT+1 END IF END IF IF(PRMEXT.EQ.1)THEN QX(L13EXT)=.5*FACT*DERFAC*FC*FCSQ*OM3/YEXT END IF Q=DEREXT END IF RETURN END C-------CR24 SUBROUTINECR24 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERCLASS REALC1,C2,C3,C4,C5,C6 REALCOSPHI REALDELTA REALDX(3) REALDY(6) REALD(9,13) REALE(7) INTEGERI,J,JJ,K,KK,L,N INTEGERI1 INTEGERI7 INTEGERJ1,J2,JH INTEGERL0,L5,L7,L8,L11,L12 INTEGERLCON INTEGERN1,N2 INTEGERNATM INTEGERNBLK INTEGERNPAR INTEGERNVEC INTEGERPCON REALQ INTEGERS INTEGERTR(3) REALV REALVAL INTEGERV1,V2 INTEGERVAR1,VAR2 INTEGERVARBLK REALW REALWS REALX(6) INTEGERNCR241 CHARACTER*11 CR241 INTEGERNCR242 CHARACTER*39 CR242 INTEGERNCR243 CHARACTER*26 CR243 REAL FMT1(4 ) REAL FMT2(4 ) REAL RAD DATANCR241/11 /, CR241/' RESTRAINTS'/ DATANCR242/39 /, CR242/' CLASS IDEAL CALC DELTA SIGMA'/ DATANCR243/26 /, CR243/'- BOND ANGLE DIHED PLANE '/ DATAFMT1/842.,842.,842.,842./ DATAFMT2/822.,822.,822.,822./ DATARAD/57.29578/ E(1)=0. DO27000I=1,3 E(I+1)=.00001 27000 CONTINUE DO27002I=1,3 E(I+4)=-E(I+1) 27002 CONTINUE W=(RSUMS(17)+RSUMS(18)-RSUMS(42)-RSUMS(43))/(RSUMS(23)+RSUMS(24)-R &SUMS(48)-RSUMS(49)-FLOAT(VARTOT)) W=W/FLOAT(NSKIP) I7=MARK7 27004 IF(I7.LT.MARK8)THEN CLASS=NINT(QX(I7+1)) NATM=NINT(QX(I7+2)) L7=I7+4 NPAR=3*NATM IF(CLASS.EQ.1)THEN NVEC=1 ELSE NVEC=3 END IF J1=I7+4 J2=I7+6 WS=SQRT(W)/QX(I7+4) DO27007J=1,NVEC L5=NINT(QX(J1+1)) S=NINT(QX(J1+2)) TR(1)=MOD(S/100,10) TR(2)=MOD(S/10,10) TR(3)=MOD(S,10) DO27009K=1,4,3 L0=MARK0+(S/1000-1)*12 DO27011JJ=0,2 X(K+JJ)=QX(L0+1)*QX(L5+2)+QX(L0+4)*QX(L5+3)+QX(L0+7)*QX(L5+4)+QX(L &0+10)+FLOAT(TR(JJ+1)-5) L0=L0+1 27011 CONTINUE L5=NINT(QX(J2+1)) S=NINT(QX(J2+2)) TR(1)=MOD(S/100,10) TR(2)=MOD(S/10,10) TR(3)=MOD(S,10) 27009 CONTINUE DO27013JJ=1,3 DX(JJ)=X(JJ)-X(JJ+3) IF(DX(JJ).GT..5)THEN DX(JJ)=DX(JJ)-1. END IF IF(DX(JJ).LT.-.5)THEN DX(JJ)=DX(JJ)+1. END IF 27013 CONTINUE DO27015K=1,7 DO27017JJ=1,3 DY(JJ)=DX(JJ) 27017 CONTINUE IF(K.EQ.1)THEN I=1 ELSE IF(K.EQ.2)THEN I=(J1-I7-4)/2*3+2 S=NINT(QX(J1+2)) ELSE IF(K.EQ.5)THEN I=(J2-I7-4)/2*3+2 S=NINT(QX(J2+2)) END IF KK=MOD((K-2),3)+1 IF(KK.EQ.1)THEN L0=MARK0+(S/1000-1)*12 END IF IF(L0.EQ.MARK0)THEN DY(KK)=DX(KK)+E(K) ELSE DO27019JJ=1,3 DY(JJ)=DY(JJ)+QX(L0+JJ)*E(K) 27019 CONTINUE L0=L0+3 END IF END IF IF(CLASS.LE.2)THEN D(J,I)=CELL(31)*DY(1)*DY(1)+CELL(35)*DY(2)*DY(2)+CELL(39)*DY(3)*DY &(3)+2.*(CELL(32)*DY(1)*DY(2)+CELL(33)*DY(1)*DY(3)+CELL(36)*DY(2)*D &Y(3)) IF(K.EQ.1)THEN DO27021I=1,NPAR D(J,I+1)=D(J,1) 27021 CONTINUE END IF ELSE IF(CLASS.EQ.3)THEN L=(J-1)*3 DO27023JJ=1,3 D(L+JJ,I)=CELL(JJ+12)*DY(1)+CELL(JJ+15)*DY(2)+CELL(JJ+18)*DY(3) IF(K.EQ.1)THEN DO27025N=1,NPAR D(L+JJ,N+1)=D(L+JJ,1) 27025 CONTINUE END IF 27023 CONTINUE END IF IF(ICYCLE.EQ.NCYCLE)THEN GOTO27016 END IF I=I+1 27015 CONTINUE 27016 CONTINUE IF(J.EQ.1)THEN J1=I7+8 ELSE IF(J.EQ.2.AND.CLASS.EQ.2)THEN J2=I7+4 ELSE J2=I7+10 END IF 27007 CONTINUE DO27027K=1,NPAR+1 IF(CLASS.EQ.1)THEN V=SQRT(D(1,K)) ELSE IF(CLASS.EQ.2)THEN COSPHI=(D(1,K)+D(2,K)-D(3,K))/(2.*SQRT(D(1,K)*D(2,K))) IF(ABS(COSPHI).LT..999999)THEN V=ACOS(COSPHI)*RAD ELSE IF(ABS(COSPHI).GT.0.0)THEN V=0.0 ELSE V=360.0 END IF ELSE IF(CLASS.EQ.3)THEN C1=D(2,K)*D(6,K)-D(3,K)*D(5,K) C2=D(3,K)*D(4,K)-D(1,K)*D(6,K) C3=D(1,K)*D(5,K)-D(2,K)*D(4,K) C4=D(6,K)*D(8,K)-D(5,K)*D(9,K) C5=D(4,K)*D(9,K)-D(6,K)*D(7,K) C6=D(5,K)*D(7,K)-D(4,K)*D(8,K) COSPHI=(C1*C4+C2*C5+C3*C6)/SQRT((C1*C1+C2*C2+C3*C3)*(C4*C4+C5*C5+C &6*C6)) IF(ABS(COSPHI).GT.1.0)THEN COSPHI=SIGN(1.0,COSPHI) END IF V=180.-ACOS(COSPHI)*RAD Q=(C2*C6-C3*C5)*D(4,K)+(C3*C4-C1*C6)*D(5,K)+(C1*C5-C2*C4)*D(6,K) IF(Q.GT..0)THEN V=-V END IF IF(V.GT.180.)THEN V=V-360. END IF END IF IF(K.EQ.1)THEN VAL=V IF(ICYCLE.EQ.NCYCLE)THEN GOTO27028 END IF ELSE L=MOD(K-2,3)+2 QX(MARK13+K-1)=WS*(V-VAL)/E(L) END IF 27027 CONTINUE 27028 CONTINUE DELTA=QX(I7+3)-VAL IF(CLASS.GT.1)THEN IF(DELTA.GT.180.)THEN DELTA=DELTA-360. ELSE IF(DELTA.LT.-180.)THEN DELTA=DELTA+360. END IF END IF L7=I7+4+2*NATM DO27029I1=1,NPAR IF(ABS((QX(L7+I1))-(0.)).GT.5.0E-7)THEN GOTO27029 END IF L=I7+4+(I1-1)/3*2 L5=NINT(QX(L+1))+MOD(I1-1,3)+2 LCON=MARK10 LCON=LCON+0 PCON=NINT(QX(LCON+1)) 27031 CONTINUE IF(L5.EQ.PCON)THEN DO27033I=1,I1 IF(ABS((QX(LCON+5))-(QX(L7+2*I-1))).GT.5.0E-7)THEN GOTO27033 END IF QX(MARK13+I)=QX(MARK13+I)+QX(LCON+6)*QX(MARK13+I1) GOTO27034 27033 CONTINUE 27034 CONTINUE END IF IF(PCON.LT.0)THEN LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE LCON=LCON+NINT(QX(LCON+3)) PCON=NINT(QX(LCON+1)) END IF IF(IABS(PCON).GT.L5)THEN GOTO27032 END IF GOTO27031 27032 CONTINUE 27029 CONTINUE RSUMS(59)=RSUMS(59)+1. RSUMS(60)=RSUMS(60)+WS*WS*DELTA*DELTA IF(I7.EQ.MARK7)THEN LINRM=10 CALLAA55(CR243,1,CHROT,2,10,1) CALLAA04(4,CR241,NCR241,2,3) CALLAA04(0,' ',0,2,3) HEADOT=' ' HEADOT(2:6)='ATOMS' JH=LABMAX*4+8 HEADOT(JH:)=CR242 END IF L7=I7+2 L=-LABMAX DO27035J=1,NATM L7=L7+2 L5=NINT(QX(L7+1)) L=L+LABMAX+2 CALLAA57(QX(L5-6),1,CHROT,L,24,0) 27035 CONTINUE CALLAA55(CR243,CLASS*6-4,CHROT,JH+1,5,0) BUFOT(1)=QX(I7+3) BUFOT(2)=VAL BUFOT(3)=DELTA BUFOT(4)=QX(I7+4) LCHROT=JH+6 IF(CLASS.EQ.1)THEN CALLAA03(BUFOT,1,CHROT,FMT1,4) ELSE CALLAA03(BUFOT,1,CHROT,FMT2,4) END IF CALLAA04(0,HEADOT,100,1,3) IF(ICYCLE.EQ.NCYCLE)THEN GOTO27005 END IF DELTA=WS*DELTA L7=I7+4+2*NATM I1=1 27037 IF(I1.LE.NPAR)THEN IF(ABS((QX(L7+I1))-(0.)).GT.5.0E-7)THEN GOTO27039 END IF I1=I1+1 GOTO27037 27039 CONTINUE END IF 27040 CONTINUE L11=MARK11 L12=MARK12 V1=0 VAR1=NINT(QX(L7+I1)) L8=MARK8+1 27042 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8+1)) VARBLK=NINT(QX(L8+2)) DO27045I=1,NBLK IF(VAR1.LE.V1+VARBLK)THEN GOTO100 END IF V1=V1+VARBLK L11=L11+VARBLK*(VARBLK+1)/2 L12=L12+VARBLK 27045 CONTINUE L8=L8+2 GOTO27042 END IF 100 V2=V1+VARBLK I=I1 27047 IF(I.LE.NPAR)THEN VAR1=NINT(QX(L7+I)) IF(VAR1.EQ.0)THEN GOTO27048 END IF IF(VAR1.LE.V1.OR.VAR1.GT.V2)THEN GOTO27049 END IF VAR1=VAR1-V1 N1=L11+((VAR1-1)*(VARBLK+VARBLK-VAR1+2))/2+1 Q=QX(MARK13+I) QX(N1)=QX(N1)+Q*Q DO27050J=I+1,NPAR VAR2=NINT(QX(L7+J)) IF(VAR2.EQ.0)THEN GOTO27050 END IF IF(VAR2.LE.V1.OR.VAR2.GT.V2)THEN GOTO27051 END IF VAR2=VAR2-V1 IF(VAR2.GT.VAR1)THEN N2=N1+VAR2-VAR1 ELSE N2=L11+((VAR2-1)*(VARBLK+VARBLK-VAR2+2))/2+1+VAR1-VAR2 END IF QX(N2)=QX(N2)+Q*QX(MARK13+J) 27050 CONTINUE 27051 CONTINUE QX(L12+VAR1)=QX(L12+VAR1)+Q*DELTA 27048 CONTINUE I=I+1 GOTO27047 27049 CONTINUE END IF I1=I IF(I1.GT.NPAR)THEN GOTO27041 END IF GOTO27040 27041 CONTINUE 27005 CONTINUE I7=I7+4+5*NATM GOTO27004 END IF RETURN END C-------CR26 SUBROUTINECR26 INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERI,L REALVAR REALSSS(3) INTEGERNCR261 CHARACTER*38 CR261 INTEGERNCR262 CHARACTER*30 CR262 INTEGERNCR263 CHARACTER*30 CR263 INTEGERNCR264 CHARACTER*42 CR264 INTEGERNCR265 CHARACTER*38 CR265 INTEGERNCR266 CHARACTER*16 CR266 INTEGERNCR267 CHARACTER*21 CR267 INTEGERNCR268 CHARACTER*21 CR268 INTEGERNCR269 CHARACTER*22 CR269 INTEGERNCR26A CHARACTER*30 CR26A INTEGERNCR26B CHARACTER*30 CR26B INTEGERNCR26C CHARACTER*30 CR26C INTEGERNCR270 CHARACTER*21 CR270 REAL FMT(9 ) DATANCR261/38 /, CR261/' STRUCTURE FACTOR SUMS BEFORE CYCLE 1'/ DATANCR262/30 /, CR262/' Rcode=1 Rcode=2'/ DATANCR263/30 /, CR263/'sum|FOBS| sum|FCAL| sum|FO-FC|'/ DATANCR264/42 /, CR264/'R-factor (using |F|)wR-factor (using |Y|) &'/ DATANCR265/38 /, CR265/' REFLECTIONS CONTRIBUTING TO LS MATRIX'/ DATANCR266/16 /, CR266/' ALL REFLECTIONS'/ DATANCR267/21 /, CR267/' Number of restraints'/ DATANCR268/21 /, CR268/' Number of variables '/ DATANCR269/22 /, CR269/' Number of reflections'/ DATANCR26A/30 /, CR26A/' Goodness of fit S with restr.'/ DATANCR26B/30 /, CR26B/' Rcode=1 Rcode>1'/ DATANCR26C/30 /, CR26C/' Sigma on g.o.f. S with restr '/ DATANCR270/21 /, CR270/'AFTER BEFORE CYCLE 1'/ DATAFMT/401522.,551522.,701522.,401552.,551552.,701552.,400613.,55 &0613.,700613./ LINRM=18 IF(ICYCLE.EQ.1)THEN CALLAA55(CR270,7,CR261,24,15,0) ELSE CALLAA55(CR270,1,CR261,24,6,0) CALLAA03(FLOAT(ICYCLE-1),1,CR261,380213.,1) END IF CALLAA55(CR263,27,CHROT,2,37,1) CALLAA04(1,CR261,NCR261,2,1) DO27000I=1,22,3 RSUMS(I+26)=RSUMS(I+1)-RSUMS(I+26) RSUMS(I+27)=RSUMS(I+2)-RSUMS(I+27) RSUMS(I)=RSUMS(I+1)+RSUMS(I+2) RSUMS(I+25)=RSUMS(I+26)+RSUMS(I+27) 27000 CONTINUE VAR=FLOAT(VARTOT) L=25 27002 CONTINUE DO27004I=1,3 L=L+1 R0(I)=0. RW(I)=0. SS(I)=0. SSS(I)=0. IF(ABS(RSUMS(L)).GT.5.0E-7)THEN R0(I)=RSUMS(L+6)/RSUMS(L) END IF IF(ABS(RSUMS(L+18)).GT.5.0E-7)THEN RW(I)=SQRT(RSUMS(L+15)/RSUMS(L+18)) END IF IF((RSUMS(L+21)-VAR).GT.5.0E-7)THEN SS(I)=SQRT(RSUMS(L+15)/(RSUMS(L+21)-VAR)) SSS(I)=SS(I)/SQRT(2.*(RSUMS(L+21)-VAR)) END IF 27004 CONTINUE L=L-2 IF(L.GT.25)THEN QX(MARK14+1)=(RSUMS(41)+RSUMS(60))/(RSUMS(47)+RSUMS(59)-VAR) CALLAA55(CR265,1,CHROT,1,NCR265,0) CALLAA04(1,' ',0,1,1) CALLAA55(CR262,1,CHROT,41,NCR262,0) CALLAA04(0,' ',0,1,1) ELSE CALLAA55(CR266,1,CHROT,1,NCR266,0) CALLAA04(1,' ',0,1,1) CALLAA55(CR26B,1,CHROT,41,NCR262,0) CALLAA04(0,' ',0,1,1) END IF CALLAA55(CR263,1,CHROT,2,10,0) CALLAA03(RSUMS,L,CHROT,FMT,3) CALLAA04(0,' ',0,1,1) CALLAA55(CR263,11,CHROT,2,10,0) CALLAA03(RSUMS,L+3,CHROT,FMT,3) CALLAA04(0,' ',0,1,1) CALLAA55(CR263,21,CHROT,2,10,0) CALLAA03(RSUMS,L+6,CHROT,FMT,3) CALLAA04(0,' ',0,1,1) CALLAA55(CR26A,1,CHROT,1,18,0) CALLAA03(SS,1,CHROT,FMT(4),3) CALLAA04(0,' ',0,1,1) CALLAA55(CR26C,1,CHROT,1,18,0) CALLAA03(SSS,1,CHROT,FMT(4),3) CALLAA04(0,' ',0,1,1) CALLAA55(CR264,1,CHROT,2,21,0) CALLAA03(R0,1,CHROT,FMT(4),3) CALLAA04(1,' ',0,1,1) CALLAA55(CR264,22,CHROT,2,21,0) CALLAA03(RW,1,CHROT,FMT(4),3) CALLAA04(0,' ',0,1,1) CALLAA55(CR268,1,CHROT,1,NCR268,0) RSUMS(L+25)=VAR CALLAA03(RSUMS,L+25,CHROT,FMT(7),1) CALLAA04(1,' ',0,1,1) CALLAA55(CR269,1,CHROT,1,NCR269,0) CALLAA03(RSUMS,L+21,CHROT,FMT(7),3) CALLAA04(0,' ',0,1,1) IF(RSUMS(59).GT.0.)THEN CALLAA55(CR267,1,CHROT,1,NCR267,0) CALLAA03(RSUMS(59),1,CHROT,FMT(7),1) CALLAA04(0,' ',0,1,1) CALLAA55(CR26A,1,CHROT,1,NCR26A,0) CALLAA03(SQRT(QX(MARK14+1)),1,CHROT,FMT(4),1) CALLAA04(0,' ',0,1,1) CALLAA55(CR26C,1,CHROT,1,NCR26C,0) CALLAA03(SQRT(QX(MARK14+1)/(2.*(RSUMS(47)+RSUMS(59)-VAR))),1,CHROT &,FMT(4),1) CALLAA04(0,' ',0,1,1) END IF IF(L.LT.25)THEN GOTO27003 END IF IF(TERMNT.NE.0)THEN IF((NINT(1000.*R0(1))+1).GT.TERMNT)THEN NCYCLE=ICYCLE+1 TERMNT=0 ELSE TERMNT=NINT(1000.*R0(1)) END IF END IF IF(ICYCLE.LT.NCYCLE)THEN GOTO27003 END IF IF(ABS((RSUMS(22))-(RSUMS(47))).LE.5.0E-7)THEN GOTO27003 END IF L=0 GOTO27002 27003 CONTINUE RETURN END C-------CR30 SUBROUTINECR30 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALFACT INTEGERI,J,K,P INTEGERL8 INTEGERL11,L11K,L11P,L11KK,L11KP,L11KJ,L11PK,L11PP,L11PJ INTEGERL12,L12K,L12P,L13,L13J,L13P INTEGERNBLK REALQ INTEGERVARBLK IF(ICYCLE.EQ.(NCYCLE-1))THEN IF(LISTMA.EQ.1)THEN LISTMA=2 ELSE IF(LISTMA.EQ.3)THEN LISTMA=4 END IF END IF IF(LISTMA.EQ.4)THEN CALLCR31(1) END IF IF(REFUOV.LT.0)THEN L11=MARK11+1 L12=MARK12+REFSKF+1 I=0 27000 IF(I.LT.REFSKF)THEN L11=L11+VARGEN-I I=I+1 GOTO27000 END IF QX(MARK14+2)=QX(L12)/QX(L11) QX(MARK14+3)=QX(MARK14+1)/QX(L11) END IF L11=MARK11 L12=MARK12 L13=MARK13 L8=MARK8+2 27003 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8)) VARBLK=NINT(QX(L8+1)) DO27006I=1,NBLK L11K=L11 DO27008K=1,VARBLK L11KK=L11K+K L12K=L12+K L11P=L11 P=1 27010 IF(P.LT.K)THEN L11PP=L11P+P L11PK=L11P+K L12P=L12+P Q=QX(L11PK)*QX(L11PP) DO27013J=K,VARBLK L11KJ=L11K+J L11PJ=L11P+J QX(L11KJ)=QX(L11KJ)-Q*QX(L11PJ) 27013 CONTINUE QX(L12K)=QX(L12K)-Q*QX(L12P) L11P=L11P+VARBLK-P P=P+1 GOTO27010 END IF IF(ABS((QX(L11KK))-(0.)).GT.5.0E-7)THEN QX(L11KK)=1./QX(L11KK) END IF L11K=L11K+VARBLK-K 27008 CONTINUE L11=L11K K=VARBLK 27015 IF(K.GE.1)THEN L11KK=L11K+K L12K=L12+K QX(L12K)=QX(L12K)*QX(L11KK) L11P=L11 P=VARBLK 27018 IF(P.GT.K)THEN L11PP=L11P+P L11KP=L11K+P L12P=L12+P L13P=L13+P QX(L13P)=QX(L11KK)*QX(L11KP) QX(L12K)=QX(L12K)-QX(L13P)*QX(L12P) IF(ICYCLE.NE.(NCYCLE-1))THEN GOTO27019 END IF QX(L11KP)=-QX(L13P)*QX(L11PP) J=P+1 27021 IF(J.LE.VARBLK)THEN L11PJ=L11P+J L11KJ=L11K+J L13J=L13+J QX(L11KP)=QX(L11KP)-QX(L13J)*QX(L11PJ) QX(L11KJ)=QX(L11KJ)-QX(L13P)*QX(L11PJ) J=J+1 GOTO27021 END IF L11P=L11P-VARBLK+P-1 27019 CONTINUE P=P-1 GOTO27018 END IF IF(ICYCLE.EQ.(NCYCLE-1))THEN J=K+1 27024 IF(J.LE.VARBLK)THEN L11KJ=L11K+J L13J=L13+J QX(L11KK)=QX(L11KK)-QX(L13J)*QX(L11KJ) J=J+1 GOTO27024 END IF END IF L11K=L11K-VARBLK+K-1 K=K-1 GOTO27015 END IF L11=L11+VARBLK L12=L12+VARBLK 27006 CONTINUE L8=L8+2 GOTO27003 END IF IF(LISTMA.EQ.4)THEN CALLCR31(2) ELSE IF(LISTMA.EQ.2)THEN IF(ABS((MALIST)-(0.)).LE.5.0E-7)THEN CALLCR31(3) ELSE CALLCR31(4) END IF END IF IF(SAVEMA.GT.0)THEN CALLCR31(5) END IF L11=MARK11+1 L13=MARK13+1 FACT=QX(MARK14+1) L8=MARK8+2 27027 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8)) VARBLK=NINT(QX(L8+1)) DO27030I=1,NBLK DO27032K=1,VARBLK QX(L13)=SQRT(ABS(QX(L11)*FACT)) L11=L11+VARBLK-K+1 L13=L13+1 27032 CONTINUE 27030 CONTINUE L8=L8+2 GOTO27027 END IF RETURN END C-------CR31 SUBROUTINECR31(KEY) INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL REALFORM(13) INTEGERI INTEGERIP,IPT INTEGERJ,K INTEGERKEY INTEGERL5,L8,L9,L10 INTEGERL11,L11K,L11P,L12 INTEGERLEN INTEGERNBLK INTEGERNBLOCK INTEGERMW INTEGERNW1 INTEGERP INTEGERPACK,PACKMX INTEGERREC INTEGERRLEN INTEGERVARBLK INTEGERNCR311 CHARACTER*56 CR311 INTEGERNCR312 CHARACTER*13 CR312 INTEGERNCR313 CHARACTER*82 CR313 REAL FORM1(4 ) INTEGER IPMX DATANCR311/56 /, CR311/'DIRECT MATRIX INVERTED MATRIX CORR &ELATION MATRIX'/ DATANCR312/13 /, CR312/' BLOCK VECTOR'/ DATANCR313/82 /, CR313/' BLOCK $, VARIABLE - VARIABLE & $,CORRELATION COEFFICIENT '/ DATAFORM1/780632.,130313.,280413.,430413./ DATAIPMX/0/ MW=IOSPEC(2)/10 DO27000K=1,MW FORM(K)=FLOAT(K*100000+931) 27000 CONTINUE IF((KEY.NE.2).OR.(ICYCLE.EQ.(NCYCLE-1)))THEN IF(KEY.LE.4)THEN K=KEY*19-18 IF(KEY.EQ.4)THEN K=K-19 END IF CALLAA55(CR311,K,CHROT,2,19,0) LINRM=8 CALLAA04(1,' ',0,1,3) ELSE IOMARK(4)=MARK15 IF(MARK15+2048.GT.QXCUR)THEN IQXY=MAX(MARK15+2048,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR3120',0) END IF DO27002IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27002 CONTINUE QXCUR=IQXY END IF I=MARK15+2048 PACKMX=2044 PACK=4 REC=2 PACK=PACK+7 CALLAA11(4,REC,PACK,IP) CALLAA56(TITLE,10,QX(IP+1),1,6,0) CALLAA56(TITLE,17,QX(IP+1),9,8,0) IPT=IP+PACK QX(IPT-6)=QX(MARK8+1) QX(IPT-5)=NONATM QX(IPT-4)=MARK5 QX(IPT-3)=MARK6-MARK5 QX(IPT-2)=MARK9-MARK8 QX(IPT-1)=MARK10-MARK9 QX(IPT)=MARK11-MARK10 RLEN=MARK6-MARK5 L5=MARK5+1 REC=REC+1 27004 CONTINUE IF(RLEN.LE.0)THEN GOTO27005 END IF PACK=MIN0(RLEN,PACKMX) CALLAA11(4,REC,PACK,IP) CALLAA51(QX,L5,QX,IP+1,PACK,1) L5=L5+PACK RLEN=RLEN-PACK GOTO27004 27005 CONTINUE RLEN=MARK9-MARK8 L8=MARK8+1 REC=REC+1 27006 CONTINUE IF(RLEN.LE.0)THEN GOTO27007 END IF PACK=MIN0(RLEN,PACKMX) CALLAA11(4,REC,PACK,IP) CALLAA51(QX,L8,QX,IP+1,PACK,1) L8=L8+PACK RLEN=RLEN-PACK GOTO27006 27007 CONTINUE RLEN=MARK10-MARK9 L9=MARK9+1 REC=REC+1 27008 CONTINUE PACK=MIN0(RLEN,PACKMX) IF(RLEN.LE.0)THEN GOTO27009 END IF CALLAA11(4,REC,PACK,IP) CALLAA51(QX,L9,QX,IP+1,PACK,1) L9=L9+PACK RLEN=RLEN-PACK GOTO27008 27009 CONTINUE RLEN=MARK11-MARK10 L10=MARK10+1 REC=REC+1 27010 CONTINUE PACK=MIN0(RLEN,PACKMX) IF(RLEN.LE.0)THEN GOTO27011 END IF CALLAA11(4,REC,PACK,IP) CALLAA51(QX,L10,QX,IP+1,PACK,1) L10=L10+PACK RLEN=RLEN-PACK GOTO27010 27011 CONTINUE END IF NBLOCK=0 L11=MARK11+1 L8=MARK8+2 27012 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8)) VARBLK=NINT(QX(L8+1)) DO27015I=1,NBLK NBLOCK=NBLOCK+1 IF(KEY.LE.3)THEN CALLAA55(CR312,2,CHROT,2,5,0) CALLAA03(FLOAT(NBLOCK),1,CHROT,90213.,1) CALLAA04(0,' ',0,1,3) ELSE IF(KEY.EQ.5)THEN LEN=(VARBLK+1)*VARBLK/2 PACK=MIN0(LEN+1,PACKMX) REC=REC+1 CALLAA11(4,REC,PACK,IP) IPMX=IP+PACKMX IP=IP+1 QX(IP)=FLOAT(VARBLK) END IF DO27017K=1,VARBLK L11K=L11 L11P=L11 DO27019P=K,VARBLK,MW NW1=MIN0(MW,VARBLK-P+1) DO27021J=1,NW1 IF(KEY.LE.2)THEN BUFOT(J)=QX(L11) ELSE IF(QX(L11K)*QX(L11P).LE.0.)THEN BUFOT(J)=0. ELSE BUFOT(J)=QX(L11)/SQRT(QX(L11K)*QX(L11P)) END IF IF(KEY.EQ.4)THEN IF((ABS(BUFOT(J)).GT.MALIST).AND.(L11.NE.L11K))THEN BUFOT(J+1)=FLOAT(NBLOCK) BUFOT(J+2)=FLOAT(K) BUFOT(J+3)=FLOAT(P+J-1) CALLAA03(BUFOT,J,CR313,FORM1,4) CALLAA04(0,CR313,NCR313,3,3) END IF END IF IF(KEY.EQ.5)THEN IF(IP.GE.IPMX)THEN CALLAA11(4,REC,PACK,IP) END IF IP=IP+1 QX(IP)=BUFOT(J) END IF L11=L11+1 L11P=L11P+VARBLK-P-J+2 27021 CONTINUE IF(KEY.LE.3)THEN CALLAA03(BUFOT,1,CHROT,FORM,NW1) CALLAA04(0,' ',0,1,3) END IF 27019 CONTINUE 27017 CONTINUE 27015 CONTINUE L8=L8+2 GOTO27012 END IF IF(KEY.EQ.5)THEN CALLAA11(4,65535,3,IP) END IF END IF IF(KEY.LE.2)THEN CALLAA55(CR312,8,CHROT,2,6,0) LINRM=4 CALLAA04(1,' ',0,1,3) L12=MARK12+1 27023 IF(L12.LE.MARK13-2)THEN NW1=MIN0(MW,MARK13-L12-1) CALLAA03(QX,L12,CHROT,FORM,NW1) CALLAA04(0,' ',0,1,3) L12=L12+MW GOTO27023 END IF END IF RETURN END C-------CR36 SUBROUTINECR36 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(117 )CH INTEGERBFMAX REALCOSPHI,COSPSI,COSTHE INTEGERI,I1,I6,IH,IHF,IIII,IP,IPP INTEGERICH INTEGERIGR INTEGERIREL(101) INTEGERIWANT(100) INTEGERJ INTEGERK,K1 INTEGERL,L1,L2,L3,L4,L12,L13 INTEGERN INTEGERNATGR INTEGERNDISP INTEGERNPAR INTEGERNSKF INTEGERNXABS INTEGERNXT INTEGERPACK INTEGERPAR INTEGERPAR1 REALPHI REALPSI INTEGERREC INTEGERREF INTEGERSGNL(4) REALSINPHI,SINPSI,SINTHE REALTHETA INTEGERVAR INTEGERNCR361 CHARACTER*34 CR361 INTEGERNCR362 CHARACTER*47 CR362 INTEGERNCR363 CHARACTER*25 CR363 INTEGERNCR364 CHARACTER*35 CR364 INTEGERNCR365 CHARACTER*63 CR365 INTEGERNCR366 CHARACTER*34 CR366 INTEGERNCR367 CHARACTER*40 CR367 INTEGERNCR368 CHARACTER*8 CR368 REAL FORM(11 ) REAL RAD INTEGER M DATANCR361/34 /, CR361/' PARAMETERS AFTER CYCLE (U*100)'/ DATANCR362/47 /, CR362/' SKF UOV EXT DISP SCALE BOV EXT RHO & XABS'/ DATANCR363/25 /, CR363/'-OLD D NEW SD D/SD '/ DATANCR364/35 /, CR364/' TOTAL LEAST SQUARES CYCLES = XXXXX'/ DATANCR365/63 /, CR365/'***GROUP ***CENTER OF GRAVITY EULER ANG &LES (PHI, THETA, PSI)'/ DATANCR366/34 /, CR366/' FINAL FREL SCALE '/ DATANCR367/40 /, CR367/'Less-thans defined by |Fo| < 0 esd(|Fo|)'/ DATANCR368/8 /, CR368/'FoF2IoFh'/ DATAFORM/241052.,341052.,441052.,541052.,641052.,741052.,841052.,9 &41052.,1041052.,1141052.,1241052./ DATARAD/57.29579/ DATAM/0/ CALLAA14(8,1) ICYCLE=ICYCLE+1 IF(ICYCLE.LT.NCYCLE)THEN CALLAA12(1,20,PACK,IP,0) ELSE LIST=LIST+1 PNCHCD=PNCHCD+1 IOMARK(2)=MARK15 IF(MARK15+2048.GT.QXCUR)THEN IQXY=MAX(MARK15+2048,QXCUR)+1000 IF(IQXY.GT.QXMAX)THEN CALLAA06('CR3620',0) END IF DO27000IQXZ=QXCUR+1,IQXY QX(IQXZ)=0. 27000 CONTINUE QXCUR=IQXY END IF I=MARK15+2048 CALLAA13(1,2,1,3) END IF NSKF=(MARK4-MARK3)/2 NXABS=0 NXT=0 NDISP=0 IF(REFABS.GT.0)THEN NXABS=1 END IF IF(REFEXT.GT.0)THEN IF(EXTTYP.LE.2)THEN NXT=1 ELSE IF(EXTTYP.EQ.3)THEN NXT=2 ELSE IF(EXTTYP.LE.5)THEN NXT=6 ELSE NXT=12 END IF IF(EXTTYP.LT.2.OR.EXTTYP.EQ.3)THEN L4=MARK4+2 ELSE IF(EXTTYP.EQ.2)THEN L4=MARK4+3 ELSE IF(EXTTYP.EQ.4.OR.EXTTYP.EQ.6)THEN L4=MARK4+4 ELSE L4=MARK4+10 END IF END IF IF(REFDSP.GT.0)THEN NDISP=2*NATTYP END IF NPAR=NSKF+1+NXABS+NXT+NDISP K1=1 L1=1 L2=MARK2 L3=MARK3 L12=MARK12+1 L13=MARK13+1 IF(ICYCLE.LT.NCYCLE)THEN BFMAX=30 ELSE BFMAX=50 END IF DSDMAX=0. DSDAVE=0. DSDNUM=0. LINRM=10 CALLAA03(FLOAT(ICYCLE-1),1,CR361,260213.,1) CALLAA55(CR363,1,CHROT,2,NCR361-1,1) CALLAA04(2,CR361,NCR361,2,3) ICH=10 I=0 IHF=1 DO27002PAR=1,NPAR IF(I.EQ.0)THEN CALLAA55(BLANK,1,CH,1,IOSPEC(2),1) END IF ICH=ICH+10 I=I+1 I1=I REF=0 BUFOT(I+30)=-1. IF(PAR.LE.NSKF)THEN CALLAA55(CR362,1,CH,ICH,5,0) BUFOT(I)=1./QX(L3+1) IF(REFSKF.GT.0)THEN IF(REFSKF.GT.1.OR.PAR.EQ.NSKF)THEN REF=1 END IF BUFOT(I+10)=QX(L12)*BUFOT(I) BUFOT(I+20)=BUFOT(I)+DAMP*BUFOT(I+10) QX(L3+1)=1./BUFOT(I+20) BUFOT(I+30)=QX(L13)*BUFOT(I) END IF IF(PNCHCD.GT.1)THEN CALLAA55(CR362,23,CHROT,1,5,0) CALLAA03(QX,L3+1,CHROT,FORM(1),2) CALLAA57(QX(MARK1+1),129,CHROT,40,12,0) IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CALLAA55(BLANK,1,CHROT,1,80,1) END IF L3=L3+2 ELSE IF(PAR.EQ.NSKF+1)THEN CALLAA55(CR362,6,CH,ICH,5,0) BUFOT(I)=BTOHU*QX(MARK4+1) BUFOT(50)=0.01*BUFOT(I) IF(REFUOV.NE.0)THEN REF=1 BUFOT(I+10)=BTOHU/CELL(1)*QX(L12) IF(REFUOV.GT.0)THEN QX(MARK4+1)=QX(MARK4+1)+DAMP/CELL(1)*QX(L12) END IF IF(QX(MARK4+1).LE.0..AND.TMPTST.EQ.0)THEN QX(MARK4+1)=0.1 END IF BUFOT(I+20)=BTOHU*QX(MARK4+1) BUFOT(I+30)=BTOHU/CELL(1)*QX(L13) BUFOT(50)=0.01*BUFOT(I+20) END IF IF(PNCHCD.GT.1)THEN CALLAA55(CR362,8,CHROT,1,3,0) CALLAA03(BUFOT(50),1,CHROT,FORM(1),1) CALLAA57(QX(MARK1+1),129,CHROT,40,12,0) IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CALLAA55(BLANK,1,CHROT,1,80,1) END IF ELSE IF(PAR.EQ.NSKF+1+NXABS)THEN CALLAA55(CR362,43,CH,ICH,5,0) BUFOT(I)=XABS IF(REFABS.EQ.2)THEN REF=1 BUFOT(I+10)=QX(L12) XABS=XABS+DAMP*BUFOT(I+10) BUFOT(I+20)=XABS BUFOT(I+30)=QX(L13) XABSIG=QX(L13) END IF IF(PNCHCD.GT.1)THEN CALLAA55(CR362,44,CHROT,1,4,0) CALLAA03(XABS,1,CHROT,FORM(1),1) CALLAA57(QX(MARK1+1),129,CHROT,40,12,0) IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CALLAA55(BLANK,1,CHROT,1,80,1) END IF ELSE IF(PAR.LE.NSKF+1+NXABS+NXT)THEN IF(EXTTYP.LE.1)THEN IH=32 ELSE IF(EXTTYP.EQ.2)THEN IH=37 ELSE IF(EXTTYP.EQ.3)THEN IF(IHF.EQ.1)THEN IH=32 ELSE IH=37 END IF IHF=-IHF END IF CALLAA55(CR362,IH,CH,ICH,5,0) BUFOT(I)=QX(L4) IF(REFEXT.GT.1)THEN REF=1 BUFOT(I+10)=QX(L12) BUFOT(I+20)=BUFOT(I)+DAMP*BUFOT(I+10) BUFOT(I+20)=AMAX1(BUFOT(I+20),0.0) BUFOT(I+30)=QX(L13) QX(L4)=BUFOT(I+20) EXTESD=BUFOT(I+30) END IF L4=L4+1 ELSE IF(K1.GT.0)THEN CALLAA55(CR362,17,CH,ICH,5,0) BUFOT(I)=QX(L2+1) ELSE CALLAA57(QX(MARK1+1),L1,CH,ICH,8,0) L1=L1+8 BUFOT(I)=QX(L2+2) END IF IF(QX(L2+3).GT.0.)THEN REF=1 BUFOT(I+10)=QX(L12) BUFOT(I+20)=BUFOT(I)+DAMP*BUFOT(I+10) IF(K1.GT.0)THEN QX(L2+1)=BUFOT(I+20) ELSE QX(L2+2)=BUFOT(I+20) END IF BUFOT(I+30)=QX(L13)*BUFOT(I) END IF K1=-K1 IF(K1.GT.0)THEN L2=L2+NSTEP2 END IF END IF IF(REF.EQ.1)THEN L12=L12+1 L13=L13+1 END IF IF(BUFOT(I1+30).GT..0)THEN BUFOT(I1+40)=ABS(BUFOT(I1+10))/BUFOT(I1+30) DSDMAX=AMAX1(DSDMAX,BUFOT(I1+40)) DSDAVE=DSDAVE+BUFOT(I1+40) DSDNUM=DSDNUM+1. END IF IF((ICH+34.GT.IOSPEC(2)).OR.(PAR.EQ.NPAR))THEN LINRM=6 CALLAA04(1,CH,ICH+5,3,3) K=2 PAR1=I DO27004J=1,BFMAX,10 CALLAA55(CR363,K,CHROT,2,4,0) K=K+4 L=J-1 DO27006I=1,PAR1 L=L+1 IF((J.EQ.1).OR.(BUFOT(I+30).GT.-0.))THEN CALLAA03(BUFOT,L,CHROT,FORM(I),1) END IF 27006 CONTINUE CALLAA04(0,' ',0,1,3) IF(VARGEN.EQ.0)THEN GOTO27005 END IF 27004 CONTINUE 27005 CONTINUE ICH=10 I=0 END IF 27002 CONTINUE IF(ICYCLE.EQ.NCYCLE)THEN DO27008I=1,20 CALLAA12(1,4,PACK,IP,2) IF(IP.LE.0)THEN GOTO27009 END IF CALLAA11(2,4,PACK,IPP) CALLAA51(QX,IP+1,QX,IPP+1,PACK,1) IP=IPP IF(I.NE.6)THEN GOTO27008 END IF QX(IP+4)=QX(IP+4)+FLOAT(NCYCLE-1) TCYCLE=QX(IP+4) CALLAA03(QX(IP+4),1,CR364,350513.,1) CALLAA04(1,CR364,NCR364,3,5) 27008 CONTINUE 27009 CONTINUE CALLAA13(1,2,5,10) DO27010REC=11,12 IWANT(1)=1 SGNL(1)=0 SGNL(2)=1 SGNL(4)=0 IF(REC.EQ.11)THEN L=MARK3+2 DO27012J=1,NSKF IWANT(J+1)=NINT(QX(L))+100 L=L+2 27012 CONTINUE SGNL(3)=NSKF+1 IF(TYPELT.GT.0.)THEN DO27014J=1,10 IWANT(J+NSKF+1)=532 27014 CONTINUE SGNL(3)=SGNL(3)+10 END IF ELSE IWANT(2)=2 DO27016J=1,4 IWANT(J+2)=100+J 27016 CONTINUE IWANT(7)=117 IWANT(8)=3 IWANT(9)=87 IWANT(10)=88 SGNL(3)=10 END IF CALLAA15(1,REC,PACK,IP,2,SGNL,IWANT,IREL) 27018 CONTINUE CALLAA12(1,REC,PACK,IP,2) IF(IP.LE.0)THEN GOTO27019 END IF CALLAA11(2,REC,PACK,IPP) CALLAA51(QX,IP+1,QX,IPP+1,PACK,0) CALLAA51(0.,1,QX,IPP+PACK+1,(SGNL(4)-PACK),1) M=IP+IREL(1) IF(M.GT.IP)THEN IF(NINT(QX(M)).NE.DATSET)THEN GOTO27018 END IF END IF IF(REC.EQ.11)THEN L=MARK3+1 DO27020J=1,NSKF M=IPP+IREL(J+1) QX(M)=QX(L) CALLAA03(QX,L,CR366,321052.,1) CALLAA03(QX,L+1,CR366,200213.,1) CALLAA04(1,CR366,NCR366,3,3) L=L+2 27020 CONTINUE IF(TYPELT.GT.0.)THEN CALLAA55(CR368,2*RFLTYP+1,CR367,24,2,0) CALLAA55(CR368,2*RFLTYP+1,CR367,37,2,0) CALLAA03(TYPELT,1,CR367,300113.,1) CALLAA56(CR367,1,QX(IPP+IREL(NSKF+2)),1,40,0) END IF ELSE M=IPP+IREL(2) QX(M)=BTOU*QX(MARK4+1) IF(REFEXT.GT.0)THEN IF(EXTTYP.EQ.0)THEN QX(MARK4+3)=QX(MARK4+2) END IF M=IPP+IREL(3) QX(M)=FLOAT(EXTTYP) M=IPP+IREL(4) QX(M)=FLOAT(DSTEXT) M=IPP+IREL(5) QX(M)=QX(MARK4+2)*10000. M=IPP+IREL(6) QX(M)=QX(MARK4+3)*10000. M=IPP+IREL(7) QX(M)=QX(MARK4+22) END IF IF(REFABS.GT.1)THEN M=IPP+IREL(8) QX(M)=XABS END IF M=IPP+IREL(9) QX(M)=TYPELT M=IPP+IREL(10) QX(M)=FLOAT(RFLTYP+1) END IF GOTO27018 27019 CONTINUE 27010 CONTINUE CALLAA13(1,2,13,15) END IF I6=MARK6 IGR=0 27022 IF(I6.LT.MARK7)THEN IGR=IGR+1 IF(QX(I6+2).LT.1.5)THEN NATGR=NINT(QX(I6+1)) ELSE I1=NINT(QX(I6+1)) NATGR=NINT(QX(I1+1)) END IF IF(ABS((QX(I6+2))-(1.)).LE.5.0E-7)THEN I6=I6+ISTEP6+NATGR*NSTEP6 GOTO27022 END IF CALLAA55(CR365,1,CHROT,2,15,0) CALLAA03(FLOAT(IGR),1,CHROT,120213.,1) LINRM=12 CALLAA04(1,' ',0,1,3) I1=I6+2 DO27024N=1,2 ICH=22 DO27026J=1,3 I1=I1+1 BUFOT(J)=QX(I1) VAR=NINT(QX(I1+6)) IF(VAR.EQ.0)THEN BUFOT(J+10)=-1000. ELSE L=MARK12+VAR BUFOT(J+10)=QX(L) QX(I1)=QX(I1)+DAMP*QX(L) BUFOT(J+20)=QX(I1) ICH=2 IF(ICYCLE.LT.NCYCLE)THEN GOTO27026 END IF L=MARK13+VAR BUFOT(J+30)=QX(L) BUFOT(J+40)=ABS(BUFOT(J+10))/BUFOT(J+30) DSDMAX=AMAX1(DSDMAX,BUFOT(J+40)) DSDAVE=DSDAVE+BUFOT(J+40) DSDNUM=DSDNUM+1. END IF 27026 CONTINUE CALLAA04(0,' ',0,1,3) IF(N.EQ.1)THEN CALLAA55(CR365,16,CHROT,2,17,0) ELSE CALLAA55(CR365,34,CHROT,2,30,0) DO27028J=1,BFMAX,10 IF(J.GT.40)THEN GOTO27029 END IF BUFOT(J)=RAD*BUFOT(J) BUFOT(J+1)=RAD*BUFOT(J+1) BUFOT(J+2)=RAD*BUFOT(J+2) 27028 CONTINUE 27029 CONTINUE END IF DO27030J=1,BFMAX,10 CALLAA55(CR363,ICH,CHROT,40,4,0) L=J-1 DO27032I=1,3 L=L+1 IF((J.EQ.1).OR.(BUFOT(I+10).GT.-999.0))THEN CALLAA03(BUFOT,L,CHROT,FORM(I+3),1) END IF 27032 CONTINUE CALLAA04(0,' ',0,1,1) IF(ICH.EQ.22)THEN GOTO27031 END IF ICH=ICH+4 27030 CONTINUE 27031 CONTINUE 27024 CONTINUE PHI=QX(I6+6) THETA=QX(I6+7) PSI=QX(I6+8) COSPHI=COS(PHI) SINPHI=SIN(PHI) COSTHE=COS(THETA) SINTHE=SIN(THETA) COSPSI=COS(PSI) SINPSI=SIN(PSI) QX(I6+22)=COSPSI*COSPHI-SINPSI*COSTHE*SINPHI QX(I6+23)=-SINPSI*COSPHI-COSPSI*COSTHE*SINPHI QX(I6+24)=SINTHE*SINPHI QX(I6+25)=COSPSI*SINPHI+SINPSI*COSTHE*COSPHI QX(I6+26)=-SINPSI*SINPHI+COSPSI*COSTHE*COSPHI QX(I6+27)=-SINTHE*COSPHI QX(I6+28)=SINPSI*SINTHE QX(I6+29)=COSPSI*SINTHE QX(I6+30)=COSTHE IIII=I6+20 I6=I6+ISTEP6+NATGR*NSTEP6 GOTO27022 END IF RETURN END C-------CR37 SUBROUTINECR37 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(117 )CH CHARACTER*(24 )NAME REALAPOP INTEGERBFMAX REALDELB(6) REALDELBOV REALFACT REALFACT1 REALFFACT REALFLACT INTEGERFLAG REALFORM(2) INTEGERGROUP INTEGERI,I1,I2,I3,I6,I6FRST,IADD,IP INTEGERIREL(71) INTEGERIWANT(70) INTEGERJ,J1,JJL,JJP INTEGERK,K1,K12,K13 INTEGERL,L5,L6,L8,L11,L11BLK,L12,L13,LL5 INTEGERLCON INTEGERM,M1,M2 INTEGERN,N0,N1,N2,N9 INTEGERNATGR INTEGERNBLK INTEGERNC INTEGERNCH INTEGERNCH1,NCH2,NCH3 INTEGERNTMP INTEGERP INTEGERPACK INTEGERPAR INTEGERPARTOT INTEGERPCON INTEGERPRNT REALQ,Q1,Q2,Q3 INTEGERS REALSIGBOV REALSIGB(6) INTEGERSGNL(4) INTEGERVAR INTEGERVAR0 REALXC,YC,ZC INTEGERNCR371 CHARACTER*30 CR371 INTEGERNCR372 CHARACTER*25 CR372 INTEGERNCR373 CHARACTER*55 CR373 INTEGERNCR374 CHARACTER*25 CR374 INTEGERNCR375 CHARACTER*30 CR375 INTEGERNCR376 CHARACTER*30 CR376 REAL FMT2(6 ) REAL FMT3(3 ) INTEGER ISKIP INTEGER L9 INTEGER VARBLK DATANCR371/30 /, CR371/' X Y ZU11U22U33U12U13U23POP'/ DATANCR372/25 /, CR372/'-OLD D NEW SD D/SDATOM'/ DATANCR373/55 /, CR373/' UIJ MATRIX FOR ATOM IS NOT POSIT &IVE DEFINITE.'/ DATANCR374/25 /, CR374/' SHIFTS ARE MULTIPLIED BY'/ DATANCR375/30 /, CR375/' MAXIMUM SHIFT/ERROR '/ DATANCR376/30 /, CR376/' AVERAGE SHIFT/ERROR '/ DATAFMT2/952.,952.,952.,952.,952.,952./ DATAFMT3/752.,752.,752./ DATAISKIP/0/ DATAL9/0/ DATAVARBLK/0/ CH=' ' IF(REFTMP.GE.4)THEN PAR=9 ELSE IF(REFTMP.GT.0)THEN PAR=4 ELSE PAR=3 END IF LCHROT=LABMAX+8 NC=MIN0((IOSPEC(2)-LCHROT-5*REFPOP)/PAR,10) IF(NC.GE.8)THEN CH(2:5)='ATOM' NCH=LCHROT-4 NCH1=2 NCH2=LABMAX+4 ELSE NCH=2 NCH1=7 NCH2=2 NC=8 END IF K=-2 DO27000I=1,PAR K=K+3 NCH=NCH+NC IF(I.EQ.4.AND.PAR.EQ.4)THEN CH(NCH:NCH+2)=' U' ELSE CALLAA55(CR371,K,CH,NCH,3,0) END IF 27000 CONTINUE FORM(1)=FLOAT(NC*100+52) IF(REFPOP.EQ.1)THEN NCH3=NCH+2 NCH=NCH+NC-3 CH(NCH:NCH+2)='POP' FORM(2)=FORM(1)-110. END IF NCH=NCH+3 BFMAX=30 PARTOT=PAR+REFPOP IF(ICYCLE.EQ.NCYCLE)THEN IWANT(1)=14 IWANT(2)=17 IWANT(3)=22 IWANT(4)=215 K=4 ISKIP=1 DO27002I=1,11 J=K+I IWANT(J)=I IWANT(J+12)=I+100 S=1 IF(I.GE.5.AND.I.LE.10.AND.REFTMP.LT.4)THEN S=-1 END IF IF(I.EQ.11.AND.POP.EQ.0)THEN S=-1 END IF IWANT(J+23)=S*I IWANT(J+35)=S*(100+I) IF(S.GT.0)THEN ISKIP=ISKIP+1 END IF 27002 CONTINUE J=J+1 IWANT(J)=23 SGNL(1)=1 SGNL(2)=K+23 IWANT(J+23)=23 SGNL(3)=K+46 SGNL(4)=1 IF(ADDOLD.GT.0)THEN DO27004IADD=1,11 IF(IWANT(IADD+27).GT.0)THEN SGNL(3)=SGNL(3)+1 SGNL(4)=1 IWANT(SGNL(3))=300+IADD END IF 27004 CONTINUE END IF CALLAA15(1,16,PACK,IP,2,SGNL,IWANT,IREL) BFMAX=50 END IF IF(REFUOV.LT.0)THEN L12=MARK12+REFSKF+1 L13=MARK13+REFSKF+1 DELBOV=(QX(L12)-QX(MARK14+2))/CELL(1) SIGBOV=(QX(L13)*QX(L13)-QX(MARK14+3))/(CELL(1)*CELL(1)) DO27006J=1,6 DELB(J)=DELBOV*CELL(J) SIGB(J)=SIGBOV*CELL(J)*CELL(J) 27006 CONTINUE END IF LCON=MARK10 LCON=LCON+0 PCON=NINT(QX(LCON+1)) IF(BLKTYP.EQ.3)THEN L9=MARK9+1 N9=NINT(QX(L9)) L12=MARK12+N9 L13=MARK13+N9 ELSE N9=0 L12=MARK12+VARGEN+1 L13=MARK13+VARGEN+1 END IF IF((MARK10+1.NE.MARK11).OR.(BLKTYP.EQ.3))THEN FLAG=1 ELSE FLAG=0 END IF GROUP=0 CALLAA04(0,' ',0,1,3) LINRM=7 L5=MARK5+7 27008 IF(L5.LT.MARK6)THEN CALLAA57(QX(L5-6),1,NAME,1,24,0) CALLAA74(QX(L5+1),NTMP,5,3) PAR=3+NTMP+POP VAR=3+NTMP+REFPOP PRNT=1 CALLAA51(-1000.,1,BUFOT,1,40,2) CALLAA51(QX,L5+2,BUFOT,1,PAR,0) IF(FLAG.EQ.0)THEN CALLAA51(QX,L12,BUFOT,11,VAR,0) CALLAA51(QX,L13,BUFOT,31,VAR,0) L12=L12+VAR L13=L13+VAR ELSE IF(-PCON.EQ.L5)THEN PRNT=0 LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE DO27011I=1,VAR IF(IABS(PCON).NE.L5+I+1)THEN BUFOT(I+10)=QX(L12) BUFOT(I+30)=QX(L13) L12=L12+1 L13=L13+1 IF((L5+I+1.EQ.-N9).OR.(N9.GT.0))THEN L9=L9+1 N9=NINT(QX(L9)) IF(N9.GT.0)THEN L12=MARK12+N9 L13=MARK13+N9 END IF END IF ELSE IF(PCON.LT.0)THEN LCON=LCON+1 PCON=NINT(QX(LCON+1)) ELSE N0=NINT(QX(LCON+2)) IF(N0.GT.0)THEN L12=L12+N0 L13=L13+N0 END IF N1=NINT(QX(LCON+3)) N2=NINT(QX(LCON+4)) J=LCON+4 Q=0. Q1=0. 27013 CONTINUE K=NINT(QX(J+1)) K12=MARK12+K K13=MARK13+K IF(N2.GT.1)THEN FACT=QX(J+2) ELSE FACT=-1. END IF IF((N0.LT.0).OR.(I.GT.3))THEN Q=Q+FACT*QX(K12) ELSE GROUP=1 END IF Q1=Q1+FACT*FACT*QX(K13)*QX(K13) J=J+N2 IF(J-LCON.GE.N1)THEN GOTO27014 END IF VAR0=0 L11BLK=MARK11 L8=MARK8+2 27015 IF(L8.LT.MARK9)THEN NBLK=NINT(QX(L8)) VARBLK=NINT(QX(L8+1)) N=1 27018 IF(N.LE.NBLK)THEN IF((VAR0+VARBLK).GE.K)THEN GOTO27020 END IF VAR0=VAR0+VARBLK L11BLK=L11BLK+(VARBLK+1)*VARBLK/2 N=N+1 GOTO27018 27020 CONTINUE END IF IF(N.LE.NBLK)THEN GOTO27017 END IF L8=L8+2 GOTO27015 27017 CONTINUE END IF L=LCON L=J 27021 IF(L.LT.N1)THEN K1=NINT(QX(L+1)) IF(K1.GT.(VAR0+VARBLK))THEN GOTO27022 END IF IF(N2.GT.1)THEN FACT1=QX(L+2) ELSE FACT1=-1. END IF M1=K-VAR0 M2=K1-VAR0 L11=L11BLK M=1 27024 IF(M.LT.M1)THEN L11=L11+VARBLK-M M=M+1 GOTO27024 END IF L11=L11+M2 Q1=Q1+2.*FACT*FACT1*QX(L11)*QX(MARK14+1) 27022 CONTINUE L=L+N2 GOTO27021 END IF GOTO27013 27014 CONTINUE BUFOT(I+10)=Q BUFOT(I+30)=SQRT(Q1) LCON=LCON+N1 PCON=NINT(QX(LCON+1)) END IF 27011 CONTINUE END IF END IF IF(REFUOV.LT.0)THEN I=1 27027 IF(I.LE.NTMP)THEN IF(BUFOT(I+13).LT.-999.)THEN GOTO27028 END IF BUFOT(I+13)=BUFOT(I+13)+DELB(I) IF(ICYCLE.LT.NCYCLE)THEN GOTO27028 END IF BUFOT(I+33)=SQRT(BUFOT(I+33)*BUFOT(I+33)+SIGB(I)) 27028 CONTINUE I=I+1 GOTO27027 END IF END IF IF((NTMP.EQ.1).AND.(BUFOT(14).GT.-999))THEN BUFOT(14)=BUFOT(14)/CELL(1) BUFOT(34)=BUFOT(34)/CELL(1) END IF DO27030I=1,VAR IF(BUFOT(I+10).LT.-999.)THEN GOTO27030 END IF M=L5+1+I QX(M)=QX(M)+DAMP*BUFOT(I+10) BUFOT(I+20)=QX(M) 27030 CONTINUE IF(GROUP.EQ.1)THEN I6=MARK6 27032 IF(I6.LT.MARK7)THEN IF(QX(I6+2).LT.1.5)THEN NATGR=NINT(QX(I6+1)) ELSE I6FRST=NINT(QX(I6+1)) NATGR=NINT(QX(I6FRST+1)) END IF IF(ABS((QX(I6+2))-(1.)).LE.5.0E-7)THEN I6=I6+ISTEP6+NATGR*NSTEP6 GOTO27032 END IF IF(ABS((QX(I6+2))-(2.)).LE.5.0E-7)THEN L6=I6+ISTEP6 IF(L5.EQ.NINT(QX(L6+1)))THEN XC=QX(I6FRST+3) YC=QX(I6FRST+4) ZC=QX(I6FRST+5) DO27034J=3,5 QX(I6FRST+J)=0. 27034 CONTINUE L6=I6FRST+ISTEP6 DO27036I=1,NATGR LL5=NINT(QX(L6+1))-1 DO27038J=3,5 QX(I6FRST+J)=QX(I6FRST+J)+QX(L6+6)*QX(LL5+J) 27038 CONTINUE L6=L6+NSTEP6 27036 CONTINUE L6=I6FRST+ISTEP6 DO27040J=3,5 QX(I6FRST+J)=QX(I6FRST+J)/QX(L6+7) 27040 CONTINUE DO27042I=1,NATGR I1=11 LL5=NINT(QX(L6+1))+1 DO27044J=1,3 I1=I1+1 QX(L6+2+J)=CELL(I1+1)*(QX(LL5+1)-XC)+CELL(I1+4)*(QX(LL5+2)-YC)+CEL &L(I1+7)*(QX(LL5+3)-ZC) 27044 CONTINUE L6=L6+NSTEP6 27042 CONTINUE END IF END IF L6=I6+ISTEP6-NSTEP6 DO27046I=1,NATGR L6=L6+NSTEP6 IF(NINT(QX(L6+1)).EQ.L5)THEN GOTO27047 END IF 27046 CONTINUE 27047 CONTINUE IF(I.LE.NATGR)THEN I1=I6+20 IF(QX(I6+2).LT.1.5)THEN I2=L6+5 ELSE I2=I6FRST+ISTEP6+(I-1)*NSTEP6+2 END IF DO27048J=1,3 I1=I1+1 QX(L6+2+J)=QX(I1+1)*QX(I2+1)+QX(I1+4)*QX(I2+2)+QX(I1+7)*QX(I2+3) 27048 CONTINUE I1=20 I3=I6+2 DO27050J=1,3 I1=I1+1 I3=I3+1 Q1=CELL(I1+1)*QX(L6+3)+CELL(I1+4)*QX(L6+4)+CELL(I1+7)*QX(L6+5)+QX( &I3) M=L5+1+J BUFOT(J+10)=Q1-QX(M) QX(M)=Q1 BUFOT(J+20)=Q1 27050 CONTINUE IF(QX(I6+2).GT.1.5)THEN L6=I6FRST+ISTEP6+(I-1)*NSTEP6 QX(L6+3)=QX(L6+3)+XC-QX(I6FRST+3) QX(L6+4)=QX(L6+4)+YC-QX(I6FRST+4) QX(L6+5)=QX(L6+5)+ZC-QX(I6FRST+5) END IF GOTO27033 END IF I6=L6+NSTEP6 GOTO27032 27033 CONTINUE END IF END IF FFACT=0.0 IF(NTMP.GT.0)THEN DO27052J=1,20 IF((NTMP.EQ.1).AND.(QX(L5+5).GT.0.))THEN GOTO27053 END IF IF(NTMP.EQ.6)THEN IF((QX(L5+5).GT.0.).AND.(QX(L5+6).GT.0.).AND.(QX(L5+7).GT.0.))THEN Q1=QX(L5+5)*QX(L5+6)-QX(L5+8)*QX(L5+8) Q2=QX(L5+5)*QX(L5+7)-QX(L5+9)*QX(L5+9) Q3=QX(L5+6)*QX(L5+7)-QX(L5+10)*QX(L5+10) IF((Q1.GT.0.).AND.(Q2.GT.0.).AND.(Q3.GT.0.))THEN Q=QX(L5+5)*QX(L5+6)*QX(L5+7)+2.*QX(L5+8)*QX(L5+9)*QX(L5+10)-QX(L5+ &5)*QX(L5+10)*QX(L5+10)-QX(L5+6)*QX(L5+9)*QX(L5+9)-QX(L5+7)*QX(L5+8 &)*QX(L5+8) ELSE Q=0. END IF IF(Q.GT.0.0)THEN GOTO27053 END IF END IF END IF FFACT=FFACT+.05 IF(TMPTST.GT.0)THEN GOTO27053 END IF DO27054I=1,NTMP IF(BUFOT(I+13).LT.-999.)THEN GOTO27054 END IF M=L5+4+I QX(M)=QX(M)-DAMP*.05*BUFOT(I+13) BUFOT(I+23)=QX(M) 27054 CONTINUE 27052 CONTINUE 27053 CONTINUE END IF FFACT=1.-FFACT IF(FFACT.LT.1.00)THEN IF(TMPTST.EQ.0)THEN DO27056I=1,NTMP IF(BUFOT(I+13).LT.-999.)THEN GOTO27056 END IF BUFOT(I+13)=BUFOT(I+13)*FFACT 27056 CONTINUE END IF END IF IF(ICYCLE.EQ.NCYCLE)THEN DO27058J=1,VAR IF(BUFOT(J+10).LT.-999.)THEN GOTO27058 END IF BUFOT(J+40)=0. IF(BUFOT(J+30).LT.5.0E-7)THEN GOTO27058 END IF BUFOT(J+40)=ABS(BUFOT(J+10))/BUFOT(J+30) DSDMAX=AMAX1(DSDMAX,BUFOT(J+40)) DSDAVE=DSDAVE+BUFOT(J+40) DSDNUM=DSDNUM+1. 27058 CONTINUE END IF IF(ICYCLE.EQ.NCYCLE)THEN CALLCR38(NAME,IREL,IWANT,SGNL,P) K=SGNL(1)+3 J1=0 IP=IOPKPT(1) DO27060I=1,12 IF(I.EQ.4)THEN FLACT=BTOU ELSE IF(I.GE.5.AND.I.LE.10)THEN FLACT=0.01*CELL(I+2) ELSE FLACT=1.0 END IF J=K+I IF(IWANT(J+23).LE.0)THEN GOTO27060 END IF P=P+1 L=P+ISKIP M=L+ISKIP-1 IF(I.EQ.4.AND.NTMP.NE.1)THEN JJP=P QX(JJP)=0. JJL=L QX(JJL)=0. GOTO27060 END IF IF(I.GE.5.AND.I.LE.10.AND.NTMP.NE.6)THEN GOTO27060 END IF IF(I.LE.11)THEN IF(ADDOLD.GT.0)THEN M2=IREL(J)+IP QX(M)=QX(M2) END IF J1=J1+1 IF(BUFOT(J1+20).GT.-999.)THEN QX(P)=BUFOT(J1+20)*FLACT QX(L)=BUFOT(J1+30)*FLACT ELSE QX(P)=BUFOT(J1)*FLACT QX(L)=0. END IF IF(I.GE.5.AND.I.LE.10)THEN QX(JJP)=QX(JJP)+QX(P)*UEQU(I-4) QX(JJL)=QX(JJL)+QX(L)*UEQU(I-4) END IF ELSE N=MIN0(2,NTMP) QX(P)=FLOAT(N) END IF 27060 CONTINUE END IF CALLAA55(NAME,1,CHROT,NCH1,LABMAX,0) IF(NCH1.GT.2)THEN CHROT(2:5)='ATOM' CALLAA04(0,CH,NCH,1,3) END IF DO27062I=1,BFMAX,10 IF(I.LT.40)THEN IF(NTMP.EQ.1)THEN BUFOT(I+3)=BTOHU*BUFOT(I+3) ELSE J=1 27064 IF(J.LE.NTMP)THEN M=I+2+J IF(BUFOT(M).LT.-999.)THEN GOTO27065 END IF BUFOT(M)=BUFOT(M)*CELL(J+6) 27065 CONTINUE J=J+1 GOTO27064 END IF END IF END IF L=I/10*4+2 CALLAA55(CR372,L,CHROT,NCH2,3,0) LCHROT=NCH2+2 M=1 DO27067J=1,VAR IF(J.EQ.PAR.AND.REFPOP.GT.0)THEN M=2 LCHROT=NCH3 END IF IF(I.EQ.1.OR.BUFOT(J+10).GT.-999.)THEN CALLAA03(BUFOT,I-1+J,CHROT,FORM(M),1) ELSE LCHROT=LCHROT+NC END IF 27067 CONTINUE CALLAA04(0,CH,NCH,1,3) IF(PRNT.EQ.0)THEN GOTO27063 END IF 27062 CONTINUE 27063 CONTINUE IF(FFACT.LT.1.00)THEN CALLAA55(CR373,1,CHROT,1,NCR373,0) CALLAA55(NAME,1,CHROT,22,8,0) IF(TMPTST.EQ.0)THEN CALLAA55(CR374,1,CHROT,(NCR373+1),NCR374,0) CALLAA03(FFACT,1,CHROT,870732.,1) ELSE IF(TMPTST.EQ.2)THEN QUITF='CR3701' END IF CALLAA04(1,' ',0,1,3) END IF IF(PRNT.EQ.1)THEN CALLAA04(1,' ',0,3,3) END IF IF(LINCT.LT.5)THEN LINRM=5 END IF IF(PNCHCD.GT.1)THEN CALLAA55(CR372,22,CHROT,1,4,0) CALLAA55(NAME,1,CHROT,6,LABMAX,0) LCHROT=LABMAX+6 CALLAA03(QX(L5+2),1,CHROT,FMT2,3) CHROT(LCHROT+2:)='$1' LCHROT=LCHROT+3 IF(POP.EQ.1)THEN APOP=QX(L5+1+PAR) ELSE APOP=1. END IF CALLAA03(APOP,1,CHROT,632.,1) IF(ICYCLE.EQ.NCYCLE)THEN DO27069I=1,3 IF(BUFOT(I+30).LT.-999.)THEN BUFOT(I+30)=0. END IF 27069 CONTINUE CALLAA03(BUFOT,31,CHROT,FMT3,3) IF(REFPOP.EQ.1)THEN CHROT(LCHROT+2:)='$1' LCHROT=LCHROT+3 IF(BUFOT(VAR+30).LT.-999.)THEN BUFOT(VAR+30)=0. END IF CALLAA03(BUFOT,VAR+30,CHROT,532.,1) END IF END IF IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CHROT=' ' IF(NTMP.LT.6)THEN CHROT(1:)='U' CALLAA55(NAME,1,CHROT,6,LABMAX,0) IF(NTMP.EQ.0)THEN BUFOT(24)=BTOU*QX(MARK4+1) ELSE BUFOT(24)=BTOU*QX(L5+5) END IF LCHROT=LABMAX+6 CALLAA03(BUFOT(24),1,CHROT,952.,1) IF(ICYCLE.EQ.NCYCLE)THEN IF(NTMP.EQ.0)THEN BUFOT(34)=BTOU/CELL(1)*QX(MARK13+REFSKF+1) ELSE IF(BUFOT(34).GT.-999.)THEN BUFOT(34)=0.01*BUFOT(34) ELSE BUFOT(34)=0. END IF CALLAA03(BUFOT(34),1,CHROT,952.,1) END IF IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CHROT=' ' ELSE CHROT(1:)='UIJ' CALLAA55(NAME,1,CHROT,6,24,0) LCHROT=LABMAX+6 DO27071I=1,6 BUFOT(I+23)=.01*CELL(I+6)*QX(L5+I+4) 27071 CONTINUE CALLAA03(BUFOT,24,CHROT,FMT2,6) IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CHROT=' ' IF(ICYCLE.EQ.NCYCLE)THEN CHROT(1:)='SUIJ' CALLAA55(NAME,1,CHROT,6,LABMAX,0) DO27073I=1,6 IF(BUFOT(I+33).LT.-999.)THEN BUFOT(I+33)=0. ELSE BUFOT(I+33)=.01*BUFOT(I+33) END IF 27073 CONTINUE LCHROT=LABMAX+6 CALLAA03(BUFOT,34,CHROT,FMT2,6) IF(IOUNIT(11).LT.0)THEN IOUNIT(11)=-IOUNIT(11) CALLAA50(IOUNIT(11),1,0,' ') END IF WRITE(IOUNIT(11),'(A)')CHROT(1:80) CHROT=' ' END IF END IF END IF L5=NINT(QX(L5)) GOTO27008 END IF IF(ICYCLE.EQ.NCYCLE)THEN LINRM=6 CALLAA03(DSDMAX,1,CR375,301041.,1) CALLAA04(2,CR375,NCR375,3,3) BUFOT(1)=DSDAVE/AMAX1(1.0,DSDNUM) CALLAA03(BUFOT,1,CR376,301041.,1) CALLAA04(0,CR376,NCR376,3,3) IF(SELECT.EQ.1)THEN CALLCR38(NAME,IREL,IWANT,SGNL,P) END IF END IF IF(ICYCLE.EQ.NCYCLE)THEN CALLAA13(1,2,17,19) END IF IF(QUITF(1:1).NE.' ')THEN CALLAA06('CR3701',0) END IF RETURN END C-------CR38 SUBROUTINECR38(NAME,IREL,IWANT,SGNL,P) INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL CHARACTER*(24 )CH1 CHARACTER*(24 )NAME INTEGERI,J,K,L,M,P INTEGERIP,IPP INTEGERIREL(*) INTEGERIWANT(*) INTEGERNEWPCK INTEGERPACK INTEGERSGNL(4) NEWPCK=SGNL(4) 27000 CONTINUE CALLAA12(1,16,PACK,IP,2) IF(IP.LE.0)THEN GOTO27001 END IF CALLAA11(2,16,NEWPCK,IPP) CALLAA51(-4.E+20,1,QX,IPP+1,NEWPCK,2) K=SGNL(2)+1 P=IPP DO27002I=1,PACK IF(I.EQ.IREL(K))THEN K=K+1 ELSE L=IP+I P=P+1 CALLAA52(QX(L),QX(P)) END IF 27002 CONTINUE IF(SELECT.EQ.0)THEN GOTO27001 END IF M=IP+IREL(1) CALLAA57(QX(M),1,CH1,1,24,0) IF(CH1.EQ.NAME)THEN GOTO27001 END IF K=SGNL(1)+3 DO27004I=1,23 J=K+I IF(IWANT(J+23).LE.0)THEN GOTO27004 END IF P=P+1 L=IP+IREL(J) IF(L.GT.IP)THEN QX(P)=QX(L) ELSE IF(I.EQ.12)THEN IF(IREL(K+5).GT.0)THEN QX(P)=2.0 ELSE IF(IREL(K+4).GT.0)THEN QX(P)=1.0 END IF END IF 27004 CONTINUE GOTO27000 27001 CONTINUE RETURN END C-------CR40 SUBROUTINECR40 INTEGERBUFPNT(40),BUFORD(40),CHRCOL,CHRMAX,CHREOF,FIELDF,INPBDF,IO &LRHD(8),IOMARK(8),IOPKPT(8),IOPRCT(8),IORWFL(8),IOUNIT(20),IOSPEC( &5),IOIN2,LABMAX,LABLEN(7),LABPOS(7),LCHROT,LINID,LINFLG,LINCT,LINM &AS,LINRM,MASTER,NIMAG,NPAGE,PPRIOR,PRVOID,PRHIST,PNTPRG,SETIDF,SYN &TXF,QXCUR,QXMAX,QXSTR,IQXY,IQXZ,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW REALBUFIN(40),BUFOT(50),ELAPST,QX(3000000) CHARACTERTITLE*200,BLANK*4,CHRIP*201,CHRIN*201,CHROT*200,HEADOT*20 &0,FILEXT(99)*3,FILENM(99)*10,MASTIN*3,MASTOT*3,PROGID*6,COMPID*6,P &RGLST*700,XTALHOME*256,QUITF*6 COMMON/SYSF/BUFIN,BUFOT,ELAPST COMMON/SYSI/BUFPNT,BUFORD,INPBDF,IOLRHD,IOMARK,IOPKPT,IOPRCT,IORWF &L,IOUNIT,IOIN2,CHRMAX,CHRCOL,CHREOF,FIELDF,LINID,LINFLG,LINCT,LINR &M,MASTER,PPRIOR,PNTPRG,IOSPEC,NIMAG,NPAGE,SETIDF,SYNTXF,LCHROT,LAB &MAX,LABPOS,LABLEN,LINMAS,PRVOID,QXMAX,QXCUR,QXSTR,PRHIST,IQXY,IQXZ &,JQJ,JQK,KQJ,KZJ,KZK,IWIWIW,JWJWJW COMMON/SYSC/BLANK,CHRIP,CHRIN,CHROT,TITLE,PROGID,COMPID,PRGLST,FIL &EXT,FILENM,MASTIN,MASTOT,QUITF,HEADOT,XTALHOME COMMON/QXDATA/QX INTEGERADDOLD INTEGERBLKTYP REALBTOHU REALBTOU REALCELL(39) REALDAMP INTEGERDATSET REALDSDAVE REALDSDMAX REALDSDNUM REALDSFTB INTEGERDSTEXT REALEXTESD INTEGEREXTTYP INTEGERICENT INTEGERICYCLE INTEGERIMAGP INTEGERISTEP6 INTEGERIWT REALLAMBDA INTEGERLIST INTEGERLISTMA INTEGERLTMTRX REALMALIST INTEGERMARK0 INTEGERMARK1 INTEGERMARK2 INTEGERMARK3 INTEGERMARK4 INTEGERMARK5 INTEGERMARK6 INTEGERMARK7 INTEGERMARK8 INTEGERMARK9 INTEGERMARK10 INTEGERMARK11 INTEGERMARK12 INTEGERMARK13 INTEGERMARK14 INTEGERMARK15 INTEGERMIXTMP INTEGERMLT REALMONO2T REALMU INTEGERNAT INTEGERNATTYP INTEGERNCYCLE INTEGERNONATM INTEGERNSFTB INTEGERNSKIP INTEGERNSTEP2 INTEGERNSTEP6 INTEGERNSYM INTEGERPARTL INTEGERPNCHCD INTEGERPOLSPG(3) INTEGERPOP REALRATIO REALR0(3) REALRW(3) INTEGERRADTYP INTEGERREFABS INTEGERREFDSP INTEGERREFEXT INTEGERREFPOP INTEGERREFSKF INTEGERREFTMP INTEGERREFUOV INTEGERREL(99) REALRFLIST INTEGERRFLMLT INTEGERRFLTYP REALRFMTRX REALRSUMS(60) INTEGERSAVEMA INTEGERSELECT INTEGERSIGNAL(4) INTEGERSTOP0 INTEGERTCYCLE INTEGERTERMNT INTEGERTMPTST REALTYPELT REALUEQU(6) INTEGERVARGEN INTEGERVARTOT REALVOL REALSS(3) REALXABS REALXABSIG COMMON/COMFCR/BTOHU,BTOU,CELL,DAMP,DSFTB,LAMBDA,MALIST,MONO2T,MU,R &FLIST,RFMTRX,RSUMS,TYPELT,UEQU,VOL,XABS,R0,RW,SS,EXTESD,RATIO,DSDA &VE,DSDMAX,DSDNUM,TCYCLE,XABSIG COMMON/COMICR/ADDOLD,BLKTYP,DATSET,DSTEXT,EXTTYP,ICENT,ICYCLE,IMAG &P,ISTEP6,IWT,LIST,LISTMA,LTMTRX,MARK0,MARK1,MARK2,MARK3,MARK4,MARK &5,MARK6,MARK7,MARK8,MARK9,MARK10,MARK11,MARK12,MARK13,MARK14,MARK1 &5,NONATM,MIXTMP,MLT,NAT,NATTYP,NCYCLE,NSFTB,NSKIP,NSTEP2,NSTEP6,NS &YM,PARTL,PNCHCD,POLSPG,POP,RADTYP,STOP0,REFABS,REFDSP,REFEXT,REFPO &P,REFSKF,REFTMP,REFUOV,REL,RFLMLT,RFLTYP,SAVEMA,SELECT,TERMNT,TMPT &ST,VARGEN,VARTOT,SIGNAL INTEGERI,IP,ISIZ,J,JP,K INTEGERPSIZ INTEGERNSFLS CHARACTER*5 SFLS INTEGERNWEIG CHARACTER*15 WEIG INTEGERNEXTT CHARACTER*28 EXTT INTEGERNEXTD CHARACTER*20 EXTD INTEGERNEXTE CHARACTER*40 EXTE INTEGERNMATX CHARACTER*27 MATX INTEGERNABSS CHARACTER*18 ABSS INTEGERNCOEF CHARACTER*12 COEF INTEGERNCR1 CHARACTER*20 CR1 INTEGERNCR2 CHARACTER*37 CR2 REAL FMT(5 ) DATANSFLS/5 /, SFLS/'sfls '/ DATANWEIG/15 /, WEIG/' unitsigma calc'/ DATANEXTT/28 /, EXTT/' ZachariasenBecker-Coppens'/ DATANEXTD/20 /, EXTD/'Gaussian Lorentzian'/ DATANEXTE/40 /, EXTE/'Eq22 p292 "Cryst. Comp." Munksgaard 1970'/ DATANMATX/27 /, MATX/'atomblock fulluserblock'/ DATANABSS/18 /, ABSS/'Flack xabs refined'/ DATANCOEF/12 /, COEF/'F FsqdInet'/ DATANCR1/20 /, CR1/' Refinement History-'/ DATANCR2/37 /, CR2/' Cycle R wR GoF Title'/ DATAFMT/40413.,120832.,200832.,200832.,280832./ CALLAA13(1,2,21,29) PSIZ=92 CALLAA11(2,30,PSIZ,JP) QX(JP+1)=1. J=JP+1 DO27000I=1,10 QX(J+I)=11. 27000 CONTINUE J=J+10 DO27002I=1,10 QX(J+I)=12. 27002 CONTINUE J=J+10 DO27004I=1,10 QX(J+I)=13. 27004 CONTINUE J=J+10 DO27006I=1,10 QX(J+I)=14. 27006 CONTINUE J=J+10 DO27008I=1,10 QX(J+I)=15. 27008 CONTINUE J=J+10 DO27010I=1,10 QX(J+I)=16. 27010 CONTINUE J=J+10 DO27012I=1,10 QX(J+I)=17. 27012 CONTINUE J=J+10 DO27014I=1,16 QX(J+I)=FLOAT(I+20) 27014 CONTINUE J=J+16 DO27016I=1,5 QX(J+I)=FLOAT(I+40) 27016 CONTINUE IWT=MIN(IWT,3) CALLAA11(2,30,PSIZ,JP) J=JP+1 QX(J)=FLOAT(DATSET) J=J+1 CALLAA56(BLANK,1,QX(J),1,40,1) CALLAA56(SFLS,1,QX(J),1,5,0) CALLAA56(COEF,RFLTYP*4+1,QX(J),7,4,0) CALLAA56(WEIG,IWT*5-4,QX(J),12,5,0) CALLAA56('weight',1,QX(J),18,6,0) CALLAA56(MATX,BLKTYP*9+1,QX(J),25,9,0) CALLAA56('matrix',1,QX(J),35,6,0) J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) CALLAA56(WEIG,IWT*5-4,QX(J),1,5,0) J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) IF(REFEXT.GT.0)THEN K=MIN(EXTTYP,1)*14+1 I=DSTEXT*10+1 CALLAA56(EXTT,K,QX(J),1,14,0) IF(EXTTYP.GT.1)THEN CALLAA56(EXTD,I,QX(J),16,10,0) END IF END IF J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) CALLAA56(MATX,BLKTYP*9+1,QX(J),1,9,0) J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) IF(REFABS.GT.0)THEN CALLAA56(ABSS,1,QX(J),1,NABSS,0) END IF J=J+10 CALLAA56(BLANK,1,QX(J),1,40,1) IF(REFEXT.GT.0.AND.EXTTYP.LT.1)THEN CALLAA56(EXTE,1,QX(J),1,40,0) END IF J=J+10-1 QX(J+1)=R0(1) QX(J+2)=R0(2) QX(J+3)=0. QX(J+4)=0. QX(J+5)=RW(1) QX(J+6)=RW(2) QX(J+7)=SS(1) QX(J+8)=SS(2) QX(J+9)=DSDMAX QX(J+10)=DSDAVE/AMAX1(1.0,DSDNUM) QX(J+11)=-4.E+20 IF(REFABS.GT.0)THEN QX(J+12)=XABS ELSE QX(J+12)=-4.E+20 END IF IF(EXTTYP.LT.2.OR.EXTTYP.EQ.3)THEN QX(J+13)=QX(MARK4+2)*10000. ELSE QX(J+13)=QX(MARK4+3)*10000. END IF QX(J+14)=EXTESD*10000. QX(J+15)=-4.E+20 IF(REFABS.GT.0)THEN QX(J+16)=XABSIG ELSE QX(J+16)=-4.E+20 END IF K=J+16 QX(K+1)=FLOAT(RFLTYP+1) QX(K+2)=RSUMS(51) QX(K+3)=RSUMS(47) QX(K+4)=RSUMS(59) QX(K+5)=0. LINRM=8 CALLAA55(CR1,NCR1,CHROT,2,NCR1-2,2) CALLAA04(1,CR1,NCR1-1,2,3) LINRM=2 ISIZ=15 27018 CONTINUE CALLAA12(1,31,PSIZ,IP,0) CALLAA11(2,31,ISIZ,JP) IF(IP.GT.0)THEN CALLAA51(QX,IP+1,QX,JP+1,PSIZ,0) ELSE QX(JP+1)=TCYCLE QX(JP+2)=R0(2) QX(JP+3)=0. QX(JP+4)=RW(2) QX(JP+5)=SS(2) CALLAA56(TITLE,59,QX(JP+6),1,40,0) END IF CALLAA03(QX,JP+1,CHROT,FMT,5) CALLAA57(QX(JP+6),1,CHROT,32,40,0) CALLAA04(0,CR2,NCR2,1,3) IF(IP.LE.0)THEN GOTO27019 END IF GOTO27018 27019 CONTINUE CALLAA13(1,2,32,65535) RETURN END
next reply other threads:[~2001-10-09 20:46 UTC|newest] Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top 2001-10-09 20:46 ddb [this message] 2001-10-14 22:02 billingd 2001-12-08 7:58 toon 2001-12-08 8:06 toon
Reply instructions: You may reply publicly to this message via plain-text email using any one of the following methods: * Save the following mbox file, import it into your mail client, and reply-to-all from there: mbox Avoid top-posting and favor interleaved quoting: https://en.wikipedia.org/wiki/Posting_style#Interleaved_style * Reply using the --to, --cc, and --in-reply-to switches of git-send-email(1): git send-email \ --in-reply-to=20011010034439.6572.qmail@sourceware.cygnus.com \ --to=ddb@r3401.rlem.titech.ac.jp \ --cc=gcc-gnats@gcc.gnu.org \ /path/to/YOUR_REPLY https://kernel.org/pub/software/scm/git/docs/git-send-email.html * If your mail client supports setting the In-Reply-To header via mailto: links, try the mailto: linkBe sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions for how to clone and mirror all data and code used for this inbox; as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).