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) 1048 CHARACTER*4 NAME,ISTA 1049 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1050 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1051 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1052 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1053 COMMON/SYMRES/TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 1054 DIMENSION NTYPE(MXDIM),COEFF(NCDUM,NCDUM) 1055 DIMENSION CHAR(12),ICOUNT(12) 1056 DATA TOLER,IFRA / 0.1, '????'/ 1057C 1058 WRITE(6,'('' == symtrz.f R00010 =='')') 1059 NDORBS=0 1060 DO 1 I=1,I1 1061 1 ICOUNT(I)=0 1062 NAMES=IFRA 1063 IF(J1.EQ.1) NAMES=JX(1,1) 1064 DO 2 I=1,NORBS 1065 INDEX(I)=I 1066 2 NAMO(I)=NAMES 1067 IF(J1.EQ.1) RETURN 1068 IF(IERROR.GT.0) RETURN 1069 IFOUND=0 1070 I=0 1071 3 IK=I+1 1072 DO 4 J=1,J1 1073 4 CHAR(J)=0.D0 1074 5 I=I+1 1075 IF(I.GT.NORBS) GOTO 10 1076 DO 6 J=1,J1 1077 CHAR(J)=CHAR(J)+R00011(COEFF,NTYPE,I,J,NCDUM) 1078 IF(CHAR(J).GT.10.) GOTO 3 1079 6 CONTINUE 1080 DO 9 K=1,I1 1081 DO 7 J=1,J1 1082 CHECK=ABS(CHAR(J)-T(K,J)) 1083 IF(CHECK.GT.TOLER) GOTO 9 1084 7 CONTINUE 1085 ICOUNT(K)=ICOUNT(K)+1 1086 DO 8 J=IK,I 1087 IFOUND=IFOUND+1 1088 INDEX(J)=ICOUNT(K) 1089 8 NAMO(J)=JX(1,K) 1090 GOTO 3 1091 9 CONTINUE 1092 GOTO 5 1093 10 IF(IFOUND.NE.NORBS) IERROR=99 1094 RETURN 1095 END 1096C 1097C====================================================================== 1098C 1099 FUNCTION R00011(COEFF,NTYPE,JORB,IOPER,NCDUM) 1100 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1101 INCLUDE 'SIZES' 1102 PARAMETER (MXDIM=MAXPAR+NUMATM) 1103 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1104 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1105 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1106 DIMENSION NTYPE(MXDIM),COEFF(NCDUM,NCDUM),E(3,3,20) 1107 DIMENSION H(5),P(3),D(5),IP(2,3),ID(2,5),LOC(2,50) 1108 EQUIVALENCE (ELEM(1,1,1),E(1,1,1)) 1109 WRITE(6,'('' == symtrz.f R00011 =='')') 1110 R00011=1.D0 1111 IF(IOPER.EQ.1) RETURN 1112 DO 1 I=1,NORBS 1113 VECT(1,I)=0.D0 1114 1 VECT(2,I)=0.D0 1115 DO 13 IATOM=1,NUMAT 1116 JATOM=JELEM(IOPER,IATOM) 1117 KI=0 1118 KJ=0 1119 DO 3 I=1,NORBS 1120 ICHECK=NTYPE(I)/100 1121 IF(ICHECK.NE.IATOM) GOTO 2 1122 KI=KI+1 1123 LOC(1,KI)=I 1124 2 IF(ICHECK.NE.JATOM) GOTO 3 1125 KJ=KJ+1 1126 LOC(2,KJ)=I 1127 3 CONTINUE 1128 IBASE=KI 1129 DO 4 I=1,IBASE 1130 ICHECK=LOC(1,I) 1131 ITEST=NTYPE(ICHECK)-10*(NTYPE(ICHECK)/10) 1132 IF(ITEST.GT.0) GOTO 4 1133 JCHECK=LOC(2,I) 1134 LOC(1,I)=0 1135 KI=KI-1 1136 VECT(1,ICHECK)=COEFF(ICHECK,JORB) 1137 VECT(2,JCHECK)=COEFF(ICHECK,JORB) 1138 4 CONTINUE 1139 MINUS=100*IATOM 1140 5 IF(KI.LT.3) GOTO 13 1141 DO 6 I=1,3 1142 IP(1,I)=0 1143 6 ID(1,I)=0 1144 ID(1,4)=0 1145 ID(1,5)=0 1146 NQZP=-1 1147 NQZD=-1 1148 DO 9 I=1,IBASE 1149 IF(LOC(1,I).LT.1) GOTO 9 1150 ICHECK=LOC(1,I) 1151 ITEST=NTYPE(ICHECK) 1152 INQZ=(ITEST-MINUS)/10 1153 ILQZ=ITEST-10*(ITEST/10) 1154 IF(ILQZ.GT.8) GOTO 8 1155 IF(ILQZ.GT.3) GOTO 7 1156 IF(NQZP.LT.0) NQZP=INQZ 1157 IF(INQZ.NE.NQZP) GOTO 9 1158 P(ILQZ)=COEFF(ICHECK,JORB) 1159 IP(1,ILQZ)=LOC(1,I) 1160 IP(2,ILQZ)=LOC(2,I) 1161 GOTO 8 1162 7 IF(NQZD.LT.0) NQZD=INQZ 1163 IF(INQZ.NE.NQZD) GOTO 9 1164 ILQZ=ILQZ-3 1165 D(ILQZ)=COEFF(ICHECK,JORB) 1166 ID(1,ILQZ)=LOC(1,I) 1167 ID(2,ILQZ)=LOC(2,I) 1168 8 LOC(1,I)=0 1169 KI=KI-1 1170 9 CONTINUE 1171 IF(NQZP.LT.0) GOTO 11 1172 H(1)=R(1,1)*P(1)+R(2,1)*P(2)+R(3,1)*P(3) 1173 H(2)=R(1,2)*P(1)+R(2,2)*P(2)+R(3,2)*P(3) 1174 H(3)=R(1,3)*P(1)+R(2,3)*P(2)+R(3,3)*P(3) 1175 P(1)=E(1,1,IOPER)*H(1)+E(1,2,IOPER)*H(2)+E(1,3,IOPER)*H(3) 1176 P(2)=E(2,1,IOPER)*H(1)+E(2,2,IOPER)*H(2)+E(2,3,IOPER)*H(3) 1177 P(3)=E(3,1,IOPER)*H(1)+E(3,2,IOPER)*H(2)+E(3,3,IOPER)*H(3) 1178 DO 10 I=1,3 1179 IF(IP(1,I).LT.1) GOTO 16 1180 II=IP(1,I) 1181 JJ=IP(2,I) 1182 VECT(1,II)=H(I) 1183 10 VECT(2,JJ)=P(I) 1184 11 IF(NQZD.LT.0) GOTO 5 1185 CALL R00012(D,H,IOPER) 1186 DO 12 I=1,5 1187 IF(ID(1,I).LT.1) GOTO 16 1188 II=ID(1,I) 1189 JJ=ID(2,I) 1190 VECT(1,II)=H(I) 1191 12 VECT(2,JJ)=D(I) 1192 KI=KI-5 1193 GOTO 5 1194 13 CONTINUE 1195 C1=0.D0 1196 C2=0.D0 1197 DO 14 I=1,NORBS 1198 C1=C1+VECT(1,I)*VECT(1,I) 1199 14 C2=C2+VECT(1,I)*VECT(2,I) 1200 IF(ABS(C1).LT.1.E-5) GOTO 15 1201 R00011=C2/C1 1202 RETURN 1203 15 R00011=100.D0 1204 RETURN 1205 16 IERROR=98 1206 RETURN 1207 END 1208C 1209C======================================================================= 1210C 1211 SUBROUTINE R00012(D,H,IOPER) 1212 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1213 INCLUDE 'SIZES' 1214 PARAMETER (MXDIM=MAXPAR+NUMATM) 1215 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1216 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1217 COMMON /S00003/ IELEM(20),ELEM(3,3,20),CUB(3,3),JELEM(20,NUMATM) 1218 COMMON /S00004/ SHIFT(3),R(3,3),VECT(2,MXDIM) 1219 DIMENSION D(5),H(5),T1(5,5,12),S(3,3) 1220 CHARACTER JX*4 1221 WRITE(6,'('' == symtrz.f R00012 =='')') 1222 IF(NDORBS.GT.0) GOTO 4 1223 NDORBS=1 1224 DO 1 I=1,3 1225 DO 1 J=1,3 1226 1 S(I,J)=R(I,J) 1227 CALL R00013(S,T1,1) 1228 DO 3 K=2,J1 1229 DO 2 I=1,3 1230 DO 2 J=1,3 1231 2 S(I,J)=ELEM(I,J,K) 1232 CALL R00013(S,T1,K) 1233 3 CONTINUE 1234 4 DO 5 I=1,5 1235 H(I)=0.D0 1236 DO 5 J=1,5 1237 5 H(I)=H(I)+T1(I,J,1)*D(J) 1238 DO 6 I=1,5 1239 D(I)=0.D0 1240 DO 6 J=1,5 1241 6 D(I)=D(I)+T1(I,J,IOPER)*H(J) 1242 RETURN 1243 END 1244C 1245C================================================================= 1246C 1247 SUBROUTINE R00013(R,T,IOPER) 1248 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1249 DIMENSION R(3,3),T(5,5,12),F(2,4) 1250 LOGICAL RIGHT 1251 DATA PI,TOL,S12 / 3.1415926536D0 ,0.001D0,3.46410161513D0 / 1252 DATA S3,ONE / 1.73205080756D0 , 1.D0 / 1253 WRITE(6,'('' == symtrz.f R00013 =='')') 1254 R1=R(2,1)*R(3,2)-R(3,1)*R(2,2) 1255 R2=R(3,1)*R(1,2)-R(1,1)*R(3,2) 1256 R3=R(1,1)*R(2,2)-R(2,1)*R(1,2) 1257 CHECK=R1*R(1,3)+R2*R(2,3)+R3*R(3,3) 1258 RIGHT=CHECK.GT.0. 1259 R(1,3)=R1 1260 R(2,3)=R2 1261 R(3,3)=R3 1262 ARG=R3 1263 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1264 B= ACOS(ARG) 1265 SINA=SQRT(1.D0-ARG*ARG) 1266 IF(SINA.LT.TOL) GOTO 1 1267 ARG=R(3,2)/SINA 1268 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1269 G= ASIN(ARG) 1270 ARG=R(2,3)/SINA 1271 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1272 A= ASIN(ARG) 1273 GOTO 2 1274 1 ARG=R(1,2) 1275 IF(ABS(ARG).GT.ONE) ARG=SIGN(ONE,ARG) 1276 G= ASIN(ARG) 1277 A=0.D0 1278 2 F(1,1)=A 1279 F(1,2)=A 1280 F(1,3)=PI-A 1281 F(1,4)=PI-A 1282 F(2,1)=G 1283 F(2,3)=G 1284 F(2,2)=PI-G 1285 F(2,4)=PI-G 1286 DO 3 I=1,4 1287 A=F(1,I) 1288 G=F(2,I) 1289 CHECK=ABS(SIN(B)*COS(A)+R(1,3)) 1290 IF(CHECK.GT.TOL) GOTO 3 1291 CHECK=-SIN(G)*COS(B)*SIN(A)+COS(G)*COS(A) 1292 IF(ABS(CHECK-R(2,2)).GT.TOL) GOTO 3 1293 CHECK=SIN(A)*COS(G)+COS(A)*COS(B)*SIN(G) 1294 IF(ABS(CHECK-R(1,2)).LE.TOL) GOTO 4 1295 3 CONTINUE 1296 4 G=-G 1297 A=-A 1298 B=-B 1299 E1=COS(B*0.5D0) 1300 X1=-SIN(B*0.5D0) 1301 E2=E1*E1 1302 E3=E1*E2 1303 E4=E2*E2 1304 X2=X1*X1 1305 X3=X1*X2 1306 X4=X2*X2 1307 TA=2.D0*A 1308 TG=2.D0*G 1309 T(1,1,IOPER)=E4*COS(TA+TG)+X4*COS(TA-TG) 1310 T(1,2,IOPER)=2.D0*E3*X1*COS(A+TG)-2.D0*E1*X3*COS(A-TG) 1311 T(1,3,IOPER)=2.D0*S3*E2*X2*COS(TG) 1312 T(1,4,IOPER)=2.D0*E3*X1*SIN(A+TG)-2.D0*E1*X3*SIN(A-TG) 1313 T(1,5,IOPER)=E4*SIN(TA+TG)+X4*SIN(TA-TG) 1314 T(2,1,IOPER)=2.D0*E1*X3*COS(TA-G)-2.D0*E3*X1*COS(TA+G) 1315 T(2,2,IOPER)=(E4-3.D0*E2*X2)*COS(A+G)-(3.D0*E2*X2-X4)*COS(A-G) 1316 T(2,3,IOPER)=2.D0*S3*(E3*X1-E1*X3)*COS(G) 1317 T(2,4,IOPER)=(E4-3.D0*E2*X2)*SIN(A+G)-(3.D0*E2*X2-X4)*SIN(A-G) 1318 T(2,5,IOPER)=-2.D0*E3*X1*SIN(TA+G)+2.D0*E1*X3*SIN(TA-G) 1319 T(3,1,IOPER)=S12*E2*X2*COS(TA) 1320 T(3,2,IOPER)=-S12*(E3*X1-E1*X3)*COS(A) 1321 T(3,3,IOPER)=E4-4.D0*E2*X2+X4 1322 T(3,4,IOPER)=-S12*(E3*X1-E1*X3)*SIN(A) 1323 T(3,5,IOPER)=S12*E2*X2*SIN(TA) 1324 T(4,1,IOPER)=2.D0*E1*X3*SIN(TA-G)+2.D0*E3*X1*SIN(TA+G) 1325 T(4,2,IOPER)=-(E4-3.D0*E2*X2)*SIN(A+G)-(3.D0*E2*X2-X4)*SIN(A-G) 1326 T(4,3,IOPER)=-2.D0*S3*(E3*X1-E1*X3)*SIN(G) 1327 T(4,4,IOPER)=(E4-3.D0*E2*X2)*COS(A+G)+(3.D0*E2*X2-X4)*COS(A-G) 1328 T(4,5,IOPER)=-2.D0*E3*X1*COS(TA+G)-2.D0*E1*X3*COS(TA-G) 1329 T(5,1,IOPER)=-E4*SIN(TA+TG)+X4*SIN(TA-TG) 1330 T(5,2,IOPER)=-2.D0*E3*X1*SIN(A+TG)-2.D0*E1*X3*SIN(A-TG) 1331 T(5,3,IOPER)=-2.D0*S3*E2*X2*SIN(TG) 1332 T(5,4,IOPER)=2.D0*E3*X1*COS(A+TG)+2.D0*E1*X3*COS(A-TG) 1333 T(5,5,IOPER)=E4*COS(TA+TG)-X4*COS(TA-TG) 1334 IF(RIGHT) RETURN 1335 DO 5 I=1,5 1336 T(2,I,IOPER)=-T(2,I,IOPER) 1337 5 T(4,I,IOPER)=-T(4,I,IOPER) 1338 RETURN 1339 END 1340C 1341C====================================================================== 1342C 1343 SUBROUTINE R00015(F,V,EW) 1344 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1345 DIMENSION F(6),A(3,3),V(3,3),EW(3) 1346 DATA TOLER /1.E-6 / 1347 WRITE(6,'('' == symtrz.f R00015 =='')') 1348 N=3 1349 IJ=0 1350 DO 2 J=1,N 1351 DO 1 I=1,J 1352 IJ=IJ+1 1353 A(I,J)=F(IJ) 1354 A(J,I)=F(IJ) 1355 V(I,J)=0.D0 1356 1 V(J,I)=0.D0 1357 2 V(J,J)=1.D0 1358 N1=N-1 1359 ZETA=10.D0 1360 3 SS=0.D0 1361 DO 4 J=1,N1 1362 DO 4 I=J,N1 1363 IRG=I+1 1364 4 SS=SS+ABS(A(IRG,J)) 1365 IF(SS-TOLER) 21,21,5 1366 5 TAU=0.D0 1367 DO 20 I=1,N 1368 I1=I+1 1369 IF(N-I1) 20,6,6 1370 6 DO 19 J=I1,N 1371 IF(ABS(A(J,I)).LT.1.E-30) GOTO 19 1372 THETA=0.5D0*(A(J,J)-A(I,I))/A(J,I) 1373 IF(ABS(THETA)-ZETA) 7,7,19 1374 7 T=1.D0 1375 IF(THETA) 8,9,9 1376 8 T=-1.D0 1377 9 T=1.D0/(THETA+T*SQRT(1.D0+THETA*THETA)) 1378 C=1.D0/SQRT(1.D0+T*T) 1379 S=C*T 1380 H=2.D0*A(J,I) 1381 HC=S*H*(S*THETA-C) 1382 A(I,I)=A(I,I)+HC 1383 A(J,J)=A(J,J)-HC 1384 A(J,I)=-H*C*(S*THETA-0.5D0*(C-S*S/C)) 1385 TAU=TAU+1.D0 1386 IF(I.LT.2) GOTO 11 1387 DO 10 IG=2,I 1388 IRS=IG-1 1389 H=C*A(I,IRS)-S*A(J,IRS) 1390 A(J,IRS)=S*A(I,IRS)+C*A(J,IRS) 1391 10 A(I,IRS)=H 1392 11 L=J-1 1393 IF(L-I1) 14,12,12 1394 12 DO 13 IG=I1,L 1395 H=C*A(IG,I)-S*A(J,IG) 1396 A(J,IG)=S*A(IG,I)+C*A(J,IG) 1397 13 A(IG,I)=H 1398 14 IF(N1-J) 17,15,15 1399 15 DO 16 IG=J,N1 1400 ILG=IG+1 1401 H=C*A(ILG,I)-S*A(ILG,J) 1402 A(ILG,J)=S*A(ILG,I)+C*A(ILG,J) 1403 16 A(ILG,I)=H 1404 17 DO 18 IG=1,N 1405 H=C*V(IG,I)-S*V(IG,J) 1406 V(IG,J)=S*V(IG,I)+C*V(IG,J) 1407 18 V(IG,I)=H 1408 19 CONTINUE 1409 20 CONTINUE 1410 H=0.5D0*FLOAT(N*(N-1)) 1411 ZETA=ZETA**(2.5D0-TAU/H) 1412 GOTO 3 1413 21 DO 22 J=1,N 1414 22 EW(J)=A(J,J) 1415 N1=N-1 1416 23 NT=0 1417 DO 26 J=1,N1 1418 JRG=J+1 1419 IF(EW(J)-EW(JRG)) 26,26,24 1420 24 BUFFER=EW(J) 1421 EW(J)=EW(JRG) 1422 EW(JRG)=BUFFER 1423 DO 25 I=1,N 1424 BUFFER=V(I,JRG) 1425 V(I,JRG)=V(I,J) 1426 25 V(I,J)=BUFFER 1427 NT=1 1428 26 CONTINUE 1429 N1=N1-1 1430 IF(NT) 23,27,23 1431 27 RETURN 1432 END 1433C 1434C=================================================================== 1435C 1436 SUBROUTINE R00016 1437 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1438 INCLUDE 'SIZES' 1439 PARAMETER (MXDIM=MAXPAR+NUMATM) 1440 CHARACTER*4 NAME,NAMO,ISTA 1441 COMMON /S00001/ T(12,12),JX(7,12),LINA,I1,J1,J2 1442 COMMON /S00002/ NUMAT,NORBS,NADIM,NCDIM,IQUAL,NDORBS,IERROR 1443 COMMON /SYMINF/ IBASE(2,12),NBASE,IVIBRO(2,12),IVIB 1444 COMMON/SYMRES/TRANS,RTR,SIG,NAME,NAMO(MXDIM),INDEX(MXDIM),ISTA(2) 1445 DIMENSION CHAR(12),COEFF(12) 1446 WRITE(6,'('' == symtrz.f R00016 =='')') 1447 IVIBRA=3*NUMAT-6 1448 IF(LINA.GT.0) GOTO 8 1449 CHAR(1)=IVIBRA 1450 IVIB=0 1451 IF(J1.LT.2) RETURN 1452 DO 5 I=2,J1 1453 JUMP=JX(4,I) 1454 GOTO (1,2,3,4),JUMP 1455 1 CHAR(I)=-3*JX(6,I) 1456 GOTO 5 1457 2 CHAR(I)=JX(6,I) 1458 GOTO 5 1459 3 JP=JX(5,I)/10 1460 JK=JX(5,I)-10*JP 1461 ANGLE=2.D0*COS(6.283185308D0*DBLE(JK)/DBLE(JP)) 1462 CHAR(I)=DBLE(JX(6,I))*(ANGLE-1.D0) 1463 GOTO 5 1464 4 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)-2)*(ANGLE+1.D0) 1468 5 CHAR(I)=CHAR(I)*DBLE(JX(2,I)) 1469 ORDER=DBLE(J2) 1470 DO 7 I=1,I1 1471 COEFF(I)=0.1D0 1472 DO 6 J=1,J1 1473 6 COEFF(I)=COEFF(I)+CHAR(J)*T(I,J)/ORDER 1474 IF(COEFF(I).LT.1.) GOTO 7 1475 IDEGEN= T(I,1)+0.1D0 1476 IVIB=IVIB+1 1477 IVIBRO(1,IVIB)= COEFF(I) 1478 IF(I1.NE.J1) IVIBRO(1,IVIB)= COEFF(I) /IDEGEN 1479 IVIBRO(2,IVIB)=JX(1,I) 1480 7 CONTINUE 1481 RETURN 1482 8 IVIBRA=IVIBRA+1 1483 GOTO(9,10),LINA 1484 9 IVIBRO(1,1)=NUMAT-1 1485 IVIBRO(2,1)=JX(1,1) 1486 IVIBRO(1,2)=NUMAT-2 1487 IVIBRO(2,2)=JX(1,2) 1488 IVIB=2 1489 IF(NUMAT.LT.3) IVIB=1 1490 RETURN 1491 10 ICENT=JX(6,3) 1492 IVIBRO(1,1)=(NUMAT-ICENT)/2 1493 IVIBRO(2,1)=JX(1,1) 1494 IVIB=2 1495 IVIBRO(1,2)=(NUMAT-2-ICENT)/2 1496 IVIBRO(2,2)=JX(1,2) 1497 IF(IVIBRO(1,2).GT.0) IVIB=3 1498 IVIBRO(1,IVIB)=(NUMAT-2+ICENT)/2 1499 IVIBRO(2,IVIB)=JX(1,4) 1500 IF(IVIBRO(1,IVIB).GT.0) IVIB=IVIB+1 1501 IVIBRO(1,IVIB)=(NUMAT-2+ICENT)/2 1502 IVIBRO(2,IVIB)=JX(1,5) 1503 IF(IVIBRO(1,IVIB).LT.1) IVIB=IVIB-1 1504 RETURN 1505 END 1506