1C 2C 3C 4 SUBROUTINE SYMTRZ (COORD,C,NORB,NMOS,FLAG,FLAG2) 5 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6C************************************************************** 7C * 8C DETERMINE POINT GROUP & SYMMETRIZE ORBITALS * 9C * 10C************************************************************** 11 INCLUDE 'SIZES' 12 PARAMETER (MXDIM=MAXPAR+NUMATM) 13C --------------------------------------------------------------- 14 COMMON/MOLKST/NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM), 15 1 NLAST(NUMATM),NORBS,NELECS,NALPHA,NBETA,NCLOSE,NOPEN,NDUMY, 16 2 FRACT 17 COMMON/SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 18 COMMON /SYMINF/ IBASE(2,12),NBASE,IVIBRO(2,12),IVIB 19 COMMON/VECTOR/CDUM(MORB2),EIGS(MAXORB),CBDUM(MORB2),EIGB(MAXORB) 20 COMMON /S00002/ NUNUM,NONORB,NADIM,NCDIM,IQUAL,NDORBS,IERROR 21 COMMON/S00004/SHIFT(3),R(3,3),VECT(2,MXDIM) 22 CHARACTER*4 NAME, NAMO, NAM, ISTA 23 LOGICAL FLAG,FLAG2 24 DIMENSION RSAV(3,3),COTIM(3,NUMATM) 25 DIMENSION V1(MAXORB),V2(MAXORB),V3(MAXORB),V4(MAXORB) 26 DIMENSION COORD(3,NUMATM),C(MAXORB,MAXORB) 27 DIMENSION IOPSYM(7),IMAGE(NUMATM,7) 28 DATA IOPSYM /1,1,1,1,1,1,1/ 29 NUNUM = NUMAT 30 NONORB = NORBS 31 DO K=1,3 32 DO L=1,NUMAT 33 COTIM(K,L)=COORD(K,L) 34 ENDDO 35 ENDDO 36 DO I=1,3 37 DO J=1,3 38 RSAV(I,J)=R(I,J) 39 ENDDO 40 ENDDO 41 NAM=NAME 42 CALL SYMAN1(NUMAT,2,COORD,NAT,1,MAXORB) 43 IF(FLAG2) CALL SYMAN2(NORBS,NORBS,C,0,1,MAXORB) 44 DO I=1,3 45 DO J=1,3 46 R(I,J)=RSAV(I,J) 47 ENDDO 48 ENDDO 49 DO K=1,3 50 DO L=1,numat 51 COORD(K,L)=COTIM(K,L) 52 ENDDO 53 ENDDO 54 RETURN 55 END 56C 57C================================================================ 58C 59 SUBROUTINE SYMAN1(NUM1,NUM2,ARRAY,LINEAR,JUMP,idim) 60 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 61C*************************************************************** 62C * 63C SYMMETRY PACKAGE FROM UMNDO PROGRAM OF PETER BISCHOF * 64C WAS REWRITTEN BY DAVID DANOVICH FOR MOPAC SYSTEM * 65C * 66C*************************************************************** 67 INCLUDE 'SIZES' 68 PARAMETER (MXDIM=MAXPAR+NUMATM) 69 DIMENSION LINEAR(NUMATM),NUSS(MXDIM),ICOUNT(12),ARRAY(3,NUMATM) 70 COMMON /S00001/T(12,12),JX(7,12),LINA,I1,J1,J2 71 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 72 COMMON /S00020/ NIMM(2,MXDIM),NOCC(2) 73 COMMON/SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 74 CHARACTER*4 IFRA, NAME, ISTA, NAMO, NIMM 75 COMMON /SYMINF/ IBASE(2,12),NBASE,IVIBRO(2,12),IVIB 76 DATA IFRA / '????' / 77 WRITE(6,'('' == symtrz.f SYMAN1 =='')') 78 IF(NUM1.LT.2) GOTO 12 79 IF(NUM2.LT.2) GOTO 12 80 IF(NUM1.GT.MXDIM) GOTO 12 81C ** MOLECULAR SYMMETRY 82 1 IERROR=0 83 LCALL=0 84 IVIB=0 85 NBASE=0 86 NUMAT=NUM1 87 NAME=IFRA 88 ISTA(1)=' ' 89 ISTA(2)=IFRA 90 DO 2 I=1,MXDIM 91 2 NAMO(I)=IFRA 92 CALL R00001(LINEAR,ARRAY) 93 IF(IERROR.LT.1) CALL R00009(LINEAR,ARRAY) 94 IF(IERROR.LT.1) CALL R00016 95 DO 3 I=1,NUMAT 96 3 INDEX(I)=LINEAR(I) 97 RETURN 98 12 IERROR=1 99 WRITE(6,600)NUM1,NUM2 100 RETURN 101 600 FORMAT(' ILLEGAL SYMA - ARGUMENTS: NUM1 = ',I10,' NUM2 = ',I10) 102 END 103C 104C====================================================================== 105C 106 SUBROUTINE SYMAN2(NUM1,NUM2,ARRAY,LINEAR,JUMP,idim) 107 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 108 INCLUDE 'SIZES' 109 PARAMETER (MXDIM=MAXPAR+NUMATM) 110 DIMENSION NUSS(MXDIM),ICOUNT(12),array(num1,num1) 111 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 112 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 113 COMMON /S00020/ NIMM(2,MXDIM),NOCC(2) 114 COMMON/SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 115 CHARACTER*4 IFRA, NAME, ISTA, NAMO, NIMM 116 COMMON /SYMINF/ IBASE(2,12),NBASE,IVIBRO(2,12),IVIB 117 DATA IFRA / '????' / 118 WRITE(6,'('' == symtrz.f SYMAN2 =='')') 119 IF(NUM1.LT.2) GOTO 12 120 IF(NUM2.LT.2) GOTO 12 121 IF(NUM1.GT.MXDIM) GOTO 12 122C ** ORBITAL SYMMETRY 123 IF(IERROR.GT.0) THEN 124 RETURN 125 ENDIF 126 LCALL=0 127 IF(LINEAR.GT.0) GOTO 6 128 IF(LCALL.GT.0) GOTO 8 129 KORB=0 130 NQZ=1 131 DO 5 I=1,NUMAT 132 JJ=1 133 IF(INDEX(I).GT.1) JJ=4 134 DO 5 J=1,JJ 135 KORB=KORB+1 136 NUSS(KORB)=100*I+10*NQZ+J-1 137 5 CONTINUE 138 GOTO 8 139 6 DO 7 I=1,NUM1 140 7 NUSS(I)=LINEAR 141 8 NORBS=NUM1 142 NCDIM=NUM2 143 NCDUM=NUM2 144 CALL R00010(ARRAY,NUSS,ICOUNT,num1) 145 IF(IERROR.GT.0) RETURN 146 NBASE=0 147 DO 9 I=1,I1 148 IF(ICOUNT(I).LT.1) GOTO 9 149 NBASE=NBASE+1 150 IBASE(1,NBASE)=ICOUNT(I) 151 IBASE(2,NBASE)=JX(1,I) 152 9 CONTINUE 153 LCALL=LCALL+1 154 IF(LCALL.GT.2) LCALL=1 155 DO 10 I=1,NORBS 156 NIMM(LCALL,I)=NAMO(I) 157 10 NIMM(2,I)=NAMO(I) 158 RETURN 159 12 IERROR=1 160 WRITE(6,600)NUM1,NUM2 161 RETURN 162 600 FORMAT(' ILLEGAL SYMA - ARGUMENTS: NUM1 = ',I10,' NUM2 = ',I10) 163 END 164C 165C========================================================================== 166C 167 SUBROUTINE R00001(NAT,COORD) 168 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 169 INCLUDE 'SIZES' 170 PARAMETER (MXDIM=MAXPAR+NUMATM) 171 CHARACTER*4 NAME,NAMO,ISTA 172 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 173 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 174 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 175 COMMON/SYMRES/ TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 176 COMMON /ATMASS/ ATMASS(NUMATM) 177 LOGICAL PLANAR,LINEAR,CUBIC,AXIS 178 DIMENSION NAT(NUMATM),COORD(3,NUMATM),F(6),EW(3),HELP(3) 179 DIMENSION RHELP(3,3) 180 DIMENSION ICYC(6) 181 DATA TOLER,BIG/ 0.1D0,1.D35 / 182 WRITE(6,'('' == symtrz.f R00001 =='')') 183 DO 2 I=1,3 184 DO 1 J=1,3 185 1 CUB(I,J)=0.D0 186 2 CUB(I,I)=1.D0 187 DO 3 I=1,20 188 CALL R00006(I,I) 189 3 IELEM(I)=0 190 DO 4 I=1,3 191 4 SHIFT(I)=0.D0 192 WMOL=0.D0 193 DO 5 I=1,NUMAT 194 WMOL=WMOL+ATMASS(I) 195 DO 5 K=1,3 196 5 SHIFT(K)=SHIFT(K)+ATMASS(I)*COORD(K,I) 197 IJ=0 198 DO 7 I=1,3 199 SHIFT(I)=SHIFT(I)/WMOL 200 DO 6 K=1,NUMAT 201 6 COORD(I,K)=COORD(I,K)-SHIFT(I) 202 DO 7 J=1,I 203 IJ=IJ+1 204 F(IJ)=0.D0 205 DO 7 K=1,NUMAT 206 TERM=ATMASS(K)*COORD(I,K)*COORD(J,K) 207 7 F(IJ)=F(IJ)+TERM 208 TRANS=25.98160821D0 + 2.97975D0*DLOG(WMOL) 209 CALL R00015(F,R,EW) 210 R(1,3)=R(2,1)*R(3,2)-R(3,1)*R(2,2) 211 R(2,3)=R(3,1)*R(1,2)-R(1,1)*R(3,2) 212 R(3,3)=R(1,1)*R(2,2)-R(2,1)*R(1,2) 213 PLANAR=(EW(1).LT.TOLER) 214 LINEAR=(EW(2).LT.TOLER) 215 CUBIC=((EW(3)-EW(1)).LT.TOLER) 216 IF(.NOT.LINEAR) GOTO 8 217 CALL R00005(COORD,1) 218 IELEM(20)=1 219 GOTO 22 220 8 IF(CUBIC.OR.((EW(3)-EW(2)).GT.TOLER)) GOTO 10 221 DO 9 I=1,3 222 BUFF=-R(I,1) 223 R(I,1)=R(I,3) 224 9 R(I,3)=BUFF 225 BUFF=EW(1) 226 EW(1)=EW(3) 227 EW(3)=BUFF 228 10 AXIS=(ABS(EW(1)-EW(2)).LT.TOLER) 229 CALL R00005(COORD,1) 230 IF(CUBIC) CALL R00003(NAT,COORD,1) 231 IF(.NOT.AXIS) GOTO 16 232 ITURN=7 233 DO 11 I=8,18 234 CALL R00007(NAT,COORD,I) 235 IF((IELEM(I).EQ.1).AND.(I.LT.14)) ITURN=I 236 11 CONTINUE 237 ITURN=ITURN-5 238 DO 13 I=1,NUMAT 239 DIST=COORD(1,I)**2+COORD(2,I)**2 240 IF(DIST.LT.TOLER) GOTO 13 241 BUFF1=BIG 242 JNDEX=0 243 IPLUS=I+1 244 DO 12 J=IPLUS,NUMAT 245 BUFF=COORD(1,J)**2+COORD(2,J)**2 246 IF(ABS(BUFF-DIST).GT.TOLER) GOTO 12 247 BUFF=(COORD(1,I)-COORD(1,J))**2+(COORD(2,I)-COORD(2,J))**2 248 IF(BUFF.GT.BUFF1) GOTO 12 249 JNDEX=J 250 BUFF1=BUFF 251 12 CONTINUE 252 GOTO 14 253 13 CONTINUE 254 14 IF(JNDEX.LT.1) IERROR=1 255 IF(IERROR.GT.0) GOTO 25 256 HELP(1)=COORD(1,I)+COORD(1,JNDEX) 257 HELP(2)=COORD(2,I)+COORD(2,JNDEX) 258 DIST=SQRT(HELP(1)**2+HELP(2)**2) 259 SINA=HELP(2)/DIST 260 COSA=HELP(1)/DIST 261 CALL R00002(COORD,SINA,COSA,1,2) 262 CALL R00007(NAT,COORD,5) 263 IF(IELEM(5).EQ.1) GOTO 16 264 CALL R00007(NAT,COORD,1) 265 IF(IELEM(1).EQ.0) GOTO 16 266 DIST=1.5707963268D0/FLOAT(ITURN) 267 SINA=SIN(DIST) 268 COSA=COS(DIST) 269 ICHECK=0 270 15 CALL R00002(COORD,SINA,COSA,1,2) 271 IF(ICHECK.GT.0) GOTO 16 272 CALL R00007(NAT,COORD,5) 273 IF(IELEM(5).GT.0) GOTO 16 274 ICHECK=1 275 SINA=-SINA 276 GOTO 15 277 16 IF(CUBIC) CALL R00003(NAT,COORD,2) 278 IF(AXIS) GOTO 22 279 DO 17 I=1,6 280 CALL R00007(NAT,COORD,I) 281 17 ICYC(I)=(1+IQUAL)*IELEM(I) 282 NAXES=IELEM(1)+IELEM(2)+IELEM(3) 283 IF(NAXES.GT.1) GOTO 18 284 IZ=1 285 IF(IELEM(1).EQ.1) GOTO 19 286 IZ=2 287 IF(IELEM(2).EQ.1) GOTO 19 288 IZ=3 289 IF(IELEM(3).EQ.1) GOTO 19 290 IF(ICYC(5).GT.ICYC(4)) IZ=2 291 IF(ICYC(6).GT.ICYC(7-IZ)) IZ=1 292 GOTO 19 293 18 IZ=1 294 IF(ICYC(2).GT.ICYC(1)) IZ=2 295 IF(ICYC(3).GT.ICYC(IZ)) IZ=3 296 19 ICYC(7-IZ)=-1 297 IX=1 298 IF(ICYC(5).GT.ICYC(6)) IX=2 299 IF(ICYC(4).GT.ICYC(7-IX)) IX=3 300 IY=6-IX-IZ 301 DO 20 I=1,3 302 RHELP(I,1)=R(I,IX) 303 20 RHELP(I,2)=R(I,IY) 304 RHELP(1,3)=R(2,IX)*R(3,IY)-R(3,IX)*R(2,IY) 305 RHELP(2,3)=R(3,IX)*R(1,IY)-R(1,IX)*R(3,IY) 306 RHELP(3,3)=R(1,IX)*R(2,IY)-R(2,IX)*R(1,IY) 307 CALL R00005(COORD,-1) 308 DO 21 I=1,3 309 DO 21 J=1,3 310 21 R(I,J)=RHELP(I,J) 311 CALL R00005(COORD,1) 312 22 DO 23 I=1,7 313 CALL R00007(NAT,COORD,I) 314 23 CONTINUE 315 NCODE=0 316 J=1 317 DO 24 I=1,20 318 NCODE=NCODE+IELEM(I)*J 319 24 J=2*J 320 25 CALL R00005(COORD,-1) 321 TOTAL=EW(1)+EW(2)+EW(3) 322 DO 26 I=1,3 323 EW(I)=TOTAL-EW(I) 324 DO 26 J=1,NUMAT 325 26 COORD(I,J)=COORD(I,J)+SHIFT(I) 326 JGROUP = 0 327 CALL R00008(JGROUP,NCODE) 328 IF(JGROUP.LT.1) IERROR=2 329 TOTAL=EW(1)*EW(2)*EW(3)/(SIG*SIG) 330 IF(LINEAR) RTR= 6.970686D0 + 1.9865D0*DLOG(EW(1)/SIG) 331 IF(.NOT.LINEAR) RTR=11.592852D0 + 0.98325D0*DLOG(TOTAL) 332 RETURN 333 END 334C 335C================================================================== 336C 337 SUBROUTINE R00002(COORD,SINA,COSA,I,J) 338 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 339 INCLUDE 'SIZES' 340 PARAMETER (MXDIM=MAXPAR+NUMATM) 341 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 342 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 343 DIMENSION COORD(3,NUMATM) 344 WRITE(6,'('' == symtrz.f R00002 =='')') 345 CALL R00005(COORD,-1) 346 DO 1 K=1,3 347 BUFF=-SINA*R(K,I)+COSA*R(K,J) 348 R(K,I)=COSA*R(K,I)+SINA*R(K,J) 349 1 R(K,J)=BUFF 350 CALL R00005(COORD,1) 351 RETURN 352 END 353C 354C==================================================================== 355C 356 SUBROUTINE R00003(NAT,COORD,JUMP) 357 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 358 INCLUDE 'SIZES' 359 PARAMETER (MXDIM=MAXPAR+NUMATM) 360 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 361 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 362 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 363 DIMENSION COORD(3,NUMATM),NAT(NUMATM),WINK(2) 364 DATA BIG,TOLER / 1.D35,0.1/ 365 DATA WINK(1),WINK(2)/ 0.955316618125D0, 0.6523581398D0 / 366 WRITE(6,'('' == symtrz.f R00003 =='')') 367 GOTO (1,5),JUMP 368 1 IELEM(19)=1 369 INDEX=0 370 XMIN=BIG 371 DO 2 I=1,NUMAT 372 DIST=COORD(1,I)**2+COORD(2,I)**2+COORD(3,I)**2 373 IF(DIST.LT.TOLER) GOTO 2 374 IF(DIST.GT.XMIN) GOTO 2 375 INDEX=I 376 XMIN=DIST 377 2 CONTINUE 378 DIST=SQRT(XMIN) 379 CALL R00005(COORD,-1) 380 R(1,3)=COORD(1,INDEX)/DIST 381 R(2,3)=COORD(2,INDEX)/DIST 382 R(3,3)=COORD(3,INDEX)/DIST 383 BUFF=SQRT(R(1,3)**2+R(2,3)**2) 384 BUFF1=SQRT(R(1,3)**2+R(3,3)**2) 385 IF(BUFF.GT.BUFF1) GOTO 3 386 R(1,1)= R(3,3)/BUFF1 387 R(2,1)=0.D0 388 R(3,1)=-R(1,3)/BUFF1 389 GOTO 4 390 3 R(1,1)= R(2,3)/BUFF 391 R(2,1)=-R(1,3)/BUFF 392 R(3,1)=0.D0 393 4 R(1,2)= R(2,3)*R(3,1)-R(2,1)*R(3,3) 394 R(2,2)= R(3,3)*R(1,1)-R(3,1)*R(1,3) 395 R(3,2)= R(1,3)*R(2,1)-R(1,1)*R(2,3) 396 CALL R00005(COORD,1) 397 RETURN 398 5 WINK2=0.D0 399 IF(IELEM(8).LT.1) GOTO 8 400 DO 6 I=1,2 401 JOTA=18-4*I 402 WINK2=WINK(I) 403 SINA=SIN(WINK2) 404 COSA=COS(WINK2) 405 CALL R00002(COORD,SINA,COSA,1,3) 406 CALL R00007(NAT,COORD,JOTA) 407 IF(IELEM(JOTA).GT.0) GOTO 7 408 WINK2=-WINK2 409 SINB=SIN(2.D0*WINK2) 410 COSB=COS(2.D0*WINK2) 411 CALL R00002(COORD,SINB,COSB,1,3) 412 CALL R00007(NAT,COORD,JOTA) 413 IF(IELEM(JOTA).GT.0) GOTO 7 414 CALL R00002(COORD,SINA,COSA,1,3) 415 6 CONTINUE 416 7 CALL R00007(NAT,COORD,9) 417 IF(IELEM(10).GT.0) CALL R00007(NAT,COORD,17) 418 GOTO 10 419 8 WINK2=-WINK(1) 420 IF(IELEM(10).GT.0) WINK2=-WINK(2) 421 SINA=-SIN(WINK2) 422 COSA=COS(WINK2) 423 CALL R00002(COORD,SINA,COSA,1,3) 424 CALL R00007(NAT,COORD,8) 425 CALL R00002(COORD,-SINA,COSA,1,3) 426 IF(IELEM(8).GT.0) GOTO 10 427 IF(IELEM(9).GT.0) GOTO 9 428 WINK2=-WINK2 429 GOTO 10 430 9 CALL R00002(COORD,0.707106781186D0,0.707106781186D0,1,2) 431 10 CUB(1,1)=COS(WINK2) 432 CUB(3,3)=CUB(1,1) 433 CUB(1,3)=SIN(WINK2) 434 CUB(3,1)=-CUB(1,3) 435 CALL R00004(CUB,8) 436 CALL R00004(CUB,15) 437 CALL R00007(NAT,COORD,8) 438 CALL R00007(NAT,COORD,15) 439 RETURN 440 END 441C 442C===================================================================== 443C 444 SUBROUTINE R00004(FMAT,IPLACE) 445 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 446 INCLUDE 'SIZES' 447 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 448 DIMENSION HELP(3,3),FMAT(3,3) 449 WRITE(6,'('' == symtrz.f R00004 =='')') 450 DO 1 I=1,3 451 DO 1 J=1,3 452 HELP(I,J)=0.D0 453 DO 1 K=1,3 454 DO 1 L=1,3 455 1 HELP(I,J)=HELP(I,J)+FMAT(I,L)*FMAT(J,K)*ELEM(L,K,IPLACE) 456 DO 2 I=1,3 457 DO 2 J=1,3 458 2 ELEM(I,J,IPLACE)=HELP(I,J) 459 RETURN 460 END 461C 462C========================================================================== 463C 464 SUBROUTINE R00005(COORD,JUMP) 465 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 466 INCLUDE 'SIZES' 467 PARAMETER (MXDIM=MAXPAR+NUMATM) 468 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 469 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 470 DIMENSION COORD(3,NUMATM),HELP(3) 471 WRITE(6,'('' == symtrz.f R00005 =='')') 472 IF(JUMP.LT.0) GOTO 3 473 DO 2 I=1,NUMAT 474 DO 1 J=1,3 475 1 HELP(J)=COORD(J,I) 476 DO 2 J=1,3 477 COORD(J,I)=0.D0 478 DO 2 K=1,3 479 2 COORD(J,I)=COORD(J,I)+R(K,J)*HELP(K) 480 RETURN 481 3 DO 5 I=1,NUMAT 482 DO 4 J=1,3 483 4 HELP(J)=COORD(J,I) 484 DO 5 J=1,3 485 COORD(J,I)=0.D0 486 DO 5 K=1,3 487 5 COORD(J,I)=COORD(J,I)+R(J,K)*HELP(K) 488 RETURN 489 END 490C 491C======================================================================== 492C 493 SUBROUTINE R00006(IOPER,IPLACE) 494 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 495 INCLUDE 'SIZES' 496 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 497 DIMENSION J(3,20) 498 DATA J(1, 1),J(2, 1),J(3, 1) / 1 , -1 , -1 / 499 DATA J(1, 2),J(2, 2),J(3, 2) / -1 , 1 , -1 / 500 DATA J(1, 3),J(2, 3),J(3, 3) / -1 , -1 , 1 / 501 DATA J(1, 4),J(2, 4),J(3, 4) / 1 , 1 , -1 / 502 DATA J(1, 5),J(2, 5),J(3, 5) / 1 , -1 , 1 / 503 DATA J(1, 6),J(2, 6),J(3, 6) / -1 , 1 , 1 / 504 DATA J(1, 7),J(2, 7),J(3, 7) / -1 , -1 , -1 / 505 DATA J(1, 8),J(2, 8),J(3, 8) / 3 , 0 , 1 / 506 DATA J(1, 9),J(2, 9),J(3, 9) / 4 , 0 , 1 / 507 DATA J(1,10),J(2,10),J(3,10) / 5 , 0 , 1 / 508 DATA J(1,11),J(2,11),J(3,11) / 6 , 0 , 1 / 509 DATA J(1,12),J(2,12),J(3,12) / 7 , 0 , 1 / 510 DATA J(1,13),J(2,13),J(3,13) / 8 , 0 , 1 / 511 DATA J(1,14),J(2,14),J(3,14) / 4 , 0 , -1 / 512 DATA J(1,15),J(2,15),J(3,15) / 6 , 0 , -1 / 513 DATA J(1,16),J(2,16),J(3,16) / 8 , 0 , -1 / 514 DATA J(1,17),J(2,17),J(3,17) / 10 , 0 , -1 / 515 DATA J(1,18),J(2,18),J(3,18) / 12 , 0 , -1 / 516 DATA J(1,19),J(2,19),J(3,19) / 5 , 0 , -1 / 517 DATA J(1,20),J(2,20),J(3,20) / 0 , 0 , -1 / 518 DATA TWOPI / 6.283185308D0 / 519 WRITE(6,'('' == symtrz.f R00006 =='')') 520 DO 2 I=1,3 521 DO 1 K=1,3 522 1 ELEM(I,K,IPLACE)=0. 523 2 ELEM(I,I,IPLACE)=J(I,IOPER) 524 IF(IOPER.EQ.20) GOTO 4 525 IF(J(1,IOPER).LT.2) GOTO 3 526 ANGLE=TWOPI/FLOAT(J(1,IOPER)) 527 ELEM(1,1,IPLACE)=COS(ANGLE) 528 ELEM(2,2,IPLACE)=ELEM(1,1,IPLACE) 529 ELEM(2,1,IPLACE)=SIN(ANGLE) 530 ELEM(1,2,IPLACE)=-ELEM(2,1,IPLACE) 531 3 IF((IOPER.EQ.8).OR.(IOPER.EQ.15)) CALL R00004(CUB,IPLACE) 532 RETURN 533 4 ELEM(1,2,IPLACE)=1.D0 534 ELEM(2,1,IPLACE)=1.D0 535 RETURN 536 END 537C 538C====================================================================== 539C 540 SUBROUTINE R00007(NAT,COORD,IOPER) 541 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 542 INCLUDE 'SIZES' 543 DIMENSION NAT(NUMATM),COORD(3,NUMATM),HELP(3),E(3,3) 544 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 545 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 546 DATA TOLER / 0.01 D0/ 547 WRITE(6,'('' == symtrz.f R00007 =='')') 548 IRESUL=1 549 IQUAL=0 550 DO 2 I=1,NUMAT 551 HELP(1)=COORD(1,I)*ELEM(1,1,IOPER)+COORD(2,I)*ELEM(1,2,IOPER) 552 . +COORD(3,I)*ELEM(1,3,IOPER) 553 HELP(2)=COORD(1,I)*ELEM(2,1,IOPER)+COORD(2,I)*ELEM(2,2,IOPER) 554 . +COORD(3,I)*ELEM(2,3,IOPER) 555 HELP(3)=COORD(1,I)*ELEM(3,1,IOPER)+COORD(2,I)*ELEM(3,2,IOPER) 556 . +COORD(3,I)*ELEM(3,3,IOPER) 557 DO 1 J=1,NUMAT 558 IF(NAT(I).NE.NAT(J)) GOTO 1 559 IF(ABS(COORD(1,J)-HELP(1)).GT.TOLER) GOTO 1 560 IF(ABS(COORD(2,J)-HELP(2)).GT.TOLER) GOTO 1 561 IF(ABS(COORD(3,J)-HELP(3)).GT.TOLER) GOTO 1 562 JELEM(IOPER,I)=J 563 IF(I.EQ.J) IQUAL=IQUAL+1 564 GOTO 2 565 1 CONTINUE 566 IRESUL=0 567 2 CONTINUE 568 IELEM(IOPER)=IRESUL 569 RETURN 570 END 571C 572C===================================================================== 573C 574 SUBROUTINE R00008(IGROUP,NCODE) 575 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 576 INCLUDE 'SIZES' 577 PARAMETER (MXDIM=MAXPAR+NUMATM) 578 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 579 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 580 COMMON/SYMRES/TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 581 INTEGER C1(3),CS(7),CI(7),C2(7),C3(9),C4(16),C5(19),C6(29), 582 . C7(33),C8(46),D2(21),D3(13),D4(31),D5(21),D6(43), 583 . C2V(21),C3V(13),C4V(31),C5V(21),C6V(43), 584 . C2H(21),C3H(29),C4H(55),C5H(67),C6H(105), 585 . D2H(73),D3H(43),D4H(111),D5H(73),D6H(157), 586 . D2D(31),D3D(43),D4D(57),D5D(73),D6D(91), 587 . S4(16),S6(29),S8(46), 588 . TD(31),OH(111),IH(111),CV(10),DH(25) 589 DIMENSION J(43),JTAB(1844),ISIGMA(43) 590 EQUIVALENCE (JTAB( 1),C1(1)),(JTAB( 4),CS(1)) 591 EQUIVALENCE (JTAB( 11),CI(1)),(JTAB( 18),C2(1)) 592 EQUIVALENCE (JTAB( 25),C3(1)),(JTAB( 34),C4(1)) 593 EQUIVALENCE (JTAB( 50),C5(1)),(JTAB( 69),C6(1)) 594 EQUIVALENCE (JTAB( 98),C7(1)),(JTAB( 131),C8(1)) 595 EQUIVALENCE (JTAB( 177),D2(1)),(JTAB( 198),D3(1)) 596 EQUIVALENCE (JTAB( 211),D4(1)),(JTAB( 242),D5(1)) 597 EQUIVALENCE (JTAB( 263),D6(1)),(JTAB( 306),C2V(1)) 598 EQUIVALENCE (JTAB( 327),C3V(1)),(JTAB( 340),C4V(1)) 599 EQUIVALENCE (JTAB( 371),C5V(1)),(JTAB( 392),C6V(1)) 600 EQUIVALENCE (JTAB( 435),C2H(1)),(JTAB( 456),C3H(1)) 601 EQUIVALENCE (JTAB( 485),C4H(1)),(JTAB( 540),C5H(1)) 602 EQUIVALENCE (JTAB( 607),C6H(1)),(JTAB( 712),D2H(1)) 603 EQUIVALENCE (JTAB( 785),D3H(1)),(JTAB( 828),D4H(1)) 604 EQUIVALENCE (JTAB( 939),D5H(1)),(JTAB(1012),D6H(1)) 605 EQUIVALENCE (JTAB(1169),D2D(1)),(JTAB(1200),D3D(1)) 606 EQUIVALENCE (JTAB(1243),D4D(1)),(JTAB(1300),D5D(1)) 607 EQUIVALENCE (JTAB(1373),D6D(1)),(JTAB(1464),S4(1)) 608 EQUIVALENCE (JTAB(1480),S6(1)),(JTAB(1509),S8(1)) 609 EQUIVALENCE (JTAB(1555),TD(1)),(JTAB(1586),OH(1)) 610 EQUIVALENCE (JTAB(1697),IH(1)) 611 EQUIVALENCE (JTAB(1808),CV(1)),(JTAB(1818),DH(1)) 612 DATA J( 1),J( 2),J( 3),J( 4)/ 1010001, 2020004, 2020011, 2020018 / 613 DATA J( 5),J( 6),J( 7),J( 8)/ 3020025, 4030034, 5030050, 6040069 / 614 DATA J( 9),J(10),J(11),J(12)/ 7040098, 8050131, 4040177, 3030198 / 615 DATA J(13),J(14),J(15),J(16)/ 5050211, 4040242, 6060263, 4040306 / 616 DATA J(17),J(18),J(19),J(20)/ 3030327, 5050340, 4040371, 6060392 / 617 DATA J(21),J(22),J(23),J(24)/ 4040435, 6040456, 8060485,10060540 / 618 DATA J(25),J(26),J(27),J(28)/12080607, 8080712, 6060785,10100828 / 619 DATA J(29),J(30),J(31),J(32)/ 8080939,12121012, 5051169, 6061200 / 620 DATA J(33),J(34),J(35),J(36)/ 7071243, 8081300, 9091373, 4031464 / 621 DATA J(37),J(38),J(39),J(40)/ 6041480, 8051509, 5051555,10101586 / 622 DATA J(41),J(42),J(43) /10101697, 2031808, 3061818 / 623 DATA ISIGMA / 1,1,1,2,3,4,5,6,7,8,4,6,8,10,12,2,3,4,5,6,2,3,4,5,6, 624 . 4,6,8,10,12,4,6,8,10,12,2,3,4,12,24,60,1,2 / 625 DATA C1 626 ./ 2HC1, 627 .4HA , 0 / 628 DATA CS 629 ./ 2HCS, 630 .4HA , 8 , 20104 , 631 .4HA , 1 , -1 / 632 DATA CI 633 ./ 2HCI, 634 .4HAG , 64 , 10107 , 635 .4HAU , 1 , -1 / 636 DATA C2 637 ./ 2HC2, 638 .4HA , 4 , 2140103 , 639 .4HB , 1 , -1 / 640 DATA C3 641 ./ 2HC3, 642 .4HA , 128 , 3140108 , 3240122 , 643 .4HE , 2 , -1 , -1 / 644 DATA C4 645 ./ 2HC4, 646 .4HA , 260 ,4140109 ,2140103 ,4340123 , 647 .4HB , 1 , -1 , 1 , -1 , 648 .4HE , 2 , 0 , -2 , 0 / 649 DATA C5 650 ./ 2HC5, 651 .2HA , 512 , 5140110 , 5240122 , 5340123 ,5440124, 652 .2HE1 , 2 , 51 , 52 , 52 , 51 , 653 .2HE2 , 2 , 52 , 51 , 51 , 52 / 654 DATA C6 655 ./ 2HC6, 656 .2HA , 1156 ,6140111 ,3140108 ,2140103 ,3240133 ,6540125 , 657 .2HB , 1 , -1 , 1 , -1 , 1 , -1 , 658 .2HE1 , 2 , 1 , -1 , -2 , -1 , 1 , 659 .2HE2 , 2 , -1 , -1 , 2 , -1 , -1 / 660 DATA C7 661 ./ 2HC7, 662 .2HA ,2048,7140112,7240122,7340123,7440124,7540125,7640126, 663 .2HE1 , 2 , 71 , 72 , 73 , 73 , 72 , 71 , 664 .2HE2 , 2 , 72 , 73 , 71 , 71 , 73 , 72 , 665 .2HE3 , 2 , 73 , 71 , 72 , 72 , 71 , 73 / 666 DATA C8 667 ./ 2HC8, 668 .2HA ,4356,8140113,4140109,2140103,4340134,8340123,8540124,8740125, 669 .2HB , 1 , -1 , 1 , 1 , 1 , -1 , -1 , -1 , 670 .2HE1 , 2 , 81 , 0 , -2 , 0 , 83 , 83 , 81 , 671 .2HE2 , 2 , 0 , -2 , 2 , -2 , 0 , 0 , 0 , 672 .2HE3 , 2 , 83 , 0 , -2 , 0 , 81 , 81 , 83 / 673 DATA D2 674 ./ 2HD2, 675 .4HA , 7 ,2140103 ,2140102 ,2140101 , 676 .4HB1 , 1 , 1 , -1 , -1 , 677 .4HB2 , 1 , -1 , 1 , -1 , 678 .4HB3 , 1 , -1 , -1 , 1 / 679 DATA D3 680 ./ 2HD3, 681 .4HA1 , 129 , 3140208 , 2140301 , 682 .4HA2 , 1 , 1 , -1 , 683 .4HE , 2 , -1 , 0 / 684 DATA D4 685 ./ 2HD4, 686 .2HA1 , 263 , 4140209 , 2140103 ,2140201 ,2140220 , 687 .2HA2 , 1 , 1 , 1 , -1 , -1 , 688 .2HB1 , 1 , -1 , 1 , 1 , -1 , 689 .2HB2 , 1 , -1 , 1 , -1 , 1 , 690 .2HE , 2 , 0 , -2 , 0 , 0 / 691 DATA D5 692 ./ 2HD5, 693 .4HA1 , 513 ,5140210 ,5240222 , 2140501 , 694 .4HA2 , 1 , 1 , 1 , -1 , 695 .4HE1 , 2 , 51 , 52 , 0 , 696 .4HE2 , 2 , 52 , 51 , 0 / 697 DATA D6 698 ./ 2HD6, 699 .2HA1 , 1159 ,6140211 ,3140208 ,2140103 ,2140301 ,2140302 , 700 .2HA2 , 1 , 1 , 1 , 1 , -1 , -1 , 701 .2HB1 , 1 , -1 , 1 , -1 , 1 , -1 , 702 .2HB2 , 1 , -1 , 1 , -1 , -1 , 1 , 703 .2HE1 , 2 , 1 , -1 , -2 , 0 , 0 , 704 .2HE2 , 2 , -1 , -1 , 2 , 0 , 0 / 705 DATA C2V 706 ./ 3HC2V, 707 .4HA1 , 52 ,2140103 , 20105 , 20106 , 708 .4HA2 , 1 , 1 , -1 , -1 , 709 .4HB1 , 1 , -1 , 1 , -1 , 710 .4HB2 , 1 , -1 , -1 , 1 / 711 DATA C3V 712 ./ 3HC3V, 713 .4HA1 , 144 ,3140208 , 20305 , 714 .4HA2 , 1 , 1 , -1 , 715 .4HE , 2 , -1 , 0 / 716 DATA C4V 717 ./ 3HC4V, 718 .2HA1 , 308 ,4140209 ,2140103 , 20205 ,20224 , 719 .2HA2 , 1 , 1 , 1 , -1 , -1 , 720 .2HB1 , 1 , -1 , 1 , 1 , -1 , 721 .2HB2 , 1 , -1 , 1 , -1 , 1 , 722 .2HE , 2 , 0 , -2 , 0 , 0 / 723 DATA C5V 724 ./ 3HC5V, 725 .4HA1 , 528 , 5140210 , 5240222 , 20505 , 726 .4HA2 , 1 , 1 , 1 , -1 , 727 .4HE1 , 2 , 51 , 52 , 0 , 728 .4HE2 , 2 , 52 , 51 , 0 / 729 DATA C6V 730 ./ 3HC6V, 731 .2HA1 , 1204 , 6140211, 3140208,2140103 , 20305 , 20306 , 732 .2HA2 , 1 , 1 , 1 , 1 , -1 , -1 , 733 .2HB1 , 1 , -1 , 1 , -1 , 1 , -1 , 734 .2HB2 , 1 , -1 , 1 , -1 , -1 , 1 , 735 .2HE1 , 2 , 1 , -1 , -2 , 0 , 0 , 736 .2HE2 , 2 , -1 , -1 , 2 , 0 , 0 / 737 DATA C2H 738 ./ 3HC2H, 739 .4HAG , 76 ,2140103 , 10107 , 20104 , 740 .4HBG , 1 , -1 , 1 , -1 , 741 .4HAU , 1 , 1 , -1 , -1 , 742 .4HBU , 1 , -1 , -1 , 1 / 743 DATA C3H 744 ./ 3HC3H, 745 .2HA , 136 , 3140108, 3240122, 20104, 3130124,3530143 , 746 .2HE , 2 , -1 , -1 , 2 , -1 , -1 , 747 .2HA , 1 , 1 , 1 , -1 , -1 , -1 , 748 .2HE , 2 , -1 , -1 , -2 , 1 , 1 / 749 DATA C4H 750 ./ 3HC4H, 751 .2HAG ,8524,4140109,2140103,4340123,10107,4330152,20104,4130114, 752 .2HBG , 1 , -1 , 1 , -1 , 1 , -1 , 1 , -1 , 753 .2HEG , 2 , 0 , -2 , 0 , 2 , 0 , -2 , 0 , 754 .2HAU , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , 755 .2HBU , 1 , -1 , 1 , -1 , -1 , 1 , -1 , 1 , 756 .2HEU , 2 , 0 , -2 , 0 , -2 , 0 , 2 , 0 / 757 DATA C5H 758 ./ 3HC5H, 759 .2HA ,520,5140110,5240122,5340123,5440124,20104,5130119,5730163, 760 . 5330164,5930165, 761 .3HE1 , 2 , 51 , 52 ,52 , 51 , 2 , 51 , 52 , 52 , 51 , 762 .3HE2 , 2 , 52 , 51 ,51 , 52 , 2 , 52 , 51 , 51 , 52 , 763 .2HA , 1 , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , 764 .3HE1 , 2 , 51 , 52 ,52 , 51 , -2 ,103 ,101 ,101 ,103 , 765 .3HE2 , 2 , 52 , 51 ,51 , 52 , -2 ,101 ,103 ,103 ,101 / 766 DATA C6H 767 ./ 3HC6H, 768 .2HAG ,17612,6140111,3140108,2140103,3240133,6540125,10107,20104, 769 . 3530127,6530137,6130115,3130183, 770 .3HBG , 1 , -1 , 1 , -1 , 1 , -1 , 1 , -1 , -1 , 1 , 1 , -1 , 771 .3HE1G, 2 , 1 , -1 , -2 , -1 , 1 , 2 , -2 , 1 , -1 , -1 , 1 , 772 .3HE2G, 2 , -1 , -1 , 2 , -1 , -1 , 2 , 2 , -1 , -1 , -1 , -1 , 773 .3HAU , 1 , 1 , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , -1 , 774 .3HBU , 1 , -1 , 1 , -1 , 1 , -1 , -1 , 1 , 1 , -1 , -1 , 1 , 775 .3HE1U, 2 , 1 , -1 , -2 , -1 , 1 , -2 , 2 , -1 , 1 , 1 , -1 , 776 .3HE2U, 2 , -1 , -1 , 2 , -1 , -1 , -2 , -2 , 1 , 1 , 1 , 1 / 777 DATA D2H 778 ./ 3HD2H, 779 .2HAG, 127,2140103,2140102,2140101, 10107, 20104,20105,20106, 780 .3HB1G, 1 , 1 , -1 , -1 , 1 , 1 , -1 , -1, 781 .3HB2G, 1 , -1 , 1 , -1 , 1 , -1 , 1 , -1, 782 .3HB3G, 1 , -1 , -1 , 1 , 1 , -1 , -1 , 1, 783 .3HAU , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1, 784 .3HB1U, 1 , 1 , -1 , -1 , -1 , -1 , 1 , 1, 785 .3HB2U, 1 , -1 , 1 , -1 , -1 , 1 , -1 , 1, 786 .3HB3U, 1 , -1 , -1 , 1 , -1 , 1 , 1 , -1/ 787 DATA D3H 788 ./ 3HD3H, 789 .3HA1 , 153 ,3140208 ,2140301 , 20104 ,3130224 , 20305 , 790 .3HA2 , 1 , 1 , -1 , 1 , 1 , -1 , 791 .3HE , 2 , -1 , 0 , 2 , -1 , 0 , 792 .3HA1 , 1 , 1 , 1 , -1 , -1 , -1 , 793 .3HA2 , 1 , 1 , -1 , -1 , -1 , 1 , 794 .3HE , 2 , -1 , 0 , -2 , 1 , 0 / 795 DATA D4H 796 ./ 3HD4H, 797 .3HA1G ,8575,4140209,2140103,2140201,2140220,10107,4130214,20104, 798 . 20205,20229, 799 .3HA2G , 1 , 1 , 1 , -1 , -1 , 1 , 1 , 1 , -1 , -1 , 800 .3HB1G , 1 , -1 , 1 , 1 , -1 , 1 , -1 , 1 , 1 , -1 , 801 .3HB2G , 1 , -1 , 1 , -1 , 1 , 1 , -1 , 1 , -1 , 1 , 802 .3HEG , 2 , 0 , -2 , 0 , 0 , 2 , 0 , -2 , 0 , 0 , 803 .3HA1U , 1 , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , 804 .3HA2U , 1 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , 1 , 1 , 805 .3HB1U , 1 , -1 , 1 , 1 , -1 , -1 , 1 , -1 , -1 , 1 , 806 .3HB2U , 1 , -1 , 1 , -1 , 1 , -1 , 1 , -1 , 1 , -1 , 807 .3HEU , 2 , 0 , -2 , 0 , 0 , -2 , 0 , 2 , 0 , 0 / 808 DATA D5H 809 ./ 3HD5H, 810 .3HA1 ,537, 5140210, 5240222,2140501,20104,5130219, 5330263,20505, 811 .3HA2 , 1 , 1 , 1 , -1 , 1 , 1 , 1 , -1 , 812 .3HE1 , 2 , 51 , 52 , 0 , 2 , 51 , 52 , 0 , 813 .3HE2 , 2 , 52 , 51 , 0 , 2 , 52 , 51 , 0 , 814 .3HA1 , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , 815 .3HA2 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , 1 , 816 .3HE1 , 2 , 51 , 52 , 0 , -2 , 103 , 101 , 0 , 817 .3HE2 , 2 , 52 , 51 , 0 , -2 , 101 , 103 , 0 / 818 DATA D6H 819 ./ 3HD6H, 820 .3HA1G ,17663,6140211,3140208,2140103,2140301,2140302,10107,20104, 821 . 6130215,3130238,20306,20305, 822 .3HA2G , 1, 1, 1, 1, -1, -1, 1, 1, 1, 1, -1, -1, 823 .3HB1G , 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 1, -1, 824 .3HB2G , 1, -1, 1, -1, -1, 1, 1, -1, 1, -1, -1, 1, 825 .3HE1G , 2, 1, -1, -2, 0, 0, 2, -2, -1, 1, 0, 0, 826 .3HE2G , 2, -1, -1, 2, 0, 0, 2, 2, -1, -1, 0, 0, 827 .3HA1U , 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 828 .3HA2U , 1, 1, 1, 1, -1, -1, -1, -1, -1, -1, 1, 1, 829 .3HB1U , 1, -1, 1, -1, 1, -1, -1, 1, -1, 1, -1, 1, 830 .3HB2U , 1, -1, 1, -1, -1, 1, -1, 1, -1, 1, 1, -1, 831 .3HE1U , 2, 1, -1, -2, 0, 0, -2, 2, 1, -1, 0, 0, 832 .3HE2U , 2, -1, -1, 2, 0, 0, -2, -2, 1, 1, 0, 0/ 833 DATA D2D 834 ./ 3HD2D, 835 .2HA1 , 8244 ,4130214 , 2140103 ,2140220 ,20205 , 836 .2HA2 , 1 , 1 , 1 , -1 , -1 , 837 .2HB1 , 1 , -1 , 1 , 1 , -1 , 838 .2HB2 , 1 , -1 , 1 , -1 , 1 , 839 .2HE , 2 , 0 , -2 , 0 , 0 / 840 DATA D3D 841 ./ 3HD3D, 842 .3HA1G,16594 ,3140208 ,2140302 , 10107 ,6130215 , 20305 , 843 .3HA2G, 1 , 1 , -1 , 1 , 1 , -1 , 844 .3HEG , 2 , -1 , 0 , 2 , -1 , 0 , 845 .3HA1U, 1 , 1 , 1 , -1 , -1 , -1 , 846 .3HA2U, 1 , 1 , -1 , -1 , -1 , 1 , 847 .3HEU , 2 , -1 , 0 , -2 , 1 , 0 / 848 DATA D4D 849 ./ 3HD4D, 850 .3HA1 ,33076,8130216 ,4140209, 8330223,2140103,20405,2140426, 851 .3HA2 , 1 , 1 , 1 , 1 , 1 , -1 , -1 , 852 .3HB1 , 1 , -1 , 1 , -1 , 1 , -1 , 1 , 853 .3HB2 , 1 , -1 , 1 , -1 , 1 , 1 , -1 , 854 .3HE1 , 2 , 81 , 0 , 83 , -2 , 0 , 0 , 855 .3HE2 , 2 , 0 , -2 , 0 , 2 , 0 , 0 , 856 .3HE3 , 2 , 83 , 0 , 81 , -2 , 0 , 0 / 857 DATA D5D 858 ./ 3HD5D, 859 .3HA1G ,66130,5140210,5240222,2140502,10107,10130217, 860 . 10330226,20505, 861 .3HA2G , 1 , 1 , 1 , -1 , 1 , 1 , 1 , -1 , 862 .3HE1G , 2 , 51 , 52 , 0 , 2 , 52 , 51 , 0 , 863 .3HE2G , 2 , 52 , 51 , 0 , 2 , 51 , 52 , 0 , 864 .3HA1U , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , 865 .3HA2U , 1 , 1 , 1 , -1 , -1 , -1 , -1 , 1 , 866 .3HE1U , 2 , 51 , 52 , 0 , -2 , 101 , 103 , 0 , 867 .3HE2U , 2 , 52 , 51 , 0 , -2 , 103 , 101 , 0 / 868 DATA D6D 869 ./ 3HD6D, 870 .2HA1 ,140468,12130218,6140211,4130214,3140208,12530225,2140103, 871 . 20605,2140620, 872 .3HA2 , 1 , 1 , 1 , 1 , 1 , 1 , 1 ,-1 ,-1 , 873 .3HB1 , 1 , -1 , 1 ,-1 , 1 , -1 , 1 ,-1 , 1 , 874 .3HB2 , 1 , -1 , 1 ,-1 , 1 , -1 , 1 , 1 ,-1 , 875 .3HE1 , 2 , 121 , 1 , 0 ,-1 , 125 ,-2 , 0 , 0 , 876 .3HE2 , 2 , 1 ,-1 ,-2 ,-1 , 1 , 2 , 0 , 0 , 877 .3HE3 , 2 , 0 ,-2 , 0 , 2 , 0 ,-2 , 0 , 0 , 878 .3HE4 , 2 , -1 ,-1 , 2 ,-1 , -1 , 2 , 0 , 0 , 879 .3HE5 , 2 , 125 , 1 , 0 ,-1 , 121 ,-2 , 0 , 0 / 880 DATA S4 881 ./ 3HS4 , 882 .4HA , 8196 , 4130114, 2140103, 4330123 , 883 .4HB , 1 , -1 , 1 , -1 , 884 .4HE , 2 , 0 , -2 , 0 / 885 DATA S6 886 ./ 3HS6 , 887 .3HAG ,16576 ,3140108 ,3240122 , 10107 , 6530124 , 6130115 , 888 .3HEG , 2 , -1 , -1 , 2 , -1 , -1 , 889 .3HAU , 1 , 1 , 1 , -1 , -1 , -1 , 890 .3HEU , 2 , -1 , -1 , -2 , 1 , 1 / 891 DATA S8 892 ./ 3HS8 , 893 .3HA ,33028,8130116,4140109,8330123,2140103,8530125,4340135, 894 . 8730127, 895 .3HB , 1, -1 , 1, -1 , 1, -1 , 1, -1 , 896 .3HE1 , 2, 81 , 0, 83 ,-2, 83 , 0, 81 , 897 .3HE2 , 2, 0 ,-2, 0 , 2, 0 ,-2, 0 , 898 .3HE3 , 2, 83 , 0, 81 ,-2, 81 , 0, 83 / 899 DATA TD 900 ./ 3HTD , 901 .2HA1 ,270516 , 3140808, 2140303, 4130614, 20605 , 902 .2HA2 , 1 , 1 , 1 , -1 , -1 , 903 .2HE , 2 , -1 , 2 , 0 , 0 , 904 .2HT1 , 3 , 0 , -1 , 1 , -1 , 905 .2HT2 , 3 , 0 , -1 , -1 , 1 / 906 DATA OH 907 ./ 3HOH , 908 .3HA1G ,287231,3140808,2140601,4140609,2140303,10107,4130614, 909 . 6130815,20304,20605, 910 .3HA2G , 1 , 1 , -1 , -1 , 1 , 1 , -1 , 1 , 1 , -1 , 911 .3HEG , 2 , -1 , 0 , 0 , 2 , 2 , 0 , -1 , 2 , 0 , 912 .3HT1G , 3 , 0 , -1 , 1 , -1 , 3 , 1 , 0 , -1 , -1 , 913 .3HT2G , 3 , 0 , 1 , -1 , -1 , 3 , -1 , 0 , -1 , 1 , 914 .3HA1U , 1 , 1 , 1 , 1 , 1 , -1 , -1 , -1 , -1 , -1 , 915 .3HA2U , 1 , 1 , -1 , -1 , 1 , -1 , 1 , -1 , -1 , 1 , 916 .3HEU , 2 , -1 , 0 , 0 , 2 , -2 , 0 , 1 , -2 , 0 , 917 .3HT1U , 3 , 0 , -1 , 1 , -1 , -3 , -1 , 0 , 1 , 1 , 918 .3HT2U , 3 , 0 , 1 , -1 , -1 , -3 , 1 , 0 , 1 , -1 / 919 DATA IH 920 ./ 3HIH , 921 .3HAG ,344786,5141210,5241222,3142008,2141502,10107,10131217, 922 . 10331227,6132015,21505, 923 .3HT1G,3, 101 , 103 , 0,-1, 3, 103 , 101 , 0 ,-1 , 924 .3HT2G,3, 103 , 101 , 0,-1, 3, 101 , 103 , 0 ,-1 , 925 .3HGG ,4, -1 , -1 , 1, 0, 4, -1 , -1 , 1 , 0 , 926 .3HHG ,5, 0 , 0 ,-1, 1, 5, 0 , 0 ,-1 , 1 , 927 .3HAU ,1, 1 , 1 , 1, 1,-1, -1 , -1 ,-1 ,-1 , 928 .3HT1U,3, 101 , 103 , 0,-1,-3, 51 , 52 , 0 , 1 , 929 .3HT2U,3, 103 , 101 , 0,-1,-3, 52 , 51 , 0 , 1 , 930 .3HGU ,4, -1 , -1 , 1, 0,-4, 1 , 1 ,-1 , 0 , 931 .3HHU ,5, 0 , 0 ,-1, 1,-5, 0 , 0 , 1 ,-1 / 932 DATA CV 933 ./ 3HC*V, 934 .3HSI , 524340 , 4140109 , 935 .3HPI , 2 , 0 , 936 .3HDE , 2 , -2 / 937 DATA DH 938 ./ 3HD*H, 939 .3HSIG , 524415 , 4140109 , 10107 , 940 .3HPIG , 2 , 0 , 2 , 941 .3HDEG , 2 , -2 , 2 , 942 .3HSIU , 1 , 1 , -1 , 943 .3HPIU , 2 , 0 , -2 , 944 .3HDEU , 2 , -2 , -2 / 945 WRITE(6,'('' == symtrz.f R00008 =='')') 946 SIG=1.D0 947 I=IGROUP 948 IF(NCODE.LT.0) GOTO 2 949 IGROUP=0 950 DO 1 I=1,43 951 ICHECK=J(I)/10000 952 ICHECK=J(I)-10000*ICHECK+2 953 ICHECK=JTAB(ICHECK) 954 IF(ICHECK.EQ.NCODE) GOTO 2 955 1 CONTINUE 956 RETURN 957 2 IGROUP=I 958 JGROUP=J(IGROUP) 959 J1=JGROUP/1000000 960 KDIM=JGROUP-1000000*J1 961 I1=KDIM/10000 962 JGROUP=KDIM-10000*I1 963 NAME=JTAB(JGROUP) 964 SIG=ISIGMA(IGROUP) 965 J2=0 966 DO 4 I=1,I1 967 JGROUP=JGROUP+1 968 JX(1,I)=JTAB(JGROUP) 969 DO 4 K=1,J1 970 JGROUP=JGROUP+1 971 BUFF=JTAB(JGROUP) 972 IF(I.GT.1) GOTO 3 973 JX(2,K)=JTAB(JGROUP)/100 974 JX(3,K)=JTAB(JGROUP)-100*JX(2,K) 975 JX(4,K)=JX(2,K)/100 976 JX(5,K)=JX(2,K)-100*JX(4,K) 977 JX(2,K)=JX(5,K) 978 JX(5,K)=JX(4,K)/10 979 JX(4,K)=JX(4,K)-10*JX(5,K) 980 JX(2,1)=1 981 JX(3,1)=0 982 J2=J2+JX(2,K) 983 BUFF=1.D0 984 3 IF(BUFF.LT.10.) GOTO 4 985 NZZ=JTAB(JGROUP) 986 NZ=NZZ/10 987 FZ=NZ 988 FN=NZZ-10*NZ 989 BUFF=2.D0*COS(6.283185307179D0*FN/FZ) 990 4 T(I,K)=BUFF 991 LINA=IGROUP-41 992 RETURN 993 END 994C 995C================================================================ 996C 997 SUBROUTINE R00009(NAT,COORD) 998 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 999 INCLUDE 'SIZES' 1000 PARAMETER (MXDIM=MAXPAR+NUMATM) 1001 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1002 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1003 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1004 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1005 DIMENSION HELP(3,3),NAT(NUMATM),COORD(3,NUMATM) 1006 WRITE(6,'('' == symtrz.f R00009 =='')') 1007 DO 1 I=1,3 1008 DO 1 J=1,NUMAT 1009 1 COORD(I,J)=COORD(I,J)-SHIFT(I) 1010 CALL R00005(COORD,1) 1011 IF(J1.LT.2) RETURN 1012 DO 5 I=2,J1 1013 JOTA=JX(3,I) 1014 JOT=1 1015 IF(JOTA.LE.20) GOTO 2 1016 JOTB=JOTA/10 1017 JOT=JOTA-10*JOTB 1018 JOTA=JX(3,JOTB) 1019 2 CALL R00006(JOTA,I) 1020 IF(JOT.EQ.1) GOTO 5 1021 DO 3 J=1,3 1022 DO 3 K=1,3 1023 HELP(J,K)=0.D0 1024 DO 3 L=1,3 1025 3 HELP(J,K)=HELP(J,K)+ELEM(J,L,JOT)*ELEM(L,K,I) 1026 DO 4 J=1,3 1027 DO 4 K=1,3 1028 4 ELEM(J,K,I)=HELP(J,K) 1029 5 CONTINUE 1030 DO 6 I=2,J1 1031 CALL R00007(NAT,COORD,I) 1032 JX(6,I)=IQUAL 1033 IF(IELEM(I).LT.1) IERROR=5 1034 6 CONTINUE 1035 CALL R00005(COORD,-1) 1036 DO 7 I=1,3 1037 DO 7 J=1,NUMAT 1038 7 COORD(I,J)=COORD(I,J)+SHIFT(I) 1039 RETURN 1040 END 1041C 1042C=================================================================== 1043C 1044 SUBROUTINE R00010(COEFF,NTYPE,ICOUNT,NCDUM) 1045 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1046 INCLUDE 'SIZES' 1047 PARAMETER (MXDIM=MAXPAR+NUMATM) 1048C CHARACTER*4 NAME,ISTA 1049C ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ; NAME is not used... 1050 CHARACTER*4 ISTA 1051 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1052 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1053 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1054 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1055 COMMON/SYMRES/TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 1056 DIMENSION NTYPE(MXDIM),COEFF(NCDUM,NCDUM) 1057 DIMENSION CHAR(12),ICOUNT(12) 1058C DATA TOLER,IFRA / 0.1, '????'/ 1059C ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 1060 INTEGER NAMES 1061 DATA TOLER,IFRA / 0.1, 0 / 1062C 1063 WRITE(6,'('' == symtrz.f R00010 =='')') 1064 NDORBS=0 1065 DO 1 I=1,I1 1066 1 ICOUNT(I)=0 1067 NAMES=IFRA 1068 IF(J1.EQ.1) NAMES=JX(1,1) 1069 DO 2 I=1,NORBS 1070 INDEX(I)=I 1071 2 NAMO(I)=NAMES 1072 IF(J1.EQ.1) RETURN 1073 IF(IERROR.GT.0) RETURN 1074 IFOUND=0 1075 I=0 1076 3 IK=I+1 1077 DO 4 J=1,J1 1078 4 CHAR(J)=0.D0 1079 5 I=I+1 1080 IF(I.GT.NORBS) GOTO 10 1081 DO 6 J=1,J1 1082 CHAR(J)=CHAR(J)+R00011(COEFF,NTYPE,I,J,NCDUM) 1083 IF(CHAR(J).GT.10.) GOTO 3 1084 6 CONTINUE 1085 DO 9 K=1,I1 1086 DO 7 J=1,J1 1087 CHECK=ABS(CHAR(J)-T(K,J)) 1088 IF(CHECK.GT.TOLER) GOTO 9 1089 7 CONTINUE 1090 ICOUNT(K)=ICOUNT(K)+1 1091 DO 8 J=IK,I 1092 IFOUND=IFOUND+1 1093 INDEX(J)=ICOUNT(K) 1094 8 NAMO(J)=JX(1,K) 1095 GOTO 3 1096 9 CONTINUE 1097 GOTO 5 1098 10 IF(IFOUND.NE.NORBS) IERROR=99 1099 RETURN 1100 END 1101C 1102C====================================================================== 1103C 1104 FUNCTION R00011(COEFF,NTYPE,JORB,IOPER,NCDUM) 1105 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1106 INCLUDE 'SIZES' 1107 PARAMETER (MXDIM=MAXPAR+NUMATM) 1108 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1109 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1110 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1111 DIMENSION NTYPE(MXDIM),COEFF(NCDUM,NCDUM),E(3,3,20) 1112 DIMENSION H(5),P(3),D(5),IP(2,3),ID(2,5),LOC(2,50) 1113 EQUIVALENCE (ELEM(1,1,1),E(1,1,1)) 1114 WRITE(6,'('' == symtrz.f R00011 =='')') 1115 R00011=1.D0 1116 IF(IOPER.EQ.1) RETURN 1117 DO 1 I=1,NORBS 1118 VECT(1,I)=0.D0 1119 1 VECT(2,I)=0.D0 1120 DO 13 IATOM=1,NUMAT 1121 JATOM=JELEM(IOPER,IATOM) 1122 KI=0 1123 KJ=0 1124 DO 3 I=1,NORBS 1125 ICHECK=NTYPE(I)/100 1126 IF(ICHECK.NE.IATOM) GOTO 2 1127 KI=KI+1 1128 LOC(1,KI)=I 1129 2 IF(ICHECK.NE.JATOM) GOTO 3 1130 KJ=KJ+1 1131 LOC(2,KJ)=I 1132 3 CONTINUE 1133 IBASE=KI 1134 DO 4 I=1,IBASE 1135 ICHECK=LOC(1,I) 1136 ITEST=NTYPE(ICHECK)-10*(NTYPE(ICHECK)/10) 1137 IF(ITEST.GT.0) GOTO 4 1138 JCHECK=LOC(2,I) 1139 LOC(1,I)=0 1140 KI=KI-1 1141 VECT(1,ICHECK)=COEFF(ICHECK,JORB) 1142 VECT(2,JCHECK)=COEFF(ICHECK,JORB) 1143 4 CONTINUE 1144 MINUS=100*IATOM 1145 5 IF(KI.LT.3) GOTO 13 1146 DO 6 I=1,3 1147 IP(1,I)=0 1148 6 ID(1,I)=0 1149 ID(1,4)=0 1150 ID(1,5)=0 1151 NQZP=-1 1152 NQZD=-1 1153 DO 9 I=1,IBASE 1154 IF(LOC(1,I).LT.1) GOTO 9 1155 ICHECK=LOC(1,I) 1156 ITEST=NTYPE(ICHECK) 1157 INQZ=(ITEST-MINUS)/10 1158 ILQZ=ITEST-10*(ITEST/10) 1159 IF(ILQZ.GT.8) GOTO 8 1160 IF(ILQZ.GT.3) GOTO 7 1161 IF(NQZP.LT.0) NQZP=INQZ 1162 IF(INQZ.NE.NQZP) GOTO 9 1163 P(ILQZ)=COEFF(ICHECK,JORB) 1164 IP(1,ILQZ)=LOC(1,I) 1165 IP(2,ILQZ)=LOC(2,I) 1166 GOTO 8 1167 7 IF(NQZD.LT.0) NQZD=INQZ 1168 IF(INQZ.NE.NQZD) GOTO 9 1169 ILQZ=ILQZ-3 1170 D(ILQZ)=COEFF(ICHECK,JORB) 1171 ID(1,ILQZ)=LOC(1,I) 1172 ID(2,ILQZ)=LOC(2,I) 1173 8 LOC(1,I)=0 1174 KI=KI-1 1175 9 CONTINUE 1176 IF(NQZP.LT.0) GOTO 11 1177 H(1)=R(1,1)*P(1)+R(2,1)*P(2)+R(3,1)*P(3) 1178 H(2)=R(1,2)*P(1)+R(2,2)*P(2)+R(3,2)*P(3) 1179 H(3)=R(1,3)*P(1)+R(2,3)*P(2)+R(3,3)*P(3) 1180 P(1)=E(1,1,IOPER)*H(1)+E(1,2,IOPER)*H(2)+E(1,3,IOPER)*H(3) 1181 P(2)=E(2,1,IOPER)*H(1)+E(2,2,IOPER)*H(2)+E(2,3,IOPER)*H(3) 1182 P(3)=E(3,1,IOPER)*H(1)+E(3,2,IOPER)*H(2)+E(3,3,IOPER)*H(3) 1183 DO 10 I=1,3 1184 IF(IP(1,I).LT.1) GOTO 16 1185 II=IP(1,I) 1186 JJ=IP(2,I) 1187 VECT(1,II)=H(I) 1188 10 VECT(2,JJ)=P(I) 1189 11 IF(NQZD.LT.0) GOTO 5 1190 CALL R00012(D,H,IOPER) 1191 DO 12 I=1,5 1192 IF(ID(1,I).LT.1) GOTO 16 1193 II=ID(1,I) 1194 JJ=ID(2,I) 1195 VECT(1,II)=H(I) 1196 12 VECT(2,JJ)=D(I) 1197 KI=KI-5 1198 GOTO 5 1199 13 CONTINUE 1200 C1=0.D0 1201 C2=0.D0 1202 DO 14 I=1,NORBS 1203 C1=C1+VECT(1,I)*VECT(1,I) 1204 14 C2=C2+VECT(1,I)*VECT(2,I) 1205 IF(ABS(C1).LT.1.E-5) GOTO 15 1206 R00011=C2/C1 1207 RETURN 1208 15 R00011=100.D0 1209 RETURN 1210 16 IERROR=98 1211 RETURN 1212 END 1213C 1214C======================================================================= 1215C 1216 SUBROUTINE R00012(D,H,IOPER) 1217 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1218 INCLUDE 'SIZES' 1219 PARAMETER (MXDIM=MAXPAR+NUMATM) 1220 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1221 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1222 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1223 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1224 DIMENSION D(5),H(5),T1(5,5,12),S(3,3) 1225 CHARACTER JX*4 1226 WRITE(6,'('' == symtrz.f R00012 =='')') 1227 IF(NDORBS.GT.0) GOTO 4 1228 NDORBS=1 1229 DO 1 I=1,3 1230 DO 1 J=1,3 1231 1 S(I,J)=R(I,J) 1232 CALL R00013(S,T1,1) 1233 DO 3 K=2,J1 1234 DO 2 I=1,3 1235 DO 2 J=1,3 1236 2 S(I,J)=ELEM(I,J,K) 1237 CALL R00013(S,T1,K) 1238 3 CONTINUE 1239 4 DO 5 I=1,5 1240 H(I)=0.D0 1241 DO 5 J=1,5 1242 5 H(I)=H(I)+T1(I,J,1)*D(J) 1243 DO 6 I=1,5 1244 D(I)=0.D0 1245 DO 6 J=1,5 1246 6 D(I)=D(I)+T1(I,J,IOPER)*H(J) 1247 RETURN 1248 END 1249C 1250C================================================================= 1251C 1252 SUBROUTINE R00013(R,T,IOPER) 1253 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1254 DIMENSION R(3,3),T(5,5,12),F(2,4) 1255 LOGICAL RIGHT 1256 DATA PI,TOL,S12 / 3.1415926536D0 ,0.001D0,3.46410161513D0 / 1257 DATA S3,ONE / 1.73205080756D0 , 1.D0 / 1258 WRITE(6,'('' == symtrz.f R00013 =='')') 1259 R1=R(2,1)*R(3,2)-R(3,1)*R(2,2) 1260 R2=R(3,1)*R(1,2)-R(1,1)*R(3,2) 1261 R3=R(1,1)*R(2,2)-R(2,1)*R(1,2) 1262 CHECK=R1*R(1,3)+R2*R(2,3)+R3*R(3,3) 1263 RIGHT=CHECK.GT.0. 1264 R(1,3)=R1 1265 R(2,3)=R2 1266 R(3,3)=R3 1267 ARG=R3 1268 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1269 B= ACOS(ARG) 1270 SINA=SQRT(1.D0-ARG*ARG) 1271 IF(SINA.LT.TOL) GOTO 1 1272 ARG=R(3,2)/SINA 1273 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1274 G= ASIN(ARG) 1275 ARG=R(2,3)/SINA 1276 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1277 A= ASIN(ARG) 1278 GOTO 2 1279 1 ARG=R(1,2) 1280 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1281 G= ASIN(ARG) 1282 A=0.D0 1283 2 F(1,1)=A 1284 F(1,2)=A 1285 F(1,3)=PI-A 1286 F(1,4)=PI-A 1287 F(2,1)=G 1288 F(2,3)=G 1289 F(2,2)=PI-G 1290 F(2,4)=PI-G 1291 DO 3 I=1,4 1292 A=F(1,I) 1293 G=F(2,I) 1294 CHECK=ABS(SIN(B)*COS(A)+R(1,3)) 1295 IF(CHECK.GT.TOL) GOTO 3 1296 CHECK=-SIN(G)*COS(B)*SIN(A)+COS(G)*COS(A) 1297 IF(ABS(CHECK-R(2,2)).GT.TOL) GOTO 3 1298 CHECK=SIN(A)*COS(G)+COS(A)*COS(B)*SIN(G) 1299 IF(ABS(CHECK-R(1,2)).LE.TOL) GOTO 4 1300 3 CONTINUE 1301 4 G=-G 1302 A=-A 1303 B=-B 1304 E1=COS(B*0.5D0) 1305 X1=-SIN(B*0.5D0) 1306 E2=E1*E1 1307 E3=E1*E2 1308 E4=E2*E2 1309 X2=X1*X1 1310 X3=X1*X2 1311 X4=X2*X2 1312 TA=2.D0*A 1313 TG=2.D0*G 1314 T(1,1,IOPER)=E4*COS(TA+TG)+X4*COS(TA-TG) 1315 T(1,2,IOPER)=2.D0*E3*X1*COS(A+TG)-2.D0*E1*X3*COS(A-TG) 1316 T(1,3,IOPER)=2.D0*S3*E2*X2*COS(TG) 1317 T(1,4,IOPER)=2.D0*E3*X1*SIN(A+TG)-2.D0*E1*X3*SIN(A-TG) 1318 T(1,5,IOPER)=E4*SIN(TA+TG)+X4*SIN(TA-TG) 1319 T(2,1,IOPER)=2.D0*E1*X3*COS(TA-G)-2.D0*E3*X1*COS(TA+G) 1320 T(2,2,IOPER)=(E4-3.D0*E2*X2)*COS(A+G)-(3.D0*E2*X2-X4)*COS(A-G) 1321 T(2,3,IOPER)=2.D0*S3*(E3*X1-E1*X3)*COS(G) 1322 T(2,4,IOPER)=(E4-3.D0*E2*X2)*SIN(A+G)-(3.D0*E2*X2-X4)*SIN(A-G) 1323 T(2,5,IOPER)=-2.D0*E3*X1*SIN(TA+G)+2.D0*E1*X3*SIN(TA-G) 1324 T(3,1,IOPER)=S12*E2*X2*COS(TA) 1325 T(3,2,IOPER)=-S12*(E3*X1-E1*X3)*COS(A) 1326 T(3,3,IOPER)=E4-4.D0*E2*X2+X4 1327 T(3,4,IOPER)=-S12*(E3*X1-E1*X3)*SIN(A) 1328 T(3,5,IOPER)=S12*E2*X2*SIN(TA) 1329 T(4,1,IOPER)=2.D0*E1*X3*SIN(TA-G)+2.D0*E3*X1*SIN(TA+G) 1330 T(4,2,IOPER)=-(E4-3.D0*E2*X2)*SIN(A+G)-(3.D0*E2*X2-X4)*SIN(A-G) 1331 T(4,3,IOPER)=-2.D0*S3*(E3*X1-E1*X3)*SIN(G) 1332 T(4,4,IOPER)=(E4-3.D0*E2*X2)*COS(A+G)+(3.D0*E2*X2-X4)*COS(A-G) 1333 T(4,5,IOPER)=-2.D0*E3*X1*COS(TA+G)-2.D0*E1*X3*COS(TA-G) 1334 T(5,1,IOPER)=-E4*SIN(TA+TG)+X4*SIN(TA-TG) 1335 T(5,2,IOPER)=-2.D0*E3*X1*SIN(A+TG)-2.D0*E1*X3*SIN(A-TG) 1336 T(5,3,IOPER)=-2.D0*S3*E2*X2*SIN(TG) 1337 T(5,4,IOPER)=2.D0*E3*X1*COS(A+TG)+2.D0*E1*X3*COS(A-TG) 1338 T(5,5,IOPER)=E4*COS(TA+TG)-X4*COS(TA-TG) 1339 IF(RIGHT) RETURN 1340 DO 5 I=1,5 1341 T(2,I,IOPER)=-T(2,I,IOPER) 1342 5 T(4,I,IOPER)=-T(4,I,IOPER) 1343 RETURN 1344 END 1345C 1346C====================================================================== 1347C 1348 SUBROUTINE R00015(F,V,EW) 1349 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1350 DIMENSION F(6),A(3,3),V(3,3),EW(3) 1351 DATA TOLER /1.E-6 / 1352 WRITE(6,'('' == symtrz.f R00015 =='')') 1353 N=3 1354 IJ=0 1355 DO 2 J=1,N 1356 DO 1 I=1,J 1357 IJ=IJ+1 1358 A(I,J)=F(IJ) 1359 A(J,I)=F(IJ) 1360 V(I,J)=0.D0 1361 1 V(J,I)=0.D0 1362 2 V(J,J)=1.D0 1363 N1=N-1 1364 ZETA=10.D0 1365 3 SS=0.D0 1366 DO 4 J=1,N1 1367 DO 4 I=J,N1 1368 IRG=I+1 1369 4 SS=SS+ABS(A(IRG,J)) 1370 IF(SS-TOLER) 21,21,5 1371 5 TAU=0.D0 1372 DO 20 I=1,N 1373 I1=I+1 1374 IF(N-I1) 20,6,6 1375 6 DO 19 J=I1,N 1376 IF(ABS(A(J,I)).LT.1.E-30) GOTO 19 1377 THETA=0.5D0*(A(J,J)-A(I,I))/A(J,I) 1378 IF(ABS(THETA)-ZETA) 7,7,19 1379 7 T=1.D0 1380 IF(THETA) 8,9,9 1381 8 T=-1.D0 1382 9 T=1.D0/(THETA+T*SQRT(1.D0+THETA*THETA)) 1383 C=1.D0/SQRT(1.D0+T*T) 1384 S=C*T 1385 H=2.D0*A(J,I) 1386 HC=S*H*(S*THETA-C) 1387 A(I,I)=A(I,I)+HC 1388 A(J,J)=A(J,J)-HC 1389 A(J,I)=-H*C*(S*THETA-0.5D0*(C-S*S/C)) 1390 TAU=TAU+1.D0 1391 IF(I.LT.2) GOTO 11 1392 DO 10 IG=2,I 1393 IRS=IG-1 1394 H=C*A(I,IRS)-S*A(J,IRS) 1395 A(J,IRS)=S*A(I,IRS)+C*A(J,IRS) 1396 10 A(I,IRS)=H 1397 11 L=J-1 1398 IF(L-I1) 14,12,12 1399 12 DO 13 IG=I1,L 1400 H=C*A(IG,I)-S*A(J,IG) 1401 A(J,IG)=S*A(IG,I)+C*A(J,IG) 1402 13 A(IG,I)=H 1403 14 IF(N1-J) 17,15,15 1404 15 DO 16 IG=J,N1 1405 ILG=IG+1 1406 H=C*A(ILG,I)-S*A(ILG,J) 1407 A(ILG,J)=S*A(ILG,I)+C*A(ILG,J) 1408 16 A(ILG,I)=H 1409 17 DO 18 IG=1,N 1410 H=C*V(IG,I)-S*V(IG,J) 1411 V(IG,J)=S*V(IG,I)+C*V(IG,J) 1412 18 V(IG,I)=H 1413 19 CONTINUE 1414 20 CONTINUE 1415 H=0.5D0*FLOAT(N*(N-1)) 1416 ZETA=ZETA**(2.5D0-TAU/H) 1417 GOTO 3 1418 21 DO 22 J=1,N 1419 22 EW(J)=A(J,J) 1420 N1=N-1 1421 23 NT=0 1422 DO 26 J=1,N1 1423 JRG=J+1 1424 IF(EW(J)-EW(JRG)) 26,26,24 1425 24 BUFFER=EW(J) 1426 EW(J)=EW(JRG) 1427 EW(JRG)=BUFFER 1428 DO 25 I=1,N 1429 BUFFER=V(I,JRG) 1430 V(I,JRG)=V(I,J) 1431 25 V(I,J)=BUFFER 1432 NT=1 1433 26 CONTINUE 1434 N1=N1-1 1435 IF(NT) 23,27,23 1436 27 RETURN 1437 END 1438C 1439C=================================================================== 1440C 1441 SUBROUTINE R00016 1442 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1443 INCLUDE 'SIZES' 1444 PARAMETER (MXDIM=MAXPAR+NUMATM) 1445 CHARACTER*4 NAME,NAMO,ISTA 1446 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1447 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1448 COMMON /SYMINF/ IBASE(2,12),NBASE,IVIBRO(2,12),IVIB 1449 COMMON/SYMRES/TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 1450 DIMENSION CHAR(12),COEFF(12) 1451 WRITE(6,'('' == symtrz.f R00016 =='')') 1452 IVIBRA=3*NUMAT-6 1453 IF(LINA.GT.0) GOTO 8 1454 CHAR(1)=IVIBRA 1455 IVIB=0 1456 IF(J1.LT.2) RETURN 1457 DO 5 I=2,J1 1458 JUMP=JX(4,I) 1459 GOTO (1,2,3,4),JUMP 1460 1 CHAR(I)=-3*JX(6,I) 1461 GOTO 5 1462 2 CHAR(I)=JX(6,I) 1463 GOTO 5 1464 3 JP=JX(5,I)/10 1465 JK=JX(5,I)-10*JP 1466 ANGLE=2.D0*COS(6.283185308D0*DBLE(JK)/DBLE(JP)) 1467 CHAR(I)=DBLE(JX(6,I))*(ANGLE-1.D0) 1468 GOTO 5 1469 4 JP=JX(5,I)/10 1470 JK=JX(5,I)-10*JP 1471 ANGLE=2.D0*COS(6.283185308D0*DBLE(JK)/DBLE(JP)) 1472 CHAR(I)=DBLE(JX(6,I)-2)*(ANGLE+1.D0) 1473 5 CHAR(I)=CHAR(I)*DBLE(JX(2,I)) 1474 ORDER=DBLE(J2) 1475 DO 7 I=1,I1 1476 COEFF(I)=0.1D0 1477 DO 6 J=1,J1 1478 6 COEFF(I)=COEFF(I)+CHAR(J)*T(I,J)/ORDER 1479 IF(COEFF(I).LT.1.) GOTO 7 1480 IDEGEN= T(I,1)+0.1D0 1481 IVIB=IVIB+1 1482 IVIBRO(1,IVIB)= COEFF(I) 1483 IF(I1.NE.J1) IVIBRO(1,IVIB)= COEFF(I) /IDEGEN 1484 IVIBRO(2,IVIB)=JX(1,I) 1485 7 CONTINUE 1486 RETURN 1487 8 IVIBRA=IVIBRA+1 1488 GOTO(9,10),LINA 1489 9 IVIBRO(1,1)=NUMAT-1 1490 IVIBRO(2,1)=JX(1,1) 1491 IVIBRO(1,2)=NUMAT-2 1492 IVIBRO(2,2)=JX(1,2) 1493 IVIB=2 1494 IF(NUMAT.LT.3) IVIB=1 1495 RETURN 1496 10 ICENT=JX(6,3) 1497 IVIBRO(1,1)=(NUMAT-ICENT)/2 1498 IVIBRO(2,1)=JX(1,1) 1499 IVIB=2 1500 IVIBRO(1,2)=(NUMAT-2-ICENT)/2 1501 IVIBRO(2,2)=JX(1,2) 1502 IF(IVIBRO(1,2).GT.0) IVIB=3 1503 IVIBRO(1,IVIB)=(NUMAT-2+ICENT)/2 1504 IVIBRO(2,IVIB)=JX(1,4) 1505 IF(IVIBRO(1,IVIB).GT.0) IVIB=IVIB+1 1506 IVIBRO(1,IVIB)=(NUMAT-2+ICENT)/2 1507 IVIBRO(2,IVIB)=JX(1,5) 1508 IF(IVIBRO(1,IVIB).LT.1) IVIB=IVIB-1 1509 RETURN 1510 END 1511