public inbox for gcc-prs@sourceware.org
help / color / mirror / Atom feed
* fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
@ 2001-10-09 20:46 ddb
0 siblings, 0 replies; 4+ messages in thread
From: ddb @ 2001-10-09 20:46 UTC (permalink / raw)
To: gcc-gnats
>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
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
@ 2001-12-08 8:06 toon
0 siblings, 0 replies; 4+ messages in thread
From: toon @ 2001-12-08 8:06 UTC (permalink / raw)
To: billingd; +Cc: gcc-prs
The following reply was made to PR fortran/4514; it has been noted by GNATS.
From: toon@gcc.gnu.org
To: billingd@gcc.gnu.org, ddb@R3401.rlem.titech.ac.jp, gcc-bugs@gcc.gnu.org,
gcc-gnats@gcc.gnu.org, gcc-prs@gcc.gnu.org
Cc:
Subject: Re: fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
Date: 8 Dec 2001 15:58:42 -0000
Synopsis: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
State-Changed-From-To: feedback->closed
State-Changed-By: toon
State-Changed-When: Sat Dec 8 07:58:41 2001
State-Changed-Why:
Neiher the released gcc-2.95.3 nor the released gcc-3.0.2
show any problem with this code using the indicated compile
time options.
2.95.4 as alluded to in the message is a version that is
Debian specific - it might be useful to redirect this bug
report to Debian.
http://gcc.gnu.org/cgi-bin/gnatsweb.pl?cmd=view%20audit-trail&pr=4514&database=gcc
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
@ 2001-12-08 7:58 toon
0 siblings, 0 replies; 4+ messages in thread
From: toon @ 2001-12-08 7:58 UTC (permalink / raw)
To: billingd, ddb, gcc-bugs, gcc-gnats, gcc-prs
Synopsis: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
State-Changed-From-To: feedback->closed
State-Changed-By: toon
State-Changed-When: Sat Dec 8 07:58:41 2001
State-Changed-Why:
Neiher the released gcc-2.95.3 nor the released gcc-3.0.2
show any problem with this code using the indicated compile
time options.
2.95.4 as alluded to in the message is a version that is
Debian specific - it might be useful to redirect this bug
report to Debian.
http://gcc.gnu.org/cgi-bin/gnatsweb.pl?cmd=view%20audit-trail&pr=4514&database=gcc
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
@ 2001-10-14 22:02 billingd
0 siblings, 0 replies; 4+ messages in thread
From: billingd @ 2001-10-14 22:02 UTC (permalink / raw)
To: billingd, ddb, gcc-bugs, gcc-prs, nobody
Synopsis: Internal compiler error in `calculate_giv_inc', at unroll.c:1604
Responsible-Changed-From-To: unassigned->billingd
Responsible-Changed-By: billingd
Responsible-Changed-When: Sun Oct 14 22:01:59 2001
Responsible-Changed-Why:
I will try and help.
State-Changed-From-To: open->feedback
State-Changed-By: billingd
State-Changed-When: Sun Oct 14 22:01:59 2001
State-Changed-Why:
I have not been able to reproduce this with the systems available to me.
The test case you posted is over 10000 lines and contains 21 seperate subroutines. Please break the test case into individual routines (using fsplit or manually) and see which routine triggers the error.
http://gcc.gnu.org/cgi-bin/gnatsweb.pl?cmd=view&pr=4514&database=gcc
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2001-12-08 16:06 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2001-10-09 20:46 fortran/4514: Internal compiler error in `calculate_giv_inc', at unroll.c:1604 ddb
2001-10-14 22:02 billingd
2001-12-08 7:58 toon
2001-12-08 8:06 toon
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).