1 SUBROUTINE FRMDSCO(ARRAY,NDIM,MBLOCK,IFILE,IMZERO) 2C 3C TRANSFER ARRAY FROM DISC FILE IFILE 4C 5 IMPLICIT REAL*8(A-H,O-Z) 6 INCLUDE 'rou_stat.inc' 7 DIMENSION ARRAY(*) 8C 9 IPACK = 1 10 IF(IPACK.NE.0) THEN 11*. Read if ARRAY is zero 12 CALL IFRMDS(IMZERO,1,MBLOCK,IFILE) 13 IF(IMZERO.EQ.1) THEN 14 ZERO = 0.0D0 15 CALL SETVEC(ARRAY,ZERO,NDIM) 16 GOTO 1001 17 END IF 18 END IF 19* 20 ICRAY = 1 21 IF( MBLOCK .GE. 0 .OR.ICRAY.EQ.1) THEN 22 NBLOCK = MBLOCK 23 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 24 IREST=NDIM 25 IBASE=0 26 100 CONTINUE 27 IF(IREST.GT.NBLOCK) THEN 28 READ(IFILE) (ARRAY(IBASE+I),I=1,NBLOCK) 29 IBASE=IBASE+NBLOCK 30 IREST=IREST-NBLOCK 31 XOP_FRMDSCO = XOP_FRMDSCO + NBLOCK 32 ELSE 33 READ(IFILE) (ARRAY(IBASE+I),I=1,IREST) 34 XOP_FRMDSCO = XOP_FRMDSCO + IREST 35 IREST=0 36 END IF 37 IF( IREST .GT. 0 ) GOTO 100 38 END IF 39 1001 CONTINUE 40* 41 RETURN 42 END 43 SUBROUTINE SKPRCD2(NDIM,MBLOCK,IFILE) 44C 45C Skip record in file IFILE 46C 47*. Version allowing zero and packed blocks 48* 49* Dos not work with FASTIO - I expect 50* 51 IMPLICIT REAL*8(A-H,O-Z) 52* 53 DIMENSION ISCR(2) 54 PARAMETER(LPBLK=50000) 55 56C 57 IPACK = 1 58 IF(IPACK.NE.0) THEN 59*. Read if ARRAY is zero 60 CALL IFRMDS(ISCR,2,2,IFILE) 61 IMZERO=ISCR(1) 62 I_AM_PACKED=ISCR(2) 63 IF(IMZERO.EQ.1) THEN 64 GOTO 1001 65 END IF 66 END IF 67* 68 ICRAY = 1 69 IF(I_AM_PACKED.EQ.1) THEN 70*. Loop over packed records of dimension LPBLK 71*. The next LPBLK elements 72 999 CONTINUE 73*. Read next batch 74 READ(IFILE) LBATCH 75 IF(LBATCH.GT.0) THEN 76 READ(IFILE) 77 READ(IFILE) 78 END IF 79 READ(IFILE) ISTOP 80 IF(ISTOP.EQ.0) GOTO 999 81 ELSE IF ( I_AM_PACKED.EQ.0) THEN 82 IF( MBLOCK .GE. 0 .OR.ICRAY.EQ.1) THEN 83 NBLOCK = MBLOCK 84 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 85 IREST=NDIM 86 IBASE=0 87 100 CONTINUE 88 IF(IREST.GT.NBLOCK) THEN 89 READ(IFILE) 90 IBASE=IBASE+NBLOCK 91 IREST=IREST-NBLOCK 92 ELSE 93 READ(IFILE) 94 IREST=0 95 END IF 96 IF( IREST .GT. 0 ) GOTO 100 97 END IF 98C 99C IF( MBLOCK.LT.0.AND.NDIM.GT.0.AND.ICRAY.EQ.0 ) THEN 100C CALL SQFILE(IFILE,2,ARRAY,2*NDIM) 101C END IF 102 END IF 103* 104 1001 CONTINUE 105* 106 RETURN 107 END 108 SUBROUTINE FRMDSC2(ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED, 109 & NO_ZEROING) 110C 111C TRANSFER ARRAY FROM DISC FILE IFILE 112C 113*. Version allowing zero and packed blocks 114* 115* If NO_ZEROING = 1, the elements of zero blocks 116* are not set to zero, the routine just returns with 117* IMZERO = 1 118* 119 IMPLICIT REAL*8(A-H,O-Z) 120 INCLUDE 'rou_stat.inc' 121 DIMENSION ARRAY(*) 122* 123 DIMENSION ISCR(2) 124 PARAMETER(LPBLK=50000) 125 INTEGER IPAK(LPBLK) 126 DIMENSION XPAK(LPBLK) 127* 128 NTEST = 0 129 IF(NTEST.GE.1000) THEN 130 WRITE(6,*) ' Info from FRMDSC2' 131 WRITE(6,*) ' IFILE, NDIM, MBLOCK = ', IFILE,NDIM,MBLOCK 132 END IF 133 134 IMZERO = 0 135C 136 IPACK = 1 137 IF(IPACK.NE.0) THEN 138*. Read if ARRAY is zero 139 MMBLOCK = MBLOCK 140 CALL IFRMDS(ISCR,2,2,IFILE) 141 IMZERO=ISCR(1) 142 I_AM_PACKED=ISCR(2) 143 IF(IMZERO.EQ.1) THEN 144 IF(NO_ZEROING.EQ.0) THEN 145 ZERO = 0.0D0 146 CALL SETVEC(ARRAY,ZERO,NDIM) 147 END IF 148 GOTO 1001 149 END IF 150 END IF 151* 152 ICRAY = 1 153 IF(I_AM_PACKED.EQ.1) THEN 154 ZERO = 0.0D0 155 CALL SETVEC(ARRAY,ZERO,NDIM) 156*. Loop over packed records of dimension LPBLK 157 NBATCH = 0 158C1000 CONTINUE 159*. The next LPBLK elements 160 999 CONTINUE 161 NBATCH = NBATCH + 1 162 IF(NBATCH.NE.1) THEN 163 LBATCHP = LBATCH 164 END IF 165*. Read next batch 166 READ(IFILE) LBATCH 167 IF(LBATCH.GT.0) THEN 168 READ(IFILE) (IPAK(I),I=1, LBATCH) 169 READ(IFILE) (XPAK(I),I=1, LBATCH) 170 XOP_FRMDSC2 = XOP_FRMDSC2 + LBATCH 171 END IF 172 READ(IFILE) ISTOP 173 DO IELMNT = 1, LBATCH 174 IF(IPAK(IELMNT).LE.0.OR.IPAK(IELMNT).GT.NDIM) THEN 175 WRITE(6,*) ' FRMDSC : Problemo IELMNT = ',IELMNT 176 WRITE(6,*) ' IPAK(IELMNT) = ',IPAK(IELMNT ) 177 WRITE(6,*) ' LBATCH IFILE = ',LBATCH,IFILE 178 IF(NBATCH.EQ.1) THEN 179 WRITE(6,*) ' NBATCH = 1 ' 180 ELSE 181 WRITE(6,*) ' NBATCH, LBATCHP', NBATCH,LBATCHP 182 END IF 183 WRITE(6,*) ' NDIM,IMZERO = ', NDIM,IMZERO 184 STOP ' problem in FRMDSC ' 185 END IF 186 ARRAY(IPAK(IELMNT)) = XPAK(IELMNT) 187 END DO 188 IF(ISTOP.EQ.0) GOTO 999 189*. End of loop over records of truncated elements 190 ELSE IF ( I_AM_PACKED.EQ.0) THEN 191 IF( MBLOCK .GE. 0 .OR.ICRAY.EQ.1) THEN 192 NBLOCK = MBLOCK 193 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 194 IREST=NDIM 195 IBASE=0 196 100 CONTINUE 197 IF(IREST.GT.NBLOCK) THEN 198 READ(IFILE) (ARRAY(IBASE+I),I=1,NBLOCK) 199 IBASE=IBASE+NBLOCK 200 IREST=IREST-NBLOCK 201 XOP_FRMDSC2 = XOP_FRMDSC2 + NBLOCK 202 ELSE 203 READ(IFILE) (ARRAY(IBASE+I),I=1,IREST) 204 XOP_FRMDSC2 = XOP_FRMDSC2 + IREST 205 IREST=0 206 END IF 207 IF( IREST .GT. 0 ) GOTO 100 208 END IF 209C 210 IF( MBLOCK.LT.0.AND.NDIM.GT.0.AND.ICRAY.EQ.0 ) THEN 211 CALL SQFILE(IFILE,2,ARRAY,2*NDIM) 212 END IF 213 END IF 214* 215 1001 CONTINUE 216* 217 RETURN 218 END 219 SUBROUTINE FRMDSC(ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED) 220C 221C TRANSFER ARRAY FROM DISC FILE IFILE 222C 223*. Version allowing zero and packed blocks 224* 225 IMPLICIT REAL*8(A-H,O-Z) 226 INCLUDE 'rou_stat.inc' 227 DIMENSION ARRAY(*) 228* 229 PARAMETER (NTEST=00) 230* 231 DIMENSION ISCR(2) 232 PARAMETER(LPBLK=50000) 233 INTEGER IPAK(LPBLK) 234 DIMENSION XPAK(LPBLK) 235 236C 237 IPACK = 1 238 IF(IPACK.NE.0) THEN 239*. Read if ARRAY is zero 240 MMBLOCK = MBLOCK 241 CALL IFRMDS(ISCR,2,2,IFILE) 242 IMZERO=ISCR(1) 243 I_AM_PACKED=ISCR(2) 244 IF(IMZERO.EQ.1) THEN 245 ZERO = 0.0D0 246C? write(6,*) ' frmdsc, length of zero block',NDIM 247 CALL SETVEC(ARRAY,ZERO,NDIM) 248 GOTO 1001 249 END IF 250 END IF 251* 252 ICRAY = 1 253 IF(I_AM_PACKED.EQ.1) THEN 254 ZERO = 0.0D0 255 CALL SETVEC(ARRAY,ZERO,NDIM) 256*. Loop over packed records of dimension LPBLK 257 NBATCH = 0 258C1000 CONTINUE 259*. The next LPBLK elements 260 999 CONTINUE 261 NBATCH = NBATCH + 1 262 IF(NBATCH.NE.1) THEN 263 LBATCHP = LBATCH 264 END IF 265*. Read next batch 266 READ(IFILE) LBATCH 267 IF(LBATCH.GT.0) THEN 268 READ(IFILE) (IPAK(I),I=1, LBATCH) 269 READ(IFILE) (XPAK(I),I=1, LBATCH) 270 XOP_FRMDSC = XOP_FRMDSC + LBATCH 271 END IF 272 READ(IFILE) ISTOP 273 DO IELMNT = 1, LBATCH 274 IF(IPAK(IELMNT).LE.0.OR.IPAK(IELMNT).GT.NDIM) THEN 275 WRITE(6,*) ' FRMDSC : Problemo IELMNT = ',IELMNT 276 WRITE(6,*) ' IPAK(IELMNT) = ',IPAK(IELMNT ) 277 WRITE(6,*) ' LBATCH IFILE = ',LBATCH,IFILE 278 IF(NBATCH.EQ.1) THEN 279 WRITE(6,*) ' NBATCH = 1 ' 280 ELSE 281 WRITE(6,*) ' NBATCH, LBATCHP', NBATCH,LBATCHP 282 END IF 283 WRITE(6,*) ' NDIM,IMZERO = ', NDIM,IMZERO 284 STOP ' problem in FRMDSC ' 285 END IF 286 ARRAY(IPAK(IELMNT)) = XPAK(IELMNT) 287 END DO 288 IF(ISTOP.EQ.0) GOTO 999 289*. End of loop over records of truncated elements 290 ELSE IF ( I_AM_PACKED.EQ.0) THEN 291 IF( MBLOCK .GE. 0 .OR.ICRAY.EQ.1) THEN 292 NBLOCK = MBLOCK 293 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 294 IREST=NDIM 295 IBASE=0 296 100 CONTINUE 297 IF(IREST.GT.NBLOCK) THEN 298 READ(IFILE) (ARRAY(IBASE+I),I=1,NBLOCK) 299 IBASE=IBASE+NBLOCK 300 IREST=IREST-NBLOCK 301 XOP_FRMDSC = XOP_FRMDSC + NBLOCK 302 ELSE 303 READ(IFILE) (ARRAY(IBASE+I),I=1,IREST) 304 XOP_FRMDSC = XOP_FRMDSC + IREST 305 IREST=0 306 END IF 307 IF( IREST .GT. 0 ) GOTO 100 308 END IF 309C 310 IF( MBLOCK.LT.0.AND.NDIM.GT.0.AND.ICRAY.EQ.0 ) THEN 311 CALL SQFILE(IFILE,2,ARRAY,2*NDIM) 312 END IF 313 END IF 314* 315 1001 CONTINUE 316* 317 RETURN 318 END 319 SUBROUTINE FRMDSCE 320 & (ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED,IERR) 321C 322C TRANSFER ARRAY FROM DISC FILE IFILE 323C 324C version with error code 325C 326*. Version allowing zero and packed blocks 327* 328 IMPLICIT REAL*8(A-H,O-Z) 329 INCLUDE 'rou_stat.inc' 330 DIMENSION ARRAY(*) 331* 332 PARAMETER (NTEST=00) 333* 334 DIMENSION ISCR(2) 335 PARAMETER(LPBLK=50000) 336 INTEGER IPAK(LPBLK) 337 DIMENSION XPAK(LPBLK) 338 339C 340 IERR = 0 341 IPACK = 1 342 IF(IPACK.NE.0) THEN 343*. Read if ARRAY is zero 344 MMBLOCK = MBLOCK 345 CALL IFRMDSE(ISCR,2,2,IFILE,IERR) 346 IF (IERR.NE.0) RETURN 347 IMZERO=ISCR(1) 348 I_AM_PACKED=ISCR(2) 349 IF(IMZERO.EQ.1) THEN 350 ZERO = 0.0D0 351 CALL SETVEC(ARRAY,ZERO,NDIM) 352 GOTO 1001 353 END IF 354 END IF 355* 356 ICRAY = 1 357 IF(I_AM_PACKED.EQ.1) THEN 358 ZERO = 0.0D0 359 CALL SETVEC(ARRAY,ZERO,NDIM) 360*. Loop over packed records of dimension LPBLK 361 NBATCH = 0 362C1000 CONTINUE 363*. The next LPBLK elements 364 999 CONTINUE 365 NBATCH = NBATCH + 1 366 IF(NBATCH.NE.1) THEN 367 LBATCHP = LBATCH 368 END IF 369*. Read next batch 370 READ(IFILE,END=201,ERR=202) LBATCH 371 IF(LBATCH.GT.0) THEN 372 READ(IFILE) (IPAK(I),I=1, LBATCH) 373 READ(IFILE) (XPAK(I),I=1, LBATCH) 374 XOP_FRMDSCE = XOP_FRMDSCE + LBATCH 375 END IF 376 READ(IFILE,END=201,ERR=202) ISTOP 377 DO IELMNT = 1, LBATCH 378 IF(IPAK(IELMNT).LE.0.OR.IPAK(IELMNT).GT.NDIM) THEN 379 WRITE(6,*) ' FRMDSC : Problemo IELMNT = ',IELMNT 380 WRITE(6,*) ' IPAK(IELMNT) = ',IPAK(IELMNT ) 381 WRITE(6,*) ' LBATCH IFILE = ',LBATCH,IFILE 382 IF(NBATCH.EQ.1) THEN 383 WRITE(6,*) ' NBATCH = 1 ' 384 ELSE 385 WRITE(6,*) ' NBATCH, LBATCHP', NBATCH,LBATCHP 386 END IF 387 WRITE(6,*) ' NDIM,IMZERO = ', NDIM,IMZERO 388 STOP ' problem in FRMDSC ' 389 END IF 390 ARRAY(IPAK(IELMNT)) = XPAK(IELMNT) 391 END DO 392 IF(ISTOP.EQ.0) GOTO 999 393*. End of loop over records of truncated elements 394 ELSE IF ( I_AM_PACKED.EQ.0) THEN 395 IF( MBLOCK .GE. 0 .OR.ICRAY.EQ.1) THEN 396 NBLOCK = MBLOCK 397 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 398 IREST=NDIM 399 IBASE=0 400 100 CONTINUE 401 IF(IREST.GT.NBLOCK) THEN 402 READ(IFILE,END=201,ERR=202) (ARRAY(IBASE+I),I=1,NBLOCK) 403 IBASE=IBASE+NBLOCK 404 IREST=IREST-NBLOCK 405 XOP_FRMDSCE = XOP_FRMDSCE + NBLOCK 406 ELSE 407 READ(IFILE,END=201,ERR=202) (ARRAY(IBASE+I),I=1,IREST) 408 XOP_FRMDSCE = XOP_FRMDSCE + IREST 409 IREST=0 410 END IF 411 IF( IREST .GT. 0 ) GOTO 100 412 END IF 413 END IF 414* 415 1001 CONTINUE 416* 417 RETURN 418 201 IERR = 1 ! end of file 419 RETURN 420 202 IERR = 2 421 RETURN 422 END 423 SUBROUTINE TODSC(A,NDIM,MBLOCK,IFIL) 424C TRANSFER ARRAY DOUBLE PRECISION A(LENGTH NDIM) TO DISCFIL IFIL IN 425C RECORDS WITH LENGTH NBLOCK. 426 IMPLICIT REAL*8 (A-H,O-Z) 427 INCLUDE 'rou_stat.inc' 428 DIMENSION A(1) 429 INTEGER START,STOP 430 REAL*8 INPROD 431 INTEGER ISCR(2) 432* 433 IPACK = 1 434 IF(IPACK.NE.0) THEN 435*. Check norm of A before writing 436 XNORM = INPROD(A,A,NDIM) 437 IF(XNORM.EQ.0.0D0) THEN 438 IMZERO = 1 439 ELSE 440 IMZERO = 0 441 END IF 442 MMBLOCK = MBLOCK 443 IF(MMBLOCK.GT.2) MMBLOCK = 2 444* 445 ISCR(1) = IMZERO 446*. No packing 447 ISCR(2) = 0 448 CALL ITODS(ISCR,2,2,IFIL) 449 IF(IMZERO.EQ.1) GOTO 1001 450 END IF 451* 452 ICRAY = 1 453 IF( MBLOCK .GE.0 .OR.ICRAY .EQ. 1 ) THEN 454C 455 NBLOCK = MBLOCK 456 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 457 STOP=0 458 NBACK=NDIM 459C LOOP OVER RECORDS 460 100 CONTINUE 461 IF(NBACK.LE.NBLOCK) THEN 462 NTRANS=NBACK 463 NLABEL=-NTRANS 464 ELSE 465 NTRANS=NBLOCK 466 NLABEL=NTRANS 467 END IF 468 START=STOP+1 469 STOP=START+NBLOCK-1 470 NBACK=NBACK-NTRANS 471 WRITE(IFIL) (A(I),I=START,STOP),NLABEL 472 XOP_TODSC = XOP_TODSC + NTRANS 473 IF(NBACK.NE.0) GOTO 100 474 END IF 475C 476 IF( ICRAY.EQ.0.AND.MBLOCK.LT.0.AND.NDIM.GT.0) THEN 477 CALL SQFILE(IFIL,1,A,2*NDIM) 478 END IF 479* 480 1001 CONTINUE 481C 482C? write(6,*) ' leaving TODSC ' 483 RETURN 484 END 485 SUBROUTINE TODSCP(A,NDIM,MBLOCK,IFIL) 486* 487C TRANSFER ARRAY DOUBLE PRECISION A(LENGTH NDIM) TO DISCFIL IFIL IN 488C RECORDS WITH LENGTH NBLOCK. 489* 490* Packed version : Store only nonzero elements 491*. Small elements should be zeroed outside 492 IMPLICIT REAL*8 (A-H,O-Z) 493 INCLUDE 'rou_stat.inc' 494 DIMENSION A(1) 495 INTEGER START,STOP 496 REAL*8 INPROD 497 INTEGER ISCR(2) 498* 499 PARAMETER(LPBLK=50000) 500 INTEGER IPAK(LPBLK) 501 DIMENSION XPAK(LPBLK) 502* 503* 504C? write(6,*) ' entering TODSCP, file = ', IFIL 505C? CALL FLUSH(6) 506 IPACK = 1 507 IF(IPACK.NE.0) THEN 508*. Check norm of A before writing 509 XNORM = INPROD(A,A,NDIM) 510 IF(XNORM.EQ.0.0D0) THEN 511 IMZERO = 1 512 ELSE 513 IMZERO = 0 514 END IF 515 MMBLOCK = MBLOCK 516 IF(MMBLOCK.GT.2) MMBLOCK = 2 517* 518 ISCR(1) = IMZERO 519*. Packing 520 ISCR(2) = 1 521C CALL ITODS(ISCR,2,MMBLOCK,IFIL) 522 CALL ITODS(ISCR,2,2,IFIL) 523 IF(IMZERO.EQ.1) GOTO 1001 524 END IF 525* 526 ICRAY = 1 527 IF( MBLOCK .GE.0 .OR.ICRAY .EQ. 1 ) THEN 528C 529 NBLOCK = MBLOCK 530 IF ( MBLOCK .LE. 0 ) NBLOCK = NDIM 531*. Loop over packed records of dimension LPBLK 532 IELMNT = 0 533 1000 CONTINUE 534*. The next LPBLK elements 535 LBATCH = 0 536*. Obtain next batch of elemnts 537 999 CONTINUE 538 IF(NDIM.GE.1) THEN 539 IELMNT = IELMNT+1 540 IF(A(IELMNT).NE.0.0D0) THEN 541 LBATCH=LBATCH+1 542 IPAK(LBATCH) = IELMNT 543 XPAK(LBATCH) = A(IELMNT) 544 END IF 545 END IF 546 IF(LBATCH.EQ.LPBLK.OR.IELMNT.EQ.NDIM) goto 998 547 GOTO 999 548*. Send to DISC 549 998 CONTINUE 550 WRITE(IFIL) LBATCH 551 IF(LBATCH.GT.0) THEN 552 WRITE(IFIL) (IPAK(I),I=1, LBATCH) 553 WRITE(IFIL) (XPAK(I),I=1, LBATCH) 554 XOP_TODSCP = XOP_TODSCP + LBATCH 555 END IF 556 IF(IELMNT.EQ.NDIM) THEN 557 WRITE(IFIL) -1 558 ELSE 559 WRITE(IFIL) 0 560 GOTO 1000 561 END IF 562*. End of loop over records of truncated elements 563 END IF 564 1001 CONTINUE 565* 566C? CALL FLUSH(6) 567 RETURN 568 END 569 SUBROUTINE ADDDIA(A,FACTOR,NDIM,IPACK) 570* 571* add factor to diagonal of square matrix A 572* 573* IPACK = 0 : full matrix 574* IPACK .NE. 0 : Lower triangular packed matrix 575* 576 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 577* 578 DIMENSION A(*) 579* 580 DO 100 I = 1,NDIM 581 IF(IPACK .EQ. 0 ) THEN 582 II = (I-1)*NDIM + I 583 ELSE 584 II = I*(I+1)/2 585 END IF 586 A(II) = A(II) + FACTOR 587 100 CONTINUE 588* 589 RETURN 590 END 591 SUBROUTINE BNDINV(A,EL,N,DETERM,EPSIL,ITEST,NSIZE) 592C 593C DOUBLE PRECISION MATRIX INVERSION SUBROUTINE 594C FROM "DLYTAP". 595C 596C* DOUBLE PRECISION E,F 597C* DOUBLE PRECISION A,EL,D,DSQRT,C,S,DETERP 598 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 599 DIMENSION A(NSIZE,1),EL(NSIZE,1) 600 IF(N.LT.2)GO TO 140 601 ISL2=0 602 K000FX=2 603 IF(ISL2.EQ.0)INDSNL=2 604 IF(ISL2.EQ.1)INDSNL=1 605C CALL SLITET(2,INDSNL) 606C CALL OVERFL(K000FX) 607C CALL DVCHK(K000FX) 608C 609C SET EL = IDENTITY MATRIX 610 DO 30 I=1,N 611 DO 10 J=1,N 612 10 EL(I,J)=0.0D0 613 30 EL(I,I)=1.0D0 614C 615C TRIANGULARIZE A, FORM EL 616C 617 N1=N-1 618 M=2 619 DO 50 J=1,N1 620 DO 45 I=M,N 621 IF(A(I,J).EQ.0.0D0)GO TO 45 622 D=DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J)) 623 C=A(J,J)/D 624 S=A(I,J)/D 625 38 DO 39 K=J,N 626 D=C*A(J,K)+S*A(I,K) 627 A(I,K)=C*A(I,K)-S*A(J,K) 628 A(J,K)=D 629 39 CONTINUE 630 DO 40 K=1,N 631 D=C*EL(J,K)+S*EL(I,K) 632 EL(I,K)=C*EL(I,K)-S*EL(J,K) 633 EL(J,K)=D 634 40 CONTINUE 635 45 CONTINUE 636 50 M=M+1 637C CALL OVERFL(K000FX) 638C GO TO (140,51),K000FX 639C 640C CALCULATE THE DETERMINANT 641 51 DETERP=A(1,1) 642 DO 52 I=2,N 643 52 DETERP=DETERP*A(I,I) 644 DETERM=DETERP 645C CALL OVERFL(K000FX) 646C GO TO (140,520,520),K000FX 647C 648C IS MATRIX SINGULAR 649 520 F=A(1,1) 650 E=A(1,1) 651 DO 58 I=2,N 652 IF(DABS(F).LT.DABS(A(I,I)))F=A(I,I) 653 IF(DABS(E).GT.DABS(A(I,I)))E=A(I,I) 654 58 CONTINUE 655 EPSILP=EPSIL 656 IF(EPSILP.LE.0)EPSILP=1.0E-8 657 RAT=E/F 658 IF(ABS(RAT).LT.EPSILP)GO TO 130 659C 660C INVERT TRIANGULAR MATRIX 661 J=N 662 DO 100 J1=1,N 663C CALL SLITE(2) 664 I=J 665 ISL2=1 666 DO 90 I1=1,J 667C CALL SLITET(2,K000FX) 668 IF(ISL2.EQ.0)K000FX=2 669 IF(ISL2.EQ.1)K000FX=1 670 IF(ISL2.EQ.1)ISL2=0 671 GO TO (70,75),K000FX 672 70 A(I,J)=1.0D0/A(I,I) 673 GO TO 90 674 75 KS=I+1 675 D=0.0D0 676 DO 80 K=KS,J 677 80 D=D+A(I,K)*A(K,J) 678 A(I,J)=-D/A(I,I) 679 90 I=I-1 680 100 J=J-1 681C CALL OVERFL(K000FX) 682C GO TO (140,103,103),K000FX 683 684C103 CALL DVCHK(K000FX) 685C GO TO (140,105),K000FX 686C 687C PREMULTIPLY EL BY INVERTED TRIANGULAR MATRIX 688 105 M=1 689 DO 120 I=1,N 690 DO 118 J=1,N 691 D=0.0D0 692 DO 107 K=M,N 693 107 D=D+A(I,K)*EL(K,J) 694 EL(I,J)=D 695 118 CONTINUE 696 120 M=M+1 697C CALL OVERFL(K000FX) 698C GO TO (140,123,123),K000FX 699C 700C RECOPY EL TO A 701 123 DO 124 I=1,N 702 DO 124 J=1,N 703 124 A(I,J)=EL(I,J) 704 ITEST=0 705C126 IF(INDSNL.EQ.1)CALL SLITE(2) 706 126 IF(INDSNL.EQ.1)ISL2=1 707 RETURN 708C 709 130 ITEST=1 710 GO TO 126 711 140 ITEST=-1 712 GO TO 126 713 END 714 INTEGER FUNCTION CANIND(I,J) 715C 716 IF(I.GT.J) THEN 717 CANIND=I*(I-1)/2 + J 718 ELSE 719 CANIND=J*(J-1)/2 + I 720 END IF 721 RETURN 722 END 723 SUBROUTINE CHLFC1(AL,NDIM) 724C 725C FACTORIZE A SYMMETRIX MATRIX IN AL TO GIVE 726C CHOLESKY FACTOR , ALSO IN AL . 727C 728C INPUT MATRIX AND FACTORIZED MATRIX ARE ASSUMED GIVEN IN 729C LOWER TRIANGULAR FORM WITH INDEXING (I,J) = I*(I-1)-2 + J 730C 731 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 732 DIMENSION AL(*) 733 REAL * 8 INPROD 734C 735 DO 100 J = 1, NDIM 736 JJ = J*(J-1)/2 737 AL(JJ+J) = SQRT( AL(JJ+J) - INPROD(AL(JJ+1),AL(JJ+1),J-1) ) 738 ALJJI = 1.0D0/AL(JJ+J) 739 DO 80 I = J+1, NDIM 740 II = I*(I-1)/2 741 AL(II+J) = (AL(II+J) - 742 & INPROD( AL(II+1), AL(JJ+1), J-1 ) ) * ALJJI 743 80 CONTINUE 744 100 CONTINUE 745C 746 NTEST = 00 747 IF( NTEST .GE. 10 ) THEN 748 WRITE(6,*) ' CHOLESKY FACTORIZATION ' 749 CALL PRSYM(AL,NDIM) 750 END IF 751C 752 RETURN 753 END 754 SUBROUTINE CHLFCB(AL,NDIM,IB,INDEF) 755C 756C FACTORIZE A SYMMETRIC POSITIVE DEFINITE BAND MATRIX,AL,TO GIVE 757C CHOLESKY FACTOR , ALSO IN AL . 758C 759C BANDWIDTH IS IB SO 2*IB + 1 ELEMENTS IN EACH ROW ARE NONVANISHING 760C ( IN COMPLETE MATRIX ) 761C 762C 763C THE MATRIX IS PACKED IN THE FOLLOWING FORM 764C FIRST INDEX J : NONVANISHING COLUMN ELEMENTS FOR ROW NUMBER 765C CORRESPONDING TO SECOND INDEX 766C FIRST ELEMENT IS FIRST NONVANISHING ELEMENT 767C SECOND INDEX I : ROW NUMBER 768C 769 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 770 DIMENSION AL(IB+1,NDIM) 771 REAL * 8 INPROD 772C 773 NTEST = 00 774 INDEF = 0 775 LROW = IB + 1 776 DO 100 J = 1, NDIM 777 KTERMJ = MIN(IB,J-1) 778C WRITE(6,*) ' KTERMJ ',KTERMJ 779 JEFF = MIN(LROW,J) 780C AL(JEFF,J) = 781C & SQRT(AL(JEFF,J)-INPROD(AL(1,J),AL(1,J),KTERMJ) ) 782 XXX = 783 & AL(JEFF,J)-INPROD(AL(1,J),AL(1,J),KTERMJ) 784 IF(XXX.LE.0.0D0 ) THEN 785 WRITE(6,*) ' NEGATIVE DIAGONAL ELEMENT IN CHLFCB,J = ',J 786 WRITE(6,*) ' VALUE ', XXX 787 INDEF = 1 788 RETURN 789 ELSE 790 AL(JEFF,J) = SQRT(XXX) 791 END IF 792C 793 ALJJI = 1.0D0/AL(JEFF,J) 794C WRITE(6,*) ' ALJJI ',ALJJI 795 IMIN = J+1 796 IMAX = MIN(NDIM,J+IB) 797C WRITE(6,*) ' IMIN IMAX ',IMIN,IMAX 798 DO 80 I = IMIN,IMAX 799 IABSTR = MAX(1,I-IB) 800 JABSTR = MAX(1,J-IB) 801 KSTRJ = IABSTR-JABSTR + 1 802 KMAX = MIN(IB + 1 - KSTRJ,J-KSTRJ) 803 JEFFI = J + 1 - IABSTR 804C WRITE(6,*) ' I IABSTR JABSTR KSTRJ ' 805C WRITE(6,*) I,IABSTR,JABSTR,KSTRJ 806C WRITE(6,*) ' KMAX ,JEFFI ', KMAX,JEFFI 807 AL(JEFFI,I) = (AL(JEFFI,I) - 808 & INPROD( AL(1,I),AL(KSTRJ,J),KMAX ) )*ALJJI 809 80 CONTINUE 810C WRITE(6,*) ' CHOLESKY FACTORIZATION AFTER J ',J 811C CALL WRTMAT(AL,IB+1,NDIM,IB+1,NDIM) 812 100 CONTINUE 813C 814 IF( NTEST .GE. 10 ) THEN 815 WRITE(6,*) ' CHOLESKY FACTORIZATION ' 816 CALL WRTMAT(AL,IB+1,NDIM,IB+1,NDIM) 817 END IF 818C 819 RETURN 820 END 821 SUBROUTINE CHLFCE(AL,NDIM,IB,IALOFF,INDEF) 822C 823C FACTORIZE A SYMMETRIC POSITIVE DEFINITE ENVELOPE MATRIX,AL,TO GIVE 824C CHOLESKY FACTOR , ALSO IN AL . 825C 826C Matrix AL is stored rowwise in vector AL. 827C 828C ILOFF(I) Adress in L of first element of row I 829C IB(I) Column number of first row of I 830C 831C on output L will be stored in the same format 832 833C L : matrix stored rowwise in one dimensional array . 834C of first nonvaninhing element in row I 835C 836C Bordering method is used 837C 838 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 839 DIMENSION AL(*),IB(*),IALOFF(*) 840 REAL * 8 INPROD 841C 842 NTEST = 0 843 INDEF = 0 844 DO 100 I = 1, NDIM 845 IOFF = IALOFF(I) 846 ICSTRT = IB(I) 847 NJ = I - ICSTRT 848 DO 50 J = ICSTRT, I-1 849 JOFF = IALOFF(J) 850 JCSTRT = IB(J) 851 KMIN = MAX(ICSTRT,JCSTRT) 852 IADDI = KMIN-ICSTRT 853 IADDJ = KMIN-JCSTRT 854 NK = J - KMIN 855 IJEFF = IOFF + J - ICSTRT 856 JJEFF = JOFF + J - JCSTRT 857 AL(IJEFF) = 858 & (AL(IJEFF)-INPROD(AL(JOFF+IADDJ),AL(IOFF+IADDJ),NK)) / 859 & AL(JJEFF) 860 50 CONTINUE 861* 862 XXX = AL(IOFF+I-ICSTRT)-INPROD(AL(IOFF),AL(IOFF),NJ) 863 IF(XXX.LE.0.0D0 ) THEN 864 WRITE(6,*) ' NEGATIVE DIAGONAL ELEMENT IN CHLFCB,I = ',I 865 WRITE(6,*) ' VALUE ', XXX 866 INDEF = 1 867 RETURN 868 ELSE 869 AL(IOFF+NJ) = SQRT(XXX) 870 END IF 871 100 CONTINUE 872C 873 RETURN 874 END 875 SUBROUTINE CLSKHB(AL,X,B,NDIM,IB,ITASK,INDEF) 876C 877C MASTER ROUTINE FOR SOLVING LINEAR EQUATIONS THROUGH 878C CHOLESKY DECOMPOSITION OF POSITIVE DEFINITE BANDED MATRIX A 879C 880C THE ACTUAL TASK IS DEFINED THROUGH ITASK 881C 882C ITASK = 1 : FACTORIZE MATRIX AND RETURN 883C = 2 : FACTORIZATION HAVE BEEN PERFORMED ( INPUT IN AL ) 884C SOLVE LINEAR EQS. MATRIX * X = B 885C = 3 : FACTORIZE AND SOLVE LINEAR EQUATIONS A X = B 886C.. INPUT 887C 888C AL : ITASK = 1,3 : INPUT MATRIX ( FORMAT : SEE BELOW ) 889C OVERWRITTEN ! 890C ITASK = 2: L DECOMPOSITOTATION ASSUMED IN AL ) 891C NOT OVERWRITTEN 892C 893C X : VECTOR FOR SOLUTION TO LINEAR EQUATIONS 894C B : RHS VECTOR FOR LINEAR EQUATIONS( OVERWRITTEN ) 895C ( FOR ITASK = 1 X AND B CAN BE DUMMY VARIABLES ) 896C NDIM : ORDER OF MATRIX OF MATRICES AND VECTORS 897C IB : HALF BANDWIDTH, I.E. 2*IB + 1 ELEMENTS IN EACH 898C ROW ARE ASSUMED NONVANISHING 899C ITASK : DEFINING TASK OF ROUTINE AS ABOVE 900C 901C OUTPUT : 902C ITASK = 1, 3 : AL IS L DECOMPOSITITION , I.E, 903C L IS A LOWER TRIANGULAR POSITIVE MATRIX AND 904C A = L * L ( TRANSPOSED ) 905C 906C ITASK = 2,3 : X IS SOLUTION TO LINEAR SET OF EQUATIONS 907C INDEF ( FOR ITASK = 1, 3 ) : 908C 0 : MATRIX DECOMPOSED IS NOT INDEFINITE 909C .NE.0 : ABNORMAL TERMINATION DUE TO INDEFINITE MATRIX 910C 911C NOTE ON STRUCTURE OF MATRIX 912C 913C THE MATRIX IS ASSUMED PACKED SO ONLY LOWER HALF ELEMENTS IN 914C THE BAND IS STORED . A IS STORED AS A TWO DIMENSIONAL ARRAY 915CWITH 916C SECOND INDEX : ROW NUMBER 917C FIRST INDEX : NONVANISHING ELEMENTS FOR THIS ROW, STARTS WITH 918C FIRST NONVANISHING ELEMENT, AND ENDS WITH 919C DIAGONAL ELEMENT. 920C 921 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 922 DIMENSION AL(IB+1,NDIM),X(*),B(*) 923C 924 IF ( ITASK .EQ. 1 .OR. ITASK .EQ. 3 ) THEN 925C 926C... CHOLESKY FACTORIZATION 927C 928 CALL LUCIAQENTER('CHOLF') 929 CALL CHLFCB(AL,NDIM,IB,INDEF) 930 CALL LUCIAQEXIT ('CHOLF') 931 END IF 932C 933 IF( ITASK .EQ. 2 .OR. ITASK .EQ. 3 ) THEN 934C L * L (T) X = B 935C IS SOLVED IN TWO STEPS 936C 1 : L Y = B TO GET Y 937C 2 : L(T) X = Y TO GET X 938C 939 CALL LUCIAQENTER('CHOLS') 940 CALL LXEBB(AL,X,B,NDIM,IB) 941 CALL COPVEC(X,B,NDIM) 942 CALL LTXEBB(AL,X,B,NDIM,IB) 943 CALL LUCIAQEXIT('CHOLS') 944 END IF 945C 946 RETURN 947 END 948 SUBROUTINE CLSKHE(AL,X,B,NDIM,IB,IALOFF,ITASK,INDEF) 949C 950C Master routine for envelope Cholesky routines . 951C Factorize and/or solve set of linear equations for a 952C positive definete matrix A. 953C The envelope of A is given through IB : 954C IB(I) is column number for first nonvanishing element of 955C row I 956C 957C ITASK = 1 : FACTORIZE MATRIX AND RETURN 958C = 2 : FACTORIZATION HAVE BEEN PERFORMED ( INPUT IN AL ) 959C SOLVE LINEAR EQS. MATRIX * X = B 960C = 3 : FACTORIZE AND SOLVE LINEAR EQUATIONS A X = B 961C.. INPUT 962C 963C AL : ITASK = 1,3 : INPUT MATRIX ( FORMAT : SEE BELOW ) 964C OVERWRITTEN ! 965C ITASK = 2: L DECOMPOSITOTATION ASSUMED IN AL ) 966C NOT OVERWRITTEN 967C 968C X : VECTOR FOR SOLUTION TO LINEAR EQUATIONS 969C B : RHS VECTOR FOR LINEAR EQUATIONS( OVERWRITTEN ) 970C ( FOR ITASK = 1 X AND B CAN BE DUMMY VARIABLES ) 971C NDIM : ORDER OF MATRIX OF MATRICES AND VECTORS 972C IB(I) is column number for first nonvanishing element of 973C row I 974C IALOFF : scratch array . 975C ITASK : DEFINING TASK OF ROUTINE AS ABOVE 976C 977C OUTPUT : 978C ITASK = 1, 3 : AL IS L DECOMPOSITITION , I.E, 979C L IS A LOWER TRIANGULAR POSITIVE MATRIX AND 980C A = L * L ( TRANSPOSED ) 981C 982C ITASK = 2,3 : X IS SOLUTION TO LINEAR SET OF EQUATIONS 983C INDEF ( FOR ITASK = 1, 3 ) : 984C 0 : MATRIX DECOMPOSED IS NOT INDEFINITE 985C .NE.0 : ABNORMAL TERMINATION DUE TO INDEFINITE MATRIX 986C 987C NOTE ON STRUCTURE OF MATRIX 988C 989C THE MATRIX IS ASSUMED PACKED SO ONLY LOWER ELEMENTS of 990C THE envelope are stored . The matrix is stored as consecutive rows 991C in a one dimensional vector AL 992C 993C in order to ease indexing an offset vector IALOFF is constructed 994C so IALOFF(I) is first adress in AL of first element in row I 995C 996 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 997 DIMENSION AL(*),X(*),B(*) 998 DIMENSION IB(*),IALOFF(*) 999* 1000 NTEST = 00 1001 IF(NTEST.GE.10) THEN 1002 WRITE(6,*) ' Output from CLSKHE:' 1003 WRITE(6,*) ' ===================' 1004 WRITE(6,*) ' NDIM = ', NDIM 1005 WRITE(6,*) ' ITASK = ', ITASK 1006 END IF 1007 IF(NTEST.GE.100) THEN 1008 WRITE(6,*) ' Envelope array (IB) ' 1009 CALL IWRTMA(IB,1,NDIM,1,NDIM) 1010 END IF 1011C 1012C 1013C. Pointer array IALOFF 1014 IALOFF(1) = 1 1015 DO 10 I = 1, NDIM - 1 1016 IALOFF(I+1) = IALOFF(I) + ( I + 1 - IB(I) ) 1017 10 CONTINUE 1018C 1019 IF (NTEST .GE. 100) THEN 1020 WRITE(6,*) ' IALOFF array ' 1021 CALL IWRTMA(IALOFF,1,NDIM,1,NDIM) 1022 END IF 1023C 1024 IF ( ITASK .EQ. 1 .OR. ITASK .EQ. 3 ) THEN 1025C 1026C... CHOLESKY FACTORIZATION 1027C 1028 CALL LUCIAQENTER('CHOLF') 1029 CALL CHLFCE(AL,NDIM,IB,IALOFF,INDEF) 1030 CALL LUCIAQEXIT ('CHOLF') 1031* 1032 IF(NTEST.GE.100) THEN 1033 WRITE(6,*) ' Cholesky factorized matrix ' 1034 CALL PRSYM(AL,NDIM) 1035 END IF 1036 END IF 1037C 1038 IF( ITASK .EQ. 2 .OR. ITASK .EQ. 3 ) THEN 1039C L * L (T) X = B 1040C IS SOLVED IN TWO STEPS 1041C 1 : L Y = B TO GET Y 1042C 2 : L(T) X = Y TO GET X 1043C 1044 IF(NTEST.GE.100) THEN 1045 WRITE(6,*) ' The right hand side vector ' 1046 CALL WRTMAT(B,1,NDIM,1,NDIM) 1047 END IF 1048 CALL LUCIAQENTER('CHOLS') 1049 CALL LXEBE(AL,X,B,NDIM,IB,IALOFF) 1050 CALL COPVEC(X,B,NDIM) 1051 CALL LTXEBE(AL,X,B,NDIM,IB,IALOFF) 1052 CALL LUCIAQEXIT('CHOLS') 1053 IF(NTEST.GE.100) THEN 1054 WRITE(6,*) ' The solution vector ' 1055 CALL WRTMAT(X,1,NDIM,1,NDIM) 1056 END IF 1057 END IF 1058C 1059 RETURN 1060 END 1061 SUBROUTINE CMP2VC(VEC1,VEC2,NDIM,THRES) 1062C 1063C COMPARE TWO DOUBLE PRECISION VECTORS VEC1,AND VEC2 1064C 1065C ONLY ELEMENTS THAT DIFFERS BY MORE THAN THRE ARE PRINTED 1066C 1067 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1068 DIMENSION VEC1(1),VEC2(1) 1069C 1070 XMXDIF = 0.0D0 1071 IMXPLC = 0 1072 WRITE(6,*) ' COMPARISON OF TWO VECTORS ' 1073 WRITE(6,*) ' VECTOR1 VECTOR2 DIFFERENCE ' 1074 DO 100 I = 1, NDIM 1075 DIF = VEC1(I) - VEC2 ( I ) 1076 IF( ABS(DIF ) .GE. XMXDIF ) THEN 1077 XMXDIF = ABS(DIF) 1078 IMXPLC = I 1079 END IF 1080 IF( ABS ( DIF ) .GT. THRES ) THEN 1081 WRITE(6,'(2X,I5,3E15.8)') I,VEC1(I),VEC2(I),DIF 1082 END IF 1083 100 CONTINUE 1084C 1085 IF( XMXDIF .EQ. 0.0D0 ) THEN 1086 WRITE(6,*) ' THE TWO VECTORS ARE IDENTICAL ' 1087 ELSE 1088 WRITE(6,*) ' SIZE AND LAST PLACE OF LARGEST DEVIATION ', 1089 & XMXDIF,IMXPLC 1090 END IF 1091C 1092 RETURN 1093 END 1094 SUBROUTINE COPDSC(ARRAY,NDIM,NBLOCK,IFROM,ITO) 1095C 1096C COPY DOUBLE PRECISION ARRAY FROM DISC FILE IFROM TO DISCFILE ITO 1097C 1098 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1099 DIMENSION ARRAY(1) 1100C 1101 IREST=NDIM 1102 IF ( IREST .EQ. 0 ) GOTO 101 1103 100 CONTINUE 1104C DO 100 WHILE(IREST.GT.0) 1105C WHILE (IREST.GT.0) 1106 IF(IREST.GT.NBLOCK) THEN 1107 READ(IFROM) (ARRAY(I),I=1,NBLOCK) 1108 WRITE(ITO) (ARRAY(I),I=1,NBLOCK) 1109C IBASE=IBASE+NBLOCK 1110 IREST=IREST-NBLOCK 1111 ELSE 1112 READ(IFROM) (ARRAY(I),I=1,IREST) 1113 WRITE(ITO) (ARRAY(I),I=1,IREST) 1114 IREST=0 1115 END IF 1116 IF( IREST .GT. 0) GOTO 100 1117 101 CONTINUE 1118C END WHILE 1119C 100 END DO 1120C 1121 RETURN 1122 END 1123 SUBROUTINE COPVCDP(LUIN,LUOUT,SEGMNT,IREW,LBLK) 1124C 1125C COPY VECTOR ON FILE LUIN TO FILE LUOUT 1126* 1127* Packed version 1128C 1129C 1130C LBLK DEFINES STRUCTURE OF FILE 1131C Type of file LUOUT is inherited from LUIN 1132 IMPLICIT REAL*8(A-H,O-Z) 1133 DIMENSION SEGMNT(*) 1134C 1135 IF( IREW .NE. 0 ) THEN 1136 CALL REWINE( LUIN ,LBLK) 1137 CALL REWINE( LUOUT ,LBLK) 1138 END IF 1139 1140C 1141C LOOP OVER BLOCKS 1142C 1143C? write(6,*) ' COPVCD LBLK : ', LBLK 1144 1000 CONTINUE 1145 IF(LBLK .GT. 0 ) THEN 1146 LBL = LBLK 1147 ELSE IF ( LBLK .EQ. 0 ) THEN 1148 READ(LUIN) LBL 1149 WRITE(LUOUT) LBL 1150C? write(6,*) ' COPVCD LBL : ', LBL 1151 ELSE IF (LBLK .LT. 0 ) THEN 1152 CALL IFRMDS(LBL,1,-1,LUIN) 1153 CALL ITODS (LBL,1,-1,LUOUT) 1154 END IF 1155 IF( LBL .GE. 0 ) THEN 1156 IF(LBLK .GE.0 ) THEN 1157 KBLK = LBL 1158 ELSE 1159 KBLK = -1 1160 END IF 1161C? write(6,*) ' LBL and KBLK ', LBL,KBLK 1162 CALL FRMDSC(SEGMNT,LBL,KBLK,LUIN,IMZERO,IAMPACK) 1163 CALL TODSCP(SEGMNT,LBL,KBLK,LUOUT) 1164 END IF 1165 IF( LBL .GE. 0 .AND. LBLK .LE. 0 ) GOTO 1000 1166C 1167 RETURN 1168 END 1169 SUBROUTINE COPVCD(LUIN,LUOUT,SEGMNT,IREW,LBLK) 1170C 1171C COPY VECTOR ON FILE LUIN TO FILE LUOUT 1172C 1173C 1174C LBLK DEFINES STRUCTURE OF FILE 1175* 1176* Structure of output file is inherited by output file, 1177* if input file is packed, so is output file 1178* 1179* 1180C Type of file LUOUT is inherited from LUIN 1181 IMPLICIT REAL*8(A-H,O-Z) 1182 DIMENSION SEGMNT(*) 1183C 1184 IF( IREW .NE. 0 ) THEN 1185 CALL REWINE( LUIN ,LBLK) 1186 CALL REWINE( LUOUT ,LBLK) 1187 END IF 1188 1189C 1190C LOOP OVER BLOCKS 1191C 1192C? write(6,*) ' COPVCD LBLK : ', LBLK 1193 1000 CONTINUE 1194 IF(LBLK .GT. 0 ) THEN 1195 LBL = LBLK 1196 ELSE IF ( LBLK .EQ. 0 ) THEN 1197 READ(LUIN) LBL 1198 WRITE(LUOUT) LBL 1199C? write(6,*) ' COPVCD LBL : ', LBL 1200 ELSE IF (LBLK .LT. 0 ) THEN 1201 CALL IFRMDS(LBL,1,-1,LUIN) 1202 CALL ITODS (LBL,1,-1,LUOUT) 1203 END IF 1204 IF( LBL .GE. 0 ) THEN 1205 IF(LBLK .GE.0 ) THEN 1206 KBLK = LBL 1207 ELSE 1208 KBLK = -1 1209 END IF 1210C? write(6,*) ' LBL and KBLK ', LBL,KBLK 1211 NO_ZEROING = 1 1212 CALL FRMDSC2(SEGMNT,LBL,KBLK,LUIN,IMZERO,IAMPACK, 1213 & NO_ZEROING) 1214 IF(IAMPACK.NE.0) THEN 1215C? WRITE(6,*) ' COPVCD, IAMPACK,FILE = ', IAMPACK,LUIN 1216 END IF 1217 IF(IMZERO.EQ.0) THEN 1218 IF(IAMPACK.EQ.0) THEN 1219 CALL TODSC (SEGMNT,LBL,KBLK,LUOUT) 1220 ELSE 1221 CALL TODSCP(SEGMNT,LBL,KBLK,LUOUT) 1222 END IF 1223 ELSE 1224 CALL ZERORC(LBL,LUOUT,IAMPACK) 1225 END IF 1226 END IF 1227 IF( LBL .GE. 0 .AND. LBLK .LE. 0 ) GOTO 1000 1228C 1229 RETURN 1230 END 1231 SUBROUTINE COPVEC(FROM,TO,NDIM) 1232C 1233 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1234C 1235 COMMON/COPVECST/XNCALL_COPVEC, XNMOVE_COPVEC 1236 INCLUDE 'rou_stat.inc' 1237C COMMON/ROU_STAT/NCALL_SCALVE,NCALL_SETVEC,NCALL_COPVEC, 1238C & NCALL_MATCG,NCALL_MATCAS,NCALL_ADD_SKAIIB, 1239C & NCALL_GET_CKAJJB, 1240C & XOP_SCALVE,XOP_SETVEC,XOP_COPVEC, 1241C & XOP_MATCG,XOP_MATCAS,XOP_ADD_SKAIIB, 1242C & XOP_GET_CKAJJB 1243 1244 DIMENSION FROM(1),TO(1) 1245C 1246 XNCALL_COPVEC = XNCALL_COPVEC + 1 1247 NCALL_COPVEC = NCALL_COPVEC + 1 1248 XOP_COPVEC = XOP_COPVEC + NDIM 1249* 1250 XNMOVE_COPVEC = XNMOVE_COPVEC + NDIM 1251 DO 100 I=1,NDIM 1252 TO(I)=FROM(I) 1253 100 CONTINUE 1254C 1255 RETURN 1256 END 1257* 1258 SUBROUTINE DIAVC2(VECOUT,VECIN,DIAG,SHIFT,NDIM) 1259C 1260C VECOUT(I)=VECIN(I)/(DIAG(I)+SHIFT) 1261C 1262 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1263 DIMENSION VECOUT(1),VECIN(1),DIAG(1) 1264C 1265 NTEST = 000 1266 IF(NTEST.GE.100) THEN 1267 WRITE(6,*) ' Info from DIAVC2: ' 1268 WRITE(6,*) ' NDIM = ', NDIM 1269 END IF 1270 IF(NTEST.GE.1000) THEN 1271 WRITE(6,*) 'DIAG and VECIN: ' 1272 CALL WRTMAT(DIAG,1,NDIM,1,NDIM) 1273 CALL WRTMAT(VECIN,1,NDIM,1,NDIM) 1274 END IF 1275* 1276 DO 100 I=1,NDIM 1277 DIVIDE=DIAG(I)+SHIFT 1278 THRES=1.0D-10 1279 IF(ABS(DIVIDE).LE.THRES) DIVIDE=THRES 1280 IF(VECIN(I).EQ.0.0D0) THEN 1281 VECOUT(I) = 0.0D0 1282 ELSE 1283 VECOUT(I)=VECIN(I)/DIVIDE 1284 END IF 1285 100 CONTINUE 1286 RETURN 1287 END 1288* 1289 SUBROUTINE DIAVC3(VECOUT,VECIN,DIAG,SHIFT,NDIM,VDSV) 1290* 1291* VECOUT(I)=VECIN(I)/(DIAG(I)+SHIFT) 1292* 1293* VDSV = SUM(I) VECIN(I) ** 2 /( DIAG(I) + SHIFT ) 1294 1295 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1296 DIMENSION VECOUT(1),VECIN(1),DIAG(1) 1297* 1298 THRES=1.0D-10 1299 VDSV = 0.0D0 1300 DO 100 I=1,NDIM 1301* 1302 DIVIDE=DIAG(I)+SHIFT 1303 IF(ABS(DIVIDE).LE.THRES) DIVIDE=THRES 1304* 1305 VDSV = VDSV + VECIN(I) ** 2 /DIVIDE 1306 VECOUT(I)=VECIN(I)/DIVIDE 1307* 1308 100 CONTINUE 1309* 1310 NTEST =00 1311c IF(NTEST.GE.100) THEN 1312 WRITE(6,*) 'DIAVC3 : VECIN, DIAG,VECOUT ' 1313 DO I = 1, NDIM 1314 WRITE(6,'(3E15.8)') VECIN(I),DIAG(I),VECOUT(I) 1315 END DO 1316c END IF 1317 RETURN 1318 END 1319* 1320 SUBROUTINE DIAVC3G(VECOUT,VECIN,DIAG,SHIFT,NDIM,VDSV) 1321* 1322* VECOUT(I)=VECIN(I)/(DIAG(I)+SHIFT) 1323* 1324* VDSV = SUM(I) VECIN(I) ** 2 /( DIAG(I) + SHIFT ) 1325 1326 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1327 integer VECOUT,VECIN,DIAG 1328#include "errquit.fh" 1329#include "mafdecls.fh" 1330#include "global.fh" 1331* 1332 THRES=1.0D-10 1333 VDSV = 0.0D0 1334 call ga_distribution(DIAG, ga_nodeid(),ilo,ihi,idum,idum) 1335 if (ihi.gt.0) then 1336 call ga_access(DIAG,ilo,ihi,1,1,idiag,idum) 1337 call ga_access(VECIN,ilo,ihi,1,1,ivecin,idum) 1338 if (VECOUT.eq.DIAG) ivecout = idiag 1339 if (VECOUT.eq.VECIN) ivecout = ivecin 1340c 1341 DO 100 I=0, ihi-ilo 1342 DIVIDE=dbl_mb(idiag+i)+SHIFT 1343 IF(ABS(DIVIDE).LE.THRES) DIVIDE=THRES 1344* 1345 VDSV = VDSV + dbl_mb(ivecin+i) ** 2 /DIVIDE 1346 dbl_mb(ivecout+i) = dbl_mb(ivecin+i) / DIVIDE 1347* 1348 100 CONTINUE 1349* 1350 NTEST = 00 1351 IF(NTEST.GE.100) THEN 1352 WRITE(6,*) 'DIAVC3 : VECIN, DIAG' 1353 DO I = 0, ihi-ilo 1354 WRITE(6,'(I5,3E15.8)') i,dbl_mb(ivecout+i),dbl_mb(idiag+i), 1355 & dbl_mb(ivecin+i) 1356 END DO 1357 END IF 1358 call ga_release(DIAG,ilo,ihi,1,1) 1359 call ga_release(VECIN,ilo,ihi,1,1) 1360 endif 1361 call ga_sync() 1362 call ga_dgop(1,VDSV,1,'+') 1363 RETURN 1364 END 1365* 1366 SUBROUTINE DMTVCD_OLD(VEC1,VEC2,LU1,LU2,LU3,FAC,IREW,INV,LBLK) 1367C 1368C IF( INV .NE. 0 ) THEN 1369C V3(I) = (V1(I)+FAC)-1 * V2(I) 1370C LU3 LU1 LU2 1371C IF( INV .EQ. 0 ) THEN 1372C V3(I) = (V1(I)+FAC) * V2(I) 1373C LU3 LU1 LU2 1374C WHERE V1 AND V2 ARE VECTORS ON FILES LU1 AND LU2, 1375C AND LU3 IS WRITTEN ON FILE LU3 1376C 1377C LBLK DEFINES STRUCTURE OF FILES 1378C 1379 IMPLICIT REAL*8(A-H,O-Z) 1380 DIMENSION VEC1(*),VEC2(*) 1381C 1382 IF ( IREW .NE. 0 ) THEN 1383 IF( LBLK .GE. 0 ) THEN 1384 REWIND LU1 1385 REWIND LU2 1386 REWIND LU3 1387 ELSE 1388 CALL REWINE( LU1,LBLK) 1389 CALL REWINE( LU2,LBLK) 1390 CALL REWINE( LU3,LBLK) 1391 END IF 1392 END IF 1393C 1394C LOOP OVER BLOCKS 1395C 1396 IBLK = 0 1397 1000 CONTINUE 1398 IF (LBLK .GT. 0 ) THEN 1399 LBL1 = LBLK 1400 LBL2 = LBLK 1401 ELSE IF( LBLK .EQ. 0 ) THEN 1402 READ(LU1) LBL1 1403 READ(LU2) LBL2 1404 WRITE(LU3) LBL1 1405 ELSE IF (LBLK .LT. 0 ) THEN 1406 CALL IFRMDS(LBL1,1,-1,LU1) 1407 CALL IFRMDS(LBL2,1,-1,LU2) 1408 CALL ITODS (LBL1,1,-1,LU3) 1409 END IF 1410 IBLK = IBLK + 1 1411 IF(LBL1 .NE. LBL2 ) THEN 1412 WRITE(6,'(A,2I3)') ' DIFFERENT BLOCKSIZES IN DMTVCD_OLD : ' 1413 & , LBL1,LBL2 1414 WRITE(6,*) 'CURRENT SEGMENT WAS ',IBLK 1415 STOP ' DIFFERENT BLOCKSIZES IN DMTVCD_OLD ' 1416 END IF 1417 IF(LBL1 .GE. 0 ) THEN 1418 IF( LBLK .GE.0 ) THEN 1419 KBLK = LBL1 1420 ELSE 1421 KBLK = -1 1422 END IF 1423 CALL FRMDSC(VEC1,LBL1,KBLK,LU1,IMZERO,IAMPACK) 1424 CALL FRMDSC(VEC2,LBL1,KBLK,LU2,IMZERO,IAMPACK) 1425 IF( LBL1 .GT. 0 )THEN 1426 IF(INV .NE. 0 ) THEN 1427 CALL DIAVC2(VEC2,VEC2,VEC1,FAC,LBL1) 1428 ELSE 1429 CALL VVTOV(VEC1,VEC2,VEC1,LBL1) 1430 CALL VECSUM(VEC2,VEC1,VEC2,1.0D0,FAC,LBL1) 1431 END IF 1432C CALL TODSC(VEC2,LBL1,KBLK,LU3) 1433 END IF 1434 CALL TODSC(VEC2,LBL1,KBLK,LU3) 1435 END IF 1436C 1437 IF( LBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 1438C 1439 RETURN 1440 END 1441 SUBROUTINE DMTVCD(VEC1,VEC2,LU1,LU2,LU3,FAC,IREW,INV,LBLK) 1442C mod version where lu1=lu2 is allowed 1443C 1444C IF( INV .NE. 0 ) THEN 1445C V3(I) = (V1(I)+FAC)-1 * V2(I) 1446C LU3 LU1 LU2 1447C IF( INV .EQ. 0 ) THEN 1448C V3(I) = (V1(I)+FAC) * V2(I) 1449C LU3 LU1 LU2 1450C WHERE V1 AND V2 ARE VECTORS ON FILES LU1 AND LU2, 1451C AND LU3 IS WRITTEN ON FILE LU3 1452C 1453C LBLK DEFINES STRUCTURE OF FILES 1454C 1455 IMPLICIT REAL*8(A-H,O-Z) 1456 DIMENSION VEC1(*),VEC2(*) 1457C 1458 IF ( IREW .NE. 0 ) THEN 1459 IF( LBLK .GE. 0 ) THEN 1460 REWIND LU1 1461 IF (LU2.NE.LU1) REWIND LU2 1462 REWIND LU3 1463 ELSE 1464 CALL REWINE( LU1,LBLK) 1465 IF (LU2.NE.LU1) CALL REWINE( LU2,LBLK) 1466 CALL REWINE( LU3,LBLK) 1467 END IF 1468 END IF 1469C 1470C LOOP OVER BLOCKS 1471C 1472 IBLK = 0 1473 1000 CONTINUE 1474 IF (LBLK .GT. 0 ) THEN 1475 LBL1 = LBLK 1476 LBL2 = LBLK 1477 ELSE IF( LBLK .EQ. 0 ) THEN 1478 READ(LU1) LBL1 1479 IF (LU1.NE.LU2) THEN 1480 READ(LU2) LBL2 1481 ELSE 1482 LBL2 = LBL1 1483 END IF 1484 WRITE(LU3) LBL1 1485 ELSE IF (LBLK .LT. 0 ) THEN 1486 CALL IFRMDS(LBL1,1,-1,LU1) 1487 IF (LU1.NE.LU2) THEN 1488 CALL IFRMDS(LBL2,1,-1,LU2) 1489 ELSE 1490 LBL2 = LBL1 1491 END IF 1492 CALL ITODS (LBL1,1,-1,LU3) 1493 END IF 1494 IBLK = IBLK + 1 1495 IF(LBL1 .NE. LBL2 ) THEN 1496 WRITE(6,'(A,2I5)') ' DIFFERENT BLOCKSIZES IN DMTVCD : ' 1497 & , LBL1,LBL2 1498 WRITE(6,'(A,2I3,A,I3,A)') 1499 & ' UNITS: ',LU1, LU2,'(IN) - ',LU3,' (OUT)' 1500 WRITE(6,*) 'CURRENT SEGMENT WAS ',IBLK 1501 CALL UNIT_INFO(LU1) 1502 CALL UNIT_INFO(LU2) 1503 CALL UNIT_INFO(LU3) 1504 STOP ' DIFFERENT BLOCKSIZES IN DMTVCD ' 1505 END IF 1506 IF(LBL1 .GE. 0 ) THEN 1507 IF( LBLK .GE.0 ) THEN 1508 KBLK = LBL1 1509 ELSE 1510 KBLK = -1 1511 END IF 1512 CALL FRMDSC(VEC1,LBL1,KBLK,LU1,IMZERO,IAMPACK) 1513 IF (LU2.NE.LU1) 1514 & CALL FRMDSC(VEC2,LBL1,KBLK,LU2,IMZERO,IAMPACK) 1515 IF (LU2.NE.LU1.AND.LBL1.GT.0) THEN 1516 IF(INV .NE. 0 ) THEN 1517 CALL DIAVC2(VEC2,VEC2,VEC1,FAC,LBL1) 1518 ELSE 1519 CALL VVTOV(VEC1,VEC2,VEC1,LBL1) 1520 CALL VECSUM(VEC2,VEC1,VEC2,1.0D0,FAC,LBL1) 1521 END IF 1522 ELSE IF (LBL1.GT.0) THEN 1523 IF(INV .NE. 0 ) THEN 1524 CALL DIAVC2(VEC2,VEC1,VEC1,FAC,LBL1) 1525 ELSE 1526 CALL VVTOV(VEC1,VEC1,VEC2,LBL1) 1527 CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,FAC,LBL1) 1528 END IF 1529 END IF 1530 CALL TODSC(VEC2,LBL1,KBLK,LU3) 1531 END IF 1532C 1533 IF( LBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 1534C 1535 RETURN 1536 END 1537 SUBROUTINE DMTVCD2(VEC1,VEC2,LU1,LU2,LU3,FAC,DMP,IREW,INV,LBLK) 1538C mod version where lu1=lu2 is allowed 1539C 1540C IF( INV .NE. 0 ) THEN 1541C V3(I) = FAC1 * (V1(I)+DMP)-1 * V2(I) 1542C LU3 LU1 LU2 1543C IF( INV .EQ. 0 ) THEN 1544C V3(I) = FAC1 * (V1(I)+DMP) * V2(I) 1545C LU3 LU1 LU2 1546C WHERE V1 AND V2 ARE VECTORS ON FILES LU1 AND LU2, 1547C AND LU3 IS WRITTEN ON FILE LU3 1548C 1549C LBLK DEFINES STRUCTURE OF FILES 1550C 1551 IMPLICIT REAL*8(A-H,O-Z) 1552 DIMENSION VEC1(*),VEC2(*) 1553C 1554 IF ( IREW .NE. 0 ) THEN 1555 IF( LBLK .GE. 0 ) THEN 1556 REWIND LU1 1557 IF (LU2.NE.LU1) REWIND LU2 1558 REWIND LU3 1559 ELSE 1560 CALL REWINE( LU1,LBLK) 1561 IF (LU2.NE.LU1) CALL REWINE( LU2,LBLK) 1562 CALL REWINE( LU3,LBLK) 1563 END IF 1564 END IF 1565C 1566C LOOP OVER BLOCKS 1567C 1568 IBLK = 0 1569 1000 CONTINUE 1570 IF (LBLK .GT. 0 ) THEN 1571 LBL1 = LBLK 1572 LBL2 = LBLK 1573 ELSE IF( LBLK .EQ. 0 ) THEN 1574 READ(LU1) LBL1 1575 IF (LU1.NE.LU2) THEN 1576 READ(LU2) LBL2 1577 ELSE 1578 LBL2 = LBL1 1579 END IF 1580 WRITE(LU3) LBL1 1581 ELSE IF (LBLK .LT. 0 ) THEN 1582 CALL IFRMDS(LBL1,1,-1,LU1) 1583 IF (LU1.NE.LU2) THEN 1584 CALL IFRMDS(LBL2,1,-1,LU2) 1585 ELSE 1586 LBL2 = LBL1 1587 END IF 1588 CALL ITODS (LBL1,1,-1,LU3) 1589 END IF 1590 IBLK = IBLK + 1 1591 IF(LBL1 .NE. LBL2 ) THEN 1592 WRITE(6,'(A,2I5)') ' DIFFERENT BLOCKSIZES IN DMTVCD2 : ' 1593 & , LBL1,LBL2 1594 WRITE(6,'(A,2I3,A,I3,A)') 1595 & ' UNITS: ',LU1, LU2,'(IN) - ',LU3,' (OUT)' 1596 WRITE(6,*) 'CURRENT SEGMENT WAS ',IBLK 1597 CALL UNIT_INFO(LU1) 1598 CALL UNIT_INFO(LU2) 1599 CALL UNIT_INFO(LU3) 1600 STOP ' DIFFERENT BLOCKSIZES IN DMTVCD2 ' 1601 END IF 1602 IF(LBL1 .GE. 0 ) THEN 1603 IF( LBLK .GE.0 ) THEN 1604 KBLK = LBL1 1605 ELSE 1606 KBLK = -1 1607 END IF 1608 CALL FRMDSC(VEC1,LBL1,KBLK,LU1,IMZERO,IAMPACK) 1609 IF (LU2.NE.LU1) 1610 & CALL FRMDSC(VEC2,LBL1,KBLK,LU2,IMZERO,IAMPACK) 1611 IF (LU2.NE.LU1.AND.LBL1.GT.0) THEN 1612 IF(INV .NE. 0 ) THEN 1613 CALL DIAVC2(VEC2,VEC2,VEC1,DMP,LBL1) 1614 ELSE 1615 CALL VVTOV(VEC1,VEC2,VEC1,LBL1) 1616 CALL VECSUM(VEC2,VEC1,VEC2,1.0D0,DMP,LBL1) 1617 END IF 1618 ELSE IF (LBL1.GT.0) THEN 1619 IF(INV .NE. 0 ) THEN 1620 CALL DIAVC2(VEC2,VEC1,VEC1,DMP,LBL1) 1621 ELSE 1622 CALL VVTOV(VEC1,VEC1,VEC2,LBL1) 1623 CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,DMP,LBL1) 1624 END IF 1625 END IF 1626 IF (FAC.NE.1d0) CALL SCALVE(VEC2,FAC,LBL1) 1627 CALL TODSC(VEC2,LBL1,KBLK,LU3) 1628 END IF 1629C 1630 IF( LBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 1631C 1632 RETURN 1633 END 1634 SUBROUTINE EIGENL(A,R,N,MV,MFKR) 1635 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1636 DIMENSION A(1),R(1) 1637 DATA TESTIT/1.D-20/ 1638 DATA TESTX/1.D-26/ 1639 DATA TESTY/1.D-18/ 1640C 1641C PURPOSE 1642C COMPUTE EIGENVALUES AND EIGENVECTORS OF A REAL SYMMETRIC 1643C MATRIX 1644C 1645C USAGE 1646C CALL EIGEN(A,R,N,MV,MFKR) 1647C 1648C DESCRIPTION OF PARAMETERS 1649C A - ORIGINAL MATRIX (SYMMETRIC), DESTROYED IN COMPUTATION. 1650C RESULTANT EIGENVALUES ARE DEVELOPED IN DIAGONAL OF 1651C MATRIX A IN ASSCENDING ORDER. 1652C R - RESULTANT MATRIX OF EIGENVECTORS (STORED COLUMNWISE, 1653C IN SAME SEQUENCE AS EIGENVALUES) 1654C N - ORDER OF MATRICES A AND R 1655C MV- INPUT CODE 1656C 0 COMPUTE EIGENVALUES AND EIGENVECTORS 1657C 1 COMPUTE EIGENVALUES ONLY (R NEED NOT BE 1658C DIMENSIONED BUT MUST STILL APPEAR IN CALLING 1659C SEQUENCE) 1660C MFKR=0 NO SORT 1661C =1 SORT 1662C 1663C REMARKS 1664C ORIGINAL MATRIX A MUST BE REAL SYMMETRIC (STORAGE MODE=1) 1665C MATRIX A CANNOT BE IN THE SAME LOCATION AS MATRIX R 1666C 1667C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED 1668C NONE 1669C 1670C METHOD 1671C DIAGONALIZATION METHOD ORIGINATED BY JACOBI AND ADAPTED 1672C BY VON NEUMANN FOR LARGE COMPUTERS AS FOUND IN ?MATHEMATICAL 1673C METHODS FOR DIGITAL COMPUTERS?, EDITED BY A. RALSTON AND 1674C H.S. WILF, JOHN WILEY AND SONS, NEW YORK, 1962, CHAPTER 7 1675C 1676C .................................................................. 1677C 1678C 1679C ............................................................... 1680C 1681C IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE 1682C C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION 1683C STATEMENT WHICH FOLLOWS. 1684C 1685C DOUBLE PRECISION A,R,ANORM,ANRMX,THR,X,Y,SINX,SINX2,COSX, 1686C 1 COSX2,SINCS,RANGE 1687C 1688C THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS 1689C APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS 1690C ROUTINE. 1691C 1692C THE DOUBLE PRECISION VERSION OF THIS SUBROUTINE MUST ALSO 1693C CONTAIN DOUBLE PRECISION FORTRAN FUNCTIONS. SQRT IN STATEMENTS 1694C 40, 68, 75, AND 78 MUST BE CHANGED TO DSQRT. ABS IN STATEMENT 1695C 62 MUST BE CHANGED TO DABS. THE CONSTANT IN STATEMENT 5 SHOULD 1696C BE CHANGED TO 1.0D-12. 1697C 1698C ............................................................... 1699C 1700C GENERATE IDENTITY MATRIX 1701C 1702 5 RANGE=1.0D-12 1703 IF(MV-1) 10,25,10 1704 10 IQ=-N 1705 DO 20 J=1,N 1706 IQ=IQ+N 1707 DO 20 I=1,N 1708 IJ=IQ+I 1709 R(IJ)=0.0D+00 1710 IF(I-J) 20,15,20 1711 15 R(IJ)=1.0D+00 1712 20 CONTINUE 1713C 1714C COMPUTE INITIAL AND FINAL NORMS (ANORM AND ANORMX) 1715C 1716 25 ANORM=0.0D+00 1717 DO 35 I=1,N 1718 DO 35 J=I,N 1719 IF(I-J) 30,35,30 1720 30 IA=I+(J*J-J)/2 1721 ANORM=ANORM+A(IA)*A(IA) 1722 35 CONTINUE 1723 IF(ANORM) 165,165,40 1724 40 ANORM=1.414D+00*DSQRT(ANORM) 1725 ANRMX=ANORM*RANGE/DFLOAT(N) 1726C 1727C INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR 1728C 1729 IND=0 1730 THR=ANORM 1731 45 THR=THR/DFLOAT(N) 1732 IF(THR.LT.TESTY)THR=0.D0 1733 50 L=1 1734 55 M=L+1 1735C 1736C COMPUTE SIN AND COS 1737C 1738 60 MQ=(M*M-M)/2 1739 LQ=(L*L-L)/2 1740 LM=L+MQ 1741 IF(DABS(A(LM)).LT.TESTY)A(LM)=0.D0 1742 IF(DABS(A(LM)).EQ.0.D0.AND.THR.EQ.0.D0)GO TO 130 1743 62 IF( DABS(A(LM))-THR) 130,65,65 1744 65 IND=1 1745 LL=L+LQ 1746 MM=M+MQ 1747 X=0.5D+00*(A(LL)-A(MM)) 1748 AJUK=(A(LM)*A(LM)+X*X) 1749 AJUK=DSQRT(AJUK) 1750 IF(DABS(AJUK).LT.TESTIT)WRITE(6,3000)TESTIT,AJUK,A(LM) 1751 3000 FORMAT(1H0,'***DENOMINATOR LT ',D12.6,'. VALUE=',D14.8, 1752 ['. NUMERATOR=',D14.8) 1753 Y=0.D0 1754 IF(DABS(AJUK).LT.TESTIT)GO TO 67 1755 Y=-A(LM)/AJUK 1756 67 CONTINUE 1757 68 CONTINUE 1758C 68 Y=-A(LM)/ DSQRT(A(LM)*A(LM)+X*X) 1759 IF(X) 70,75,75 1760 70 Y=-Y 1761 75 AJUK=(1.D0-Y*Y) 1762 IF(AJUK.LT.0.D0)WRITE(6,3001) AJUK 1763 3001 FORMAT(1H0,'***DSQRT OF ',D14.8) 1764 IF(AJUK.LT.0.D0)AJUK=0.D0 1765 AJUK=DSQRT(AJUK) 1766 AJUK=2.D0*(1.D0+AJUK) 1767 AJUK=DSQRT(AJUK) 1768 SINX=Y/AJUK 1769 76 CONTINUE 1770C SINX=Y/ DSQRT(2.0D+00*(1.0D+00+( DSQRT(1.0D+00-Y*Y)))) 1771 SINX2=SINX*SINX 1772C 78 COSX= DSQRT(1.0D+00-SINX2) 1773 78 CONTINUE 1774 AJUK=1.D0-SINX2 1775 IF(AJUK.LT.TESTX)AJUK=0.D0 1776 COSX=DSQRT(AJUK) 1777 COSX2=COSX*COSX 1778 SINCS =SINX*COSX 1779C 1780C ROTATE L AND M COLUMNS 1781C 1782 ILQ=N*(L-1) 1783 IMQ=N*(M-1) 1784 DO 125 I=1,N 1785 IQ=(I*I-I)/2 1786 IF(I-L) 80,115,80 1787 80 IF(I-M) 85,115,90 1788 85 IM=I+MQ 1789 GO TO 95 1790 90 IM=M+IQ 1791 95 IF(I-L) 100,105,105 1792 100 IL=I+LQ 1793 GO TO 110 1794 105 IL=L+IQ 1795 110 X=A(IL)*COSX-A(IM)*SINX 1796 A(IM)=A(IL)*SINX+A(IM)*COSX 1797 A(IL)=X 1798 115 IF(MV-1) 120,125,120 1799 120 ILR=ILQ+I 1800 IMR=IMQ+I 1801 X=R(ILR)*COSX-R(IMR)*SINX 1802 R(IMR)=R(ILR)*SINX+R(IMR)*COSX 1803 R(ILR)=X 1804 125 CONTINUE 1805 X=2.0D+00*A(LM)*SINCS 1806 Y=A(LL)*COSX2+A(MM)*SINX2-X 1807 X=A(LL)*SINX2+A(MM)*COSX2+X 1808 A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2) 1809 A(LL)=Y 1810 A(MM)=X 1811C 1812C TESTS FOR COMPLETION 1813C 1814C TEST FOR M = LAST COLUMN 1815C 1816 130 IF(M-N) 135,140,135 1817 135 M=M+1 1818 GO TO 60 1819C 1820C TEST FOR L = SECOND FROM LAST COLUMN 1821C 1822 140 IF(L-(N-1)) 145,150,145 1823 145 L=L+1 1824 GO TO 55 1825 150 IF(IND-1) 160,155,160 1826 155 IND=0 1827 GO TO 50 1828C 1829C COMPARE THRESHOLD WITH FINAL NORM 1830C 1831 160 IF(THR-ANRMX) 165,165,45 1832C 1833C SORT EIGENVALUES AND EIGENVECTORS 1834C 1835 165 IQ=-N 1836 IF(MFKR.EQ.0)GO TO 186 1837 166 CONTINUE 1838 DO 185 I=1,N 1839 IQ=IQ+N 1840 LL=I+(I*I-I)/2 1841 JQ=N*(I-2) 1842 DO 185 J=I,N 1843 JQ=JQ+N 1844 MM=J+(J*J-J)/2 1845 IF(A(MM)-A(LL)) 170,185,185 1846 170 X=A(LL) 1847 A(LL)=A(MM) 1848 A(MM)=X 1849 IF(MV-1) 175,185,175 1850 175 DO 180 K=1,N 1851 ILR=IQ+K 1852 IMR=JQ+K 1853 X=R(ILR) 1854 R(ILR)=R(IMR) 1855 180 R(IMR)=X 1856 185 CONTINUE 1857186 CONTINUE 1858 RETURN 1859 END 1860 1861 REAL*8 FUNCTION FINDMN(VECTOR,NDIM) 1862C 1863C FIND SMALLEST ELEMENT OF DOUBLE PRECISION VECTOR VECTOR 1864C 1865 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1866 DIMENSION VECTOR(1) 1867C 1868 XMIN=VECTOR(1) 1869 DO 100 I=2,NDIM 1870 IF(VECTOR(I).LT.XMIN) XMIN=VECTOR(I) 1871 100 CONTINUE 1872 FINDMN=XMIN 1873C 1874 RETURN 1875 END 1876 SUBROUTINE FNDMN2(VEC,NDIM,NVAL,NELMNT,IPLACE,VECORD,NELPVL, 1877 & IPRT) 1878C 1879C FIND NVAL LOWEST ELEMENTS IN VEC . 1880C IF THE SAME VALUE OCCURS SEVERAL TIMES IT IS INCLUDED SEVERAL TIMES 1881C THE NUMBER OF OCCURENCIES OF THE NVAL LOWEST VALUES ARE RETURNED 1882C AS NELMNT , AND THEIR VALUES ARE RETURNED IN VECORD ,AND THEIR 1883C ORIGINAL PLACE IN IPLACE 1884C 1885 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1886 DIMENSION VEC(1 ),IPLACE(*),VECORD(*) 1887 DIMENSION NELPVL(1 ) 1888C 1889 THRES = 1.0D-8 1890 CALL ISETVC(IPLACE,0,NVAL) 1891 CALL ISETVC(NELPVL,0,NVAL) 1892C 1893 NELMNT = NVAL 1894 IELMNT = 0 1895 IVAL = 0 1896C. LARGEST ELEMENT TO START WITH 1897 XMAX = FNDMNX(VEC,NDIM,2) 1898C 1899C FIND NEXT LOWEST ELEMENT 19001000 CONTINUE 1901C? WRITE(6,*) ' START OF LOOP 1000 ' 1902C? WRITE(6,*) ' IVAL IELMNT ',IVAL,IELMNT 1903 1904C 1905 XMIN = XMAX 1906 DO 100 I = 1, NDIM 1907 1908 IF(VEC(I) .LE. XMIN ) THEN 1909C.. C HECK TO ENSURE THAT I HAS NOT BEEN USED YET 1910 INEW = 1 1911 DO 90 JELMNT = 1, IELMNT 1912 IF(I .EQ. IPLACE(JELMNT)) INEW = 0 1913 90 CONTINUE 1914C 1915 IF( INEW .EQ. 1 ) THEN 1916 XMIN = VEC(I) 1917 IMIN = I 1918 END IF 1919 END IF 1920C 1921C WRITE(6,*) ' END OF 100 I XMIN IMIN INEW ' 1922C WRITE(6,*) I,XMIN,IMIN,INEW 1923C 1924 100 CONTINUE 1925C? WRITE(6,*) ' XMIN AND IMIN ', XMIN,IMIN 1926C 1927C 1928 1929 IF(IELMNT .GT. 0 ) THEN 1930C NEW VALUE ? 1931COLD IF(XMIN . EQ. VECORD(IELMNT) ) THEN 1932 IF( ABS( XMIN-VECORD(IELMNT) ) .LT. THRES ) THEN 1933 NELMNT = NELMNT + 1 1934 IPLACE(NELMNT) = 0 1935 IELMNT = IELMNT + 1 1936 VECORD(IELMNT) = XMIN 1937 IPLACE(IELMNT) = IMIN 1938 ELSE 1939 IVAL = IVAL + 1 1940 IF( IVAL .LE. NVAL ) THEN 1941 IELMNT = IELMNT + 1 1942 VECORD(IELMNT) = XMIN 1943 IPLACE(IELMNT) = IMIN 1944 END IF 1945 END IF 1946 ELSE 1947 IVAL = 1 1948 IELMNT = 1 1949 VECORD(1) = XMIN 1950 IPLACE(1) = IMIN 1951 END IF 1952C 1953 NELPVL(IVAL) = NELPVL(IVAL) + 1 1954 NELMNT = MIN(NELMNT,NDIM) 1955 IF( IVAL .LE. NVAL .AND.IELMNT .LT. NDIM) GOTO 1000 1956C 1957C 1958 IF( IPRT .NE. 0 ) THEN 1959 WRITE(6,*) ' From FNDMN2 : ' 1960 WRITE(6,*) ' Lowest values ' 1961 CALL WRTMAT(VECORD,1,NELMNT,1,NELMNT) 1962C WRITE(6,*) ' places of lowest elements ' 1963C CALL IWRTMA(IPLACE,1,NELMNT,1,NELMNT) 1964 WRITE(6,*) ' Number of elements per value ' 1965 CALL IWRTMA(NELPVL,1,NVAL,1,NVAL) 1966 END IF 1967C 1968 RETURN 1969 END 1970 REAL*8 FUNCTION FNDMNX(VECTOR,NDIM,MINMAX) 1971C 1972C FIND SMALLEST(MINMAX=1) OR LARGEST(MINMAX=2) 1973C ABSOLUTE VALUE OF ELEMENTS IN VECTOR 1974C 1975 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 1976 DIMENSION VECTOR(1) 1977C 1978 IF(MINMAX.EQ.1) THEN 1979 RESULT=ABS(VECTOR(1)) 1980 DO I=2,NDIM 1981 RESULT=MIN(RESULT,ABS(VECTOR(I))) 1982 END DO 1983 END IF 1984C 1985 IF(MINMAX.EQ.2) THEN 1986 RESULT=ABS(VECTOR(1)) 1987 DO I=2,NDIM 1988 RESULT=MAX(RESULT,ABS(VECTOR(I))) 1989 END DO 1990 END IF 1991C 1992 IF(MINMAX.EQ.-1) THEN 1993 RESULT=VECTOR(1) 1994 DO I=2,NDIM 1995 RESULT=MIN(RESULT,VECTOR(I)) 1996 END DO 1997 END IF 1998C 1999 IF(MINMAX.EQ.-2) THEN 2000 RESULT=VECTOR(1) 2001 DO I=2,NDIM 2002 RESULT=MAX(RESULT,VECTOR(I)) 2003 END DO 2004 END IF 2005 2006 FNDMNX=RESULT 2007 RETURN 2008 END 2009 SUBROUTINE SGATVEC(VECO,VECI,INDEX,NDIM) 2010C 2011C GATHER VECTOR with sign encoded: 2012C VECO(I) = SIGN(INDEX(I))VECI(ABS(INDEX(I)) 2013C 2014 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2015 DIMENSION VECI(1),VECO(1 ),INDEX(1 ) 2016* 2017C 2018 DO I = 1, NDIM 2019 IF(INDEX(I).GT.0) THEN 2020 VECO(I) = VECI(INDEX(I)) 2021 ELSE 2022 VECO(I) = -VECI(-INDEX(I)) 2023 END IF 2024 END DO 2025C 2026 RETURN 2027 END 2028 SUBROUTINE GATVEC(VECO,VECI,INDEX,NDIM) 2029C 2030C GATHER VECTOR : 2031C VECO(I) = VECI(INDEX(I)) 2032C 2033 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2034 DIMENSION VECI(1),VECO(1 ),INDEX(1 ) 2035C 2036 DO 100 I = 1, NDIM 2037 100 VECO(I) = VECI(INDEX(I)) 2038C 2039 RETURN 2040 END 2041 SUBROUTINE SCAVEC(VECO,VECI,INDEX,NDIM) 2042C 2043C SCATTER VECTOR 2044C VECO(INDEX(I)) = VECI(I) 2045C 2046 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2047 DIMENSION VECI(1 ),VECO(1),INDEX(1 ) 2048C 2049 DO 100 I = 1, NDIM 2050 100 VECO(INDEX(I)) = VECI(I) 2051C 2052 RETURN 2053 END 2054 SUBROUTINE GPRCTV(DIAG,VECIN,VECUT,NVAR,NPRDIM,IPNTR, 2055 & PEIGVL,PEIGVC,SHIFT,WORK,XH0PSX ) 2056* 2057* Calculate inverted general preconditioner matrix times vector 2058* 2059* Vecut= (H0 + shift )-1 Vecin 2060* 2061* and XH0PSX = X(T) (H0 + shift ) X 2062* 2063* Where H0 consists of a diagonal Diag 2064* and a block matrix of dimension NPRDIM. 2065* 2066* Note : The diagonal elements in DIAG corresponding to 2067* elements in the subspace are neglected, 2068* i.e. their elements can have arbitrary value 2069* without affecting the results 2070* 2071* The block matrix is defined by 2072* ============================== 2073* 2074* NPRDIM : Size of block matrix 2075* IPNTR(I) : Scatter array, gives adress of subblock element 2076* I in full matrix 2077* PEIGVL : Eigenvalues of subblock mateix 2078* PEIGVC : Eigenvectors of subblock matrix 2079* 2080* Jeppe Olsen , Sept. 1989 2081* 2082* Input 2083*======= 2084* DIAG : Diagonal of matrix 2085* VECIN : Input vector 2086* NVAR : Dimension of full matrix 2087* NPRDIM,PEIGVL,PEIGVC : See above 2088* SHIFT : constant ADDED to diagonal 2089* WORK : Scratch array , at least 2*NPRDIM 2090* 2091* Externals: GATVEC,DIAVC2,SCAVEC,SBINTV,WRTMAT 2092* ========== 2093* 2094* Output 2095*======== 2096* VECUT : Output vector (you guessed ?? ), can occupy same space 2097* as VECIN or DIAG 2098* XH0PSX = X(T)(H0+SHIFT)**(-1)X 2099 2100 2101* 2102 IMPLICIT DOUBLE PRECISION ( A-H,O-Z) 2103 DIMENSION DIAG(*),VECIN(*),VECUT(*) 2104 DIMENSION IPNTR(*),PEIGVL(*),PEIGVC(*) 2105 DIMENSION WORK(*) 2106* 2107 IF(NPRDIM.NE.0) THEN 2108 CALL GATVEC(WORK(1),VECIN,IPNTR,NPRDIM) 2109* X(T)(DIAG+SHIFT)X in subspace, for later subtraction 2110 CALL GATVEC(WORK(1+NPRDIM),DIAG,IPNTR,NPRDIM) 2111 CALL DIAVC3(WORK(1+NPRDIM),WORK(1), 2112 & WORK(1+NPRDIM),SHIFT,NPRDIM,X1) 2113 ELSE 2114 X1 = 0.0D0 2115 END IF 2116* 2117 CALL DIAVC3(VECUT,VECIN,DIAG,SHIFT,NVAR,X2) 2118* 2119 IF(NPRDIM .NE. 0 ) THEN 2120 CALL SCAVEC(VECUT,WORK(1),IPNTR,NPRDIM) 2121 CALL SBINTV(NPRDIM,PEIGVC,PEIGVL,SHIFT, 2122 & IPNTR,VECUT,VECUT,WORK(1),WORK(1+NPRDIM),X3) 2123 ELSE 2124 X3 = 0.0D0 2125 END IF 2126 XH0PSX = X2 - X1 + X3 2127C? write(6,*) ' XH0PSX x1 x2 x3 ', XH0PSX,X1,X2,X3 2128 2129 2130* 2131 NTEST = 0 2132 IF(NTEST.GT. 0 ) THEN 2133 WRITE(6,*) ' Output vector from GPRCTV ' 2134 WRITE(6,*) ' ========================= ' 2135 CALL WRTMAT(VECUT,1,NVAR,1,NVAR) 2136 END IF 2137* 2138 RETURN 2139 END 2140 SUBROUTINE H0LNSL(PHP,PHQ,QHQ,NP1DM,NP2DM,NQDM, 2141 & X,RHS,S,SCR,NTESTG) 2142* 2143* Matrix H0 of the form 2144* 2145* 2146* P1 P2 Q 2147* *************************** 2148* * * * * 2149* P1 * Ex * Ex * Ex * Ex : exact H matrix 2150* *************************** is used in this block 2151* P2 * * * * 2152* * Ex * Ex * Diag * Diag : Diagonal 2153* ************ * appriximation used 2154* * * * * 2155* * * * * 2156* * Ex * Diag * * 2157* Q * * * * 2158* * * * * 2159* * * * * 2160* * * * * 2161* *************************** 2162* 2163* Solve the set of equations 2164* 2165* ( H0+S ) X = RHS 2166 2167* 2168* ========================= 2169* Jeppe Olsen , May 1 1990 2170* ========================= 2171* 2172* Modified to allow solution by conjugate gradient, March 1993 2173* ===== 2174* Input 2175* ===== 2176* PHP : The matrix in the P1+P2 space, given in lower 2177* Triangular form 2178* PHQ : PHQ block of matrix 2179* QHQ : Diagonal approximation in Q-Q space 2180* NP1DM : Dimension of P1 space 2181* NP2DM : Dimension of P2 space 2182* NQDM : Dimension of Q space 2183* RHS : Right hand side of equations 2184* 2185* ====== 2186* Output 2187* ====== 2188* X : solution to linear equations 2189* 2190 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2191 LOGICAL CONVER 2192* Input 2193 DIMENSION PHP(*),PHQ(*),QHQ(*),RHS(*) 2194* Output 2195 DIMENSION X(*) 2196* Scratch 2197 DIMENSION SCR(*), ERROR(20+1) 2198*.SCR Should atleast be dimensioned 2 *(NP1DM+NP2DM)** 2 + 2 NPQDM 2199 DOUBLE PRECISION INPROD 2200 COMMON/SHFT/SHIFT 2201* 2202 EXTERNAL HPQTVM 2203*. 2204* The Q-space can be partitioned into the P -space 2205* to give the effective linear equation 2206* 2207* (PHP+S - PHQ (QHQ+S)**-1 QHP ) XP = RHSP - HPQ(QHQ+S)-1 RHSQ 2208* 2209* This leads to a simple iterative scheme 2210* 2211 CALL LUCIAQENTER('H0LNS') 2212 NTESTL = 00 2213 NTEST = MAX(NTESTL,NTESTG) 2214 IF(NTEST .GE. 5 ) THEN 2215 WRITE(6,*) ' =============== ' 2216 WRITE(6,*) ' H0LNSL speaking ' 2217 WRITE(6,*) ' =============== ' 2218 END IF 2219* 2220 NPDM = NP1DM + NP2DM 2221 NPQDM = NPDM + NQDM 2222 IROUTE = 2 2223* 2224 IF( IROUTE.EQ.1. OR. IROUTE. EQ.3 ) THEN 2225*. Solve by partitioning theory 2226*. A bit of memory 2227* 2228 KLFREE = 1 2229*. Space for two local P-P matrix 2230 KLPP1 = KLFREE 2231 KLFREE = KLFREE + NPDM ** 2 2232* 2233 2234 KLPP2 = KLFREE 2235 KLFREE = KLFREE + NPDM ** 2 2236*. Two vectors in space 2237 KLV1 = KLFREE 2238 KLFREE = KLFREE + NPDM + NQDM 2239 KLV2 = KLFREE 2240 KLFREE = KLFREE + NPDM + NQDM 2241* ========================= 2242* RHSP - HPQ(QHQ+S)-1 RHSQ 2243* ========================= 2244* DIAVC3(VECOUT,VECIN,DIAG,SHIFT,NDIM,VDSV) 2245 CALL DIAVC3(SCR(KLV1),RHS(1+NPDM),QHQ,S,NQDM,XDUMMY) 2246 CALL MATML4(SCR(KLV2),PHQ,SCR(KLV1),NP1DM,1,NP1DM,NQDM,NQDM,1,0) 2247 CALL VECSUM(SCR(KLV1),RHS,SCR(KLV2),1.0D0,-1.0D0,NP1DM) 2248 CALL COPVEC(RHS(1+NP1DM),SCR(KLV1+NP1DM),NP2DM) 2249* =============================== 2250* (PHP+S - PHQ (QHQ+S)**-1 QHP ) 2251* =============================== 2252C XDIXT2(XDX,X,DIA,NXRDM,NXCDM,SHIFT,SCR) 2253 CALL XDIXT2(SCR(KLPP1),PHQ,QHQ,NP1DM,NQDM,S,SCR(KLV2)) 2254C TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 2255 CALL SETVEC(SCR(KLPP2),0.0D0,NPDM*(NPDM+1)/2) 2256 CALL TRIPAK(SCR(KLPP1),SCR(KLPP2),1,NP1DM,NP1DM) 2257 CALL VECSUM(SCR(KLPP1),SCR(KLPP2),PHP,-1.0D0,1.0D0, 2258 & NPDM*(NPDM+1)/2) 2259C ADDDIA(A,FACTOR,NDIM,IPACK) 2260 CALL ADDDIA(SCR(KLPP1),S,NPDM,1) 2261*. Pack to full matrix 2262 CALL TRIPAK(SCR(KLPP2),SCR(KLPP1),2,NPDM,NPDM) 2263 IF(NTEST.GE.5) THEN 2264 WRITE(6,*) ' Partitioned matrix ' 2265 CALL WRTMAT(SCR(KLPP2),NPDM,NPDM,NPDM,NPDM) 2266 END IF 2267*.Solve p equations by inverting and multiplying 2268 CALL INVMAT(SCR(KLPP2),SCR(KLPP1),NPDM,NPDM,ISING) 2269C MATVCB(MATRIX,VECIN,VECOUT,MATDIM,NDIM,ITRNSP) 2270 CALL MATVCB(SCR(KLPP2),SCR(KLV1),X,NPDM,NPDM,0) 2271*. q part of solution 2272* ================================== 2273* XQ = (QHQ+SHIFT)**-1 (RHS Q - QHP XP) 2274* ================================== 2275 2276 CALL MATML4(SCR(KLV1),PHQ,X, 2277 & NQDM,1,NP1DM,NQDM,NP1DM,1,1) 2278 CALL VECSUM(SCR(KLV2),RHS(NPDM+1),SCR(KLV1),1.0D0, 2279 & -1.0D0,NQDM) 2280* 2281C DIAVC3(VECOUT,VECIN,DIAG,SHIFT,NDIM,VDSV) 2282 CALL DIAVC3(X(NPDM+1),SCR(KLV2),QHQ, 2283 & S,NQDM,XDUMMY) 2284* 2285 IF(NTEST.GE.2) THEN 2286 WRITE(6,*) ' Solution to linear equations ' 2287 CALL WRTMAT(X,1,NPQDM,1,NPQDM) 2288 END IF 2289 END IF 2290* 2291 IF (IROUTE. EQ. 2 .OR. IROUTE .EQ. 3 ) THEN 2292*. Use preconditioned conjugate gradient 2293 LU1 = 34 2294 LU2 = 35 2295 LU3 = 36 2296 LUDIA = 37 2297* 2298 KLV1 = 1 2299 KLFREE = KLV1 + NPQDM 2300 KLV2 = KLFREE 2301 KLFREE = KLFREE + NPQDM 2302*. Diagonal 2303 CALL XTRCDI(PHP,SCR(KLV1),NPDM ,1) 2304 CALL COPVEC(QHQ,SCR(KLV1+NPDM),NQDM) 2305 CALL REWINE(LUDIA,-1) 2306 CALL TODSC(SCR(KLV1),NPQDM,-1,LUDIA) 2307*. Initial Guess 2308 CALL REWINE(LU1,-1) 2309 CALL SETVEC(SCR(KLV1),0.0D0,NPQDM) 2310 CALL TODSC(SCR(KLV1),NPQDM,-1,LU1) 2311*. Right hand side 2312 CALL REWINE(LU2,-1) 2313 CALL TODSC(RHS,NPQDM,-1,LU2) 2314* 2315 MAXIT = 20 2316 CONVER = .FALSE. 2317 TEST = 1.0D-9 * SQRT(INPROD(RHS,RHS,NPQDM)) 2318 SHIFT = S 2319 ILNPRT = MAX(NTEST-10,0) 2320 CALL MINGCG(HPQTVM,LU1,LU2,LU3,LUDIA,SCR(KLV1),SCR(KLV2), 2321 & MAXIT,CONVER,TEST,S,ERROR,NPQDM,0,ILNPRT) 2322 CALL REWINE(LU1,-1) 2323 CALL FRMDSC(SCR(KLV1),NPQDM,-1,LU1,IMZERO,IAMPACK) 2324 CALL COPVEC(SCR(KLV1),X,NPQDM) 2325* 2326 IF(NTEST.GE.50) THEN 2327 WRITE(6,*) ' Solution to linear equations ' 2328 CALL WRTMAT(X,1,NPQDM,1,NPQDM) 2329 END IF 2330* 2331 END IF 2332* 2333 CALL LUCIAQEXIT('H0LNS') 2334 RETURN 2335 END 2336 SUBROUTINE H0M1TV(DIAG,VECIN,VECUT,NVAR,NPQDM,IPNTR, 2337 & H0,SHIFT,WORK,XH0PSX, 2338 & NP1,NP2,NQ,NTESTG) 2339* 2340* Calculate inverted general preconditioner matrix times vector 2341* 2342* Vecut= (H0 + shift )-1 Vecin 2343* 2344* and XH0PSX = X(T) (H0 + shift )** - 1 X 2345* 2346* Where H0 consists of a diagonal Diag 2347* and a block matrix of the form 2348* 2349* P1 P2 Q 2350* *************************** 2351* * * * * 2352* P1 * Ex * Ex * Ex * Ex : exact H matrix 2353* *************************** is used in this block 2354* P2 * * * * 2355* * Ex * Ex * Diag * Diag : Diagonal 2356* ************ * appriximation used 2357* * * * * 2358* * * * * 2359* * Ex * Diag * * 2360* Q * * * * 2361* * * * * 2362* * * * * 2363* 2364* Note : The diagonal elements in DIAG corresponding to 2365* elements in the subspace are neglected, 2366* i.e. their elements can have arbitrary value 2367* without affecting the results 2368* 2369* The block matrix is defined by 2370* ============================== 2371* NPQDM : Total dimension of PQ subspace 2372* NP1,NP2,NQ : Dimensions of the three subspaces 2373* IPNTR(I) : Scatter array, gives adress of subblock element 2374* I in full matrix 2375* IPNTR gives first all elements in P1, 2376* the all elements in P2,an finally all elements in Q 2377* H0 : contains PHP,PHQ and QHQ in this order 2378* 2379* Jeppe Olsen , May 1990 2380 2381* 2382* 2383* ===== 2384* Input 2385* ===== 2386* DIAG : Diagonal of matrix 2387* VECIN : Input vector 2388* NVAR : Dimension of full matrix 2389* NPQDM,H0,NP1,NP2,NQ,IPNTR : Defines PQ subspace, see above 2390* SHIFT : constant ADDED to diagonal 2391* WORK : Scratch array , at least 2*(NP1DM+NP2DM) ** 2 + 4 NPQDM 2392* 2393* ========== 2394* Externals: GATVEC,DIAVC2,SCAVEC,SBINTV,WRTMAT 2395* ========== 2396* 2397* ====== 2398* Output 2399* ====== 2400* VECUT : Output vector (you guessed ?? ), can occupy same space 2401* as VECIN or DIAG 2402* XH0PSX = X(T)(H0+SHIFT)**(-1)X 2403* 2404 IMPLICIT DOUBLE PRECISION ( A-H,O-Z) 2405#include "errquit.fh" 2406#include "mafdecls.fh" 2407#include "global.fh" 2408 REAL * 8 INPROD 2409* 2410CNW DIMENSION DIAG(*),VECIN(*),VECUT(*) 2411 integer diag, vecin, vecut 2412 DIMENSION IPNTR(*),H0(*) 2413 DIMENSION WORK(*) 2414* 2415 CALL LUCIAQENTER('H0M1T') 2416 NTESTL = 1 2417 NTEST = MAX(NTESTG,NTESTL) 2418* 2419 KLFREE = 1 2420 KLV1 = KLFREE 2421 KLFREE = KLV1 + NPQDM 2422* 2423 KLV2 = KLFREE 2424 KLFREE = KLV2 + NPQDM 2425* 2426 KLGA = KLFREE 2427 KLFREE = KLGA + NPQDM 2428* 2429 KLSCR = KLFREE 2430* 2431 DO I = 0, NPQDM-1 2432 WORK(KLGA) = 1 2433 ENDDO 2434 IF(NPQDM.NE.0) THEN 2435CNW CALL GATVEC(dbl_mb(KLV1),VECIN,IPNTR,NPQDM) 2436 call ga_gather(VECIN,WORK(KLV1),IPNTR,WORK(KLGA),NPQDM) 2437* X(T)(DIAG+SHIFT)-1 X in subspace, for later subtraction 2438CNW CALL GATVEC(dbl_mb(KLV2),DIAG,IPNTR,NPQDM) 2439 call ga_gather(DIAG,WORK(KLV2),IPNTR,WORK(KLGA),NPQDM) 2440 CALL DIAVC3(WORK(KLV2),WORK(KLV1), 2441 & WORK(KLV2),SHIFT,NPQDM,X1) 2442 ELSE 2443 X1 = 0.0D0 2444 END IF 2445* 2446 CALL DIAVC3G(VECUT,VECIN,DIAG,SHIFT,NVAR,X2) 2447* 2448 IF(NPQDM .NE. 0 ) THEN 2449C H0LNSL(PHP,PHQ,QHQ,NP1DM,NP2DM,NQDM, 2450C & X,RHS,S,SCR) 2451 KLPHP = 1 2452 KLPHQ = KLPHP + (NP1+NP2) *(NP1+NP2+1)/2 2453 KLQHQ = KLPHQ + NP1 * NQ 2454C? write(6,*) ' KLPHP KLPHQ KLQHQ ',KLPHP,KLPHQ,KLQHQ 2455* 2456 CALL H0LNSL(H0(KLPHP),H0(KLPHQ),H0(KLQHQ),NP1,NP2,NQ, 2457 & WORK(KLV2),WORK(KLV1),SHIFT,WORK(KLSCR), 2458 & NTEST ) 2459 X3 = INPROD(WORK(KLV1),WORK(KLV2),NPQDM) 2460CNW CALL SCAVEC(VECUT,dbl_mb(KLV2),IPNTR,NPQDM) 2461 call ga_scatter(VECUT,WORK(KLV2),IPNTR,WORK(KLGA),NPQDM) 2462 call ga_sync() 2463 ELSE 2464 X3 = 0.0D0 2465 END IF 2466 XH0PSX = X2 - X1 + X3 2467C? write(6,*) ' XH0PSX x1 x2 x3 ', XH0PSX,X1,X2,X3 2468 2469 2470* 2471 IF(NTEST.GT. 100 ) THEN 2472 WRITE(6,*) ' Output vector from H0M1TV ' 2473 WRITE(6,*) ' ========================= ' 2474CNW CALL WRTMAT(VECUT,1,NVAR,1,NVAR) 2475 call ga_print(VECUT) 2476 END IF 2477 CALL LUCIAQEXIT('H0M1T') 2478* 2479 RETURN 2480 END 2481* 2482 SUBROUTINE H0TV(VECIN,VECUT,DIAG,NVAR,NPQDM,IPNTR,H0, 2483 & WORK,NP1,NP2,NQ) 2484* 2485* Calculate H0 times vector , where H0 is the diagonal 2486* approximation plus a P1P2Q preconditioner in a subspace 2487* 2488* 2489 DIMENSION DIAG(*),VECIN(*),VECUT(*) 2490 DIMENSION IPNTR(*),H0(*) 2491 DIMENSION WORK(*) 2492* 2493 KLFREE = 1 2494 KLV1 = KLFREE 2495 KLFREE = KLV1 + NPQDM 2496* 2497 KLV2 = KLFREE 2498 KLFREE = KLV2 + NPQDM 2499* 2500 KLSCR = KLFREE 2501* 2502* Diagonal Times vector 2503 CALL VVTOV(VECIN,DIAG,VECUT,NVAR) 2504* 2505 IF(NPQDM.NE.0) THEN 2506*.Extract elements belonging to subspace 2507 CALL GATVEC(WORK(KLV1),VECIN,IPNTR,NPQDM) 2508 KLPHP = 1 2509 KLPHQ = KLPHP + (NP1+NP2) *(NP1+NP2+1)/2 2510 KLQHQ = KLPHQ + NP1 * NQ 2511C? write(6,*) ' KLPHP KLPHQ KLQHQ ',KLPHP,KLPHQ,KLQHQ 2512C HPQTV(NP1,NP2,NQ,PHP,PHQ,QHQ,VECIN,VECUT,WORK) 2513 CALL HPQTV(NP1,NP2,NQ,H0(KLPHP),H0(KLPHQ),H0(KLQHQ), 2514 & WORK(KLV1),WORK(KLV2) ) 2515 CALL SCAVEC(VECUT,WORK(KLV2),IPNTR,NPQDM) 2516 END IF 2517* 2518 NTEST = 0 2519 IF(NTEST.GT. 0 ) THEN 2520 WRITE(6,*) ' Output vector from H0TV ' 2521 WRITE(6,*) ' ========================= ' 2522 CALL WRTMAT(VECUT,1,NVAR,1,NVAR) 2523 END IF 2524* 2525 RETURN 2526 END 2527 INTEGER FUNCTION IBION(M,N) 2528C 2529C BIONOMIAL COEFFICIENT (M / N ) = IFAC(M)/(IFAC(M-N)*IFAC(N)) 2530C 2531* 2532 INCLUDE 'implicit.inc' 2533* 2534 IWAY = 2 2535 IF(IWAY.EQ.1) THEN 2536* 2537* Good old route based on integers 2538* 2539 IB = 1 2540 IF(M-N.GE.N) THEN 2541 DO K = (M-N+1), M 2542 IB = IB * K 2543 END DO 2544 IB = IB/IFAC(N) 2545 ELSE 2546 DO K = N+1,M 2547 IB = IB * K 2548 END DO 2549 IB = IB/IFAC(M-N) 2550 END IF 2551 IBION = IB 2552* 2553 ELSE IF (IWAY.EQ.2) THEN 2554* 2555* Use reals 2556* 2557 XIB = 1.0D0 2558 IF(M-N.GE.N) THEN 2559 DO K = (M-N+1), M 2560 XK = K 2561 XIB = XIB * XK 2562 END DO 2563 FACN = IFAC(N) 2564 XIB = XIB/FACN 2565 ELSE 2566 DO K = N+1,M 2567 XK = K 2568 XIB = XIB * XK 2569 END DO 2570 FACMN = IFAC(M-N) 2571 XIB = XIB/FACMN 2572 END IF 2573 IBION = NINT(XIB) 2574 END IF 2575* 2576 RETURN 2577 END 2578 SUBROUTINE ICOPVE(IFROM,ITO,NDIM) 2579C 2580C COPY INTEGER ARRAY 2581C 2582 DIMENSION IFROM(1 ),ITO(1 ) 2583C 2584 DO 100 I = 1,NDIM 2585 ITO(I) = IFROM(I) 2586 100 CONTINUE 2587C 2588 RETURN 2589 END 2590 FUNCTION IFAC(N) 2591C 2592C N ! 2593C 2594 IF( N .LT. 0 ) THEN 2595 IFAC = 0 2596 WRITE(6,*) ' WARNING FACULTY OF NEGATIVE NUMBER SET TO ZERO ' 2597 ELSE 2598C 2599 IFACN = 1 2600 DO 100 K = 2,N 2601 IFACN = IFACN * K 2602 100 CONTINUE 2603 IFAC = IFACN 2604 END IF 2605C 2606 RETURN 2607 END 2608 SUBROUTINE IFRMDS(IARRAY,NDIM,MBLOCK,IFILE) 2609C 2610C TRANSFER INTEGER ARRAY FROM DISC FILE IFILE 2611C 2612C NBLOCK .LT. 0 INDICATES USE OF FASTIO 2613C 2614C If nblock .eq. 0 NBLOCK = NDIM 2615 IMPLICIT REAL*8(A-H,O-Z) 2616 DIMENSION IARRAY(1) 2617C 2618 ICRAY = 1 2619 NBLOCK = MBLOCK 2620 2621 IF( ICRAY.EQ.1.OR.NBLOCK .GE. 0 ) THEN 2622C DO NOT USE FASTIO 2623 IF(NBLOCK .LE. 0 ) NBLOCK = NDIM 2624 IREST=NDIM 2625 IBASE=0 2626 100 CONTINUE 2627 IF(IREST.GT.NBLOCK) THEN 2628 READ(IFILE) (IARRAY(IBASE+I),I=1,NBLOCK) 2629 IBASE=IBASE+NBLOCK 2630 IREST=IREST-NBLOCK 2631 ELSE 2632 READ(IFILE) (IARRAY(IBASE+I),I=1,IREST) 2633 IREST=0 2634 END IF 2635 IF( IREST .GT. 0 ) GOTO 100 2636 ELSE 2637C USE FAST IO 2638 CALL SQFILE(IFILE,2,IARRAY,NDIM) 2639 END IF 2640 RETURN 2641 END 2642 SUBROUTINE IFRMDSE(IARRAY,NDIM,MBLOCK,IFILE,IERR) 2643C 2644C TRANSFER INTEGER ARRAY FROM DISC FILE IFILE 2645C 2646C version with error-code 2647C 2648C NBLOCK .LT. 0 INDICATES USE OF FASTIO 2649C 2650C If nblock .eq. 0 NBLOCK = NDIM 2651 IMPLICIT REAL*8(A-H,O-Z) 2652 DIMENSION IARRAY(1) 2653C 2654 ICRAY = 1 2655 NBLOCK = MBLOCK 2656 IERR = 0 ! begin optimistic 2657 2658 IF( ICRAY.EQ.1.OR.NBLOCK .GE. 0 ) THEN 2659C DO NOT USE FASTIO 2660 IF(NBLOCK .LE. 0 ) NBLOCK = NDIM 2661 IREST=NDIM 2662 IBASE=0 2663 100 CONTINUE 2664 IF(IREST.GT.NBLOCK) THEN 2665 READ(IFILE,END=201,ERR=202) (IARRAY(IBASE+I),I=1,NBLOCK) 2666 IBASE=IBASE+NBLOCK 2667 IREST=IREST-NBLOCK 2668 ELSE 2669 READ(IFILE,END=201,ERR=202) (IARRAY(IBASE+I),I=1,IREST) 2670 IREST=0 2671 END IF 2672 IF( IREST .GT. 0 ) GOTO 100 2673 ELSE 2674C USE FAST IO 2675 CALL SQFILE(IFILE,2,IARRAY,NDIM) 2676 END IF 2677 RETURN 2678 201 IERR = 1 ! end of file reached 2679 RETURN 2680 202 IERR = 2 ! I/O-error 2681 RETURN 2682 END 2683 SUBROUTINE IIM1SU(IMAX) 2684C 2685C CREATE ARRAY IIM1AR(I)=I*(I-1)/2 2686C 2687 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2688 COMMON/IIM1CM/IIM1AR(5050 ) 2689C 2690 IIM1AR(1)=0 2691 IMAXM1=IMAX-1 2692 DO 100 I=1,IMAXM1 2693 IIM1AR(I+1)=IIM1AR(I)+I 2694 100 CONTINUE 2695C 2696 RETURN 2697 END 2698 2699 SUBROUTINE INPACK(A,SCR,NDIM,MATDIM) 2700C 2701C PACK LOWER HALF OF MATRIX TO ARRAY 2702C 2703 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2704 DIMENSION A(MATDIM,MATDIM),SCR(NDIM,NDIM) 2705C 2706 DO 100 I=1,NDIM 2707 DO 100 J=1,NDIM 2708 SCR(J,I)=A(J,I) 2709 100 CONTINUE 2710C 2711 IROW=0 2712 ICOL=1 2713C 2714 DO 200 I=1,NDIM 2715 DO 200 J=1,I 2716 IROW=IROW+1 2717 IF(IROW.GT.MATDIM) THEN 2718 ICOL=ICOL+1 2719 IROW=1 2720 END IF 2721 A(IROW,ICOL)=SCR(I,J) 2722 200 CONTINUE 2723 RETURN 2724 END 2725 2726 REAL*8 FUNCTION INPRDD(VEC1,VEC2,LU1,LU2,IREW,LBLK) 2727C 2728C DISC VERSION OF INPROD 2729C 2730C LBLK DEFINES STRUCTURE OF FILE 2731C 2732*. Last revision, Sept 2003 : FRMDSC => FRMDSC2 to simplify handling 2733* of vectors containing many zeo blocks 2734 IMPLICIT REAL*8(A-H,O-Z) 2735 REAL*8 INPROD 2736 DIMENSION VEC1(*),VEC2(*) 2737 LOGICAL DIFVEC 2738C 2739 X = 0.0D0 2740 IF( LU1 .NE. LU2 ) THEN 2741 DIFVEC = .TRUE. 2742 ELSE 2743 DIFVEC = .FALSE. 2744 END IF 2745C 2746 IF( IREW .NE. 0 ) THEN 2747 IF( LBLK .GE. 0 ) THEN 2748 REWIND LU1 2749 IF(DIFVEC) REWIND LU2 2750 ELSE 2751 CALL REWINE( LU1,LBLK) 2752 IF( DIFVEC ) CALL REWINE( LU2,LBLK) 2753 END IF 2754 END IF 2755C 2756C LOOP OVER BLOCKS OF VECTORS 2757C 2758 1000 CONTINUE 2759C 2760 IF( LBLK .GT. 0 ) THEN 2761 NBL1 = LBLK 2762 NBL2 = LBLK 2763 ELSE IF ( LBLK .EQ. 0 ) THEN 2764 READ(LU1) NBL1 2765 IF( DIFVEC) READ(LU2) NBL2 2766 ELSE IF ( LBLK .LT. 0 ) THEN 2767 CALL IFRMDS(NBL1,1,-1,LU1) 2768 IF( DIFVEC)CALL IFRMDS(NBL2,1,-1,LU2) 2769 END IF 2770C 2771 NO_ZEROING = 1 2772 IF(NBL1 .GE. 0 ) THEN 2773 IF(LBLK .GE.0 ) THEN 2774 KBLK = NBL1 2775 ELSE 2776 KBLK = -1 2777 END IF 2778 CALL FRMDSC2(VEC1,NBL1,KBLK,LU1,IMZERO1,IAMPACK,NO_ZEROING) 2779C FRMDSC2(ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED, 2780C & NO_ZEROING) 2781 IF( DIFVEC) THEN 2782 CALL FRMDSC2(VEC2,NBL1,KBLK,LU2,IMZERO2,IAMPACK, 2783 & NO_ZEROING) 2784 IF(NBL1 .GT. 0 .AND. IMZERO1.EQ.0.AND.IMZERO2.EQ.0) 2785 & X = X + INPROD(VEC1,VEC2,NBL1) 2786 ELSE 2787 IF(NBL1 .GT. 0 .AND. IMZERO1.EQ.0 ) 2788 & X = X + INPROD(VEC1,VEC1,NBL1) 2789 END IF 2790 END IF 2791 IF(NBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 2792C 2793 INPRDD = X 2794C 2795 RETURN 2796 END 2797 REAL*8 FUNCTION INPRDe(VEC1,VEC2,LU1,LU2,IREW) 2798C 2799C DISC VERSION OF INPROD 2800C 2801 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2802 REAL * 8 INPROD 2803 DIMENSION VEC1(*),VEC2(*) 2804 LOGICAL DIFVEC 2805C 2806 X = 0.0D0 2807 IF( LU1 .NE. LU2 ) THEN 2808 DIFVEC = .TRUE. 2809 ELSE 2810 DIFVEC = .FALSE. 2811 END IF 2812C 2813 IF( IREW .NE. 0 ) THEN 2814 CALL REWINO( LU1) 2815 IF( DIFVEC ) CALL REWINO( LU2) 2816 END IF 2817C 2818C LOOP OVER BLOCKS OF VECTORS 2819C 2820 1000 CONTINUE 2821C 2822 READ(LU1) NBL1 2823 IF( DIFVEC) READ(LU2) NBL2 2824 IF(NBL1 .GE. 0 ) THEN 2825 CALL FRMDSC(VEC1,NBL1,-1 ,LU1,IMZERO,IAMPACK) 2826 IF( DIFVEC) THEN 2827 CALL FRMDSC(VEC2,NBL1,-1 ,LU2,IMZERO,IAMPACK) 2828 IF(NBL1 .GT. 0 ) 2829 & X = X + INPROD(VEC1,VEC2,NBL1) 2830 ELSE 2831 IF(NBL1 .GT. 0 ) 2832 & X = X + INPROD(VEC1,VEC1,NBL1) 2833 END IF 2834 END IF 2835 IF(NBL1 .GE. 0 ) GOTO 1000 2836C 2837 INPRDD = X 2838 INPRDe = X 2839C 2840 RETURN 2841 END 2842 REAL*8 FUNCTION INPROD(A,B,NDIM) 2843C CALCULATE SCALAR PRODUCT BETWEEN TO VECTORS A,B 2844 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2845 DIMENSION A(2),B(2) 2846C 2847 INPROD=0.0D0 2848 DO 100 I=1,NDIM 2849 INPROD=INPROD+A(I)*B(I) 2850 100 CONTINUE 2851C 2852 RETURN 2853 END 2854 SUBROUTINE INVMAT(A,B,MATDIM,NDIM,ISING) 2855C FIND INVERSE OF MATRIX A 2856C INPUT : 2857C A : MATRIX TO BE INVERTED 2858C B : SCRATCH ARRAY 2859C MATDIM : PHYSICAL DIMENSION OF MATRICES 2860C NDIM : DIMENSION OF SUBMATRIX TO BE INVERTED 2861C 2862C OUTPUT : A : INVERSE MATRIX ( ORIGINAL MATRIX THUS DESTROYED ) 2863C WARNINGS ARE ISSUED IN CASE OF CONVERGENCE PROBLEMS ) 2864* 2865* ISING = 0 => No convergence problems 2866* = 1 => Convergence problems 2867C 2868 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 2869 DIMENSION A(MATDIM,MATDIM),B(MATDIM,MATDIM) 2870C 2871 ITEST=0 2872 IF(NDIM.EQ.0) THEN 2873 RETURN 2874 ELSE IF(NDIM.EQ.1)THEN 2875 IF(A(1,1) .NE. 0.0D0 ) THEN 2876 A(1,1) = 1.0D0/A(1,1) 2877 ELSE 2878 ITEST = 1 2879 END IF 2880 ELSE 2881 DETERM=0.0D0 2882 EPSIL=0.0D0 2883 CALL BNDINV(A,B,NDIM,DETERM,EPSIL,ITEST,MATDIM) 2884 END IF 2885C 2886 IF( ITEST .NE. 0 ) THEN 2887 WRITE (6,'(A,I3)') ' INVERSION PROBLEM NUMBER..',ITEST 2888 END IF 2889* 2890 IF(ITEST.NE.0) THEN 2891 ISING = 1 2892 ELSE 2893 ISING = 0 2894 END IF 2895* 2896 NTEST = 0 2897 IF ( NTEST .NE. 0 ) THEN 2898 WRITE(6,*) ' INVERTED MATRIX ' 2899 CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM) 2900 END IF 2901C 2902 RETURN 2903 END 2904 SUBROUTINE ISETVC(IVEC,IVALUE,NDIM) 2905C 2906 DIMENSION IVEC(NDIM) 2907C 2908 DO 100 I = 1, NDIM 2909 IVEC(I) = IVALUE 2910 100 CONTINUE 2911C 2912 RETURN 2913 END 2914 SUBROUTINE ISTVC2(IVEC,IBASE,IFACT,NDIM) 2915C 2916C IVEC(I) = IBASE + IFACT * I 2917C 2918 DIMENSION IVEC(1 ) 2919C 2920 DO 100 I = 1,NDIM 2921 IVEC(I) = IBASE + IFACT*I 2922 100 CONTINUE 2923C 2924 RETURN 2925 END 2926 SUBROUTINE ITODS(IA,NDIM,MBLOCK,IFIL) 2927C TRANSFER ARRAY INTEGER IA(LENGTH NDIM) TO DISCFIL IFIL IN 2928C RECORDS WITH LENGTH NBLOCK. 2929 IMPLICIT REAL*8(A-H,O-Z) 2930 DIMENSION IA(1) 2931 INTEGER START,STOP 2932* 2933 ICRAY = 1 2934 NBLOCK = MBLOCK 2935 IF( NBLOCK .GE.0.OR.ICRAY.EQ.1 ) THEN 2936C 2937 IF(NBLOCK .LE. 0 ) NBLOCK = NDIM 2938 STOP=0 2939 NBACK=NDIM 2940C LOOP OVER RECORDS 2941 100 CONTINUE 2942 IF(NBACK.LE.NBLOCK) THEN 2943 NTRANS=NBACK 2944 NLABEL=-NTRANS 2945 ELSE 2946 NTRANS=NBLOCK 2947 NLABEL=NTRANS 2948 END IF 2949 START=STOP+1 2950 STOP=START+NBLOCK-1 2951 NBACK=NBACK-NTRANS 2952 WRITE(IFIL) (IA(I),I=START,STOP),NLABEL 2953 IF(NBACK.NE.0) GOTO 100 2954 END IF 2955C 2956 IF(ICRAY.EQ.0.AND. NBLOCK .LT. 0 ) THEN 2957 CALL SQFILE(IFIL,1,IA,NDIM) 2958 END IF 2959C 2960 RETURN 2961 END 2962 SUBROUTINE IWRTMA10(IMAT,NROW,NCOL,MAXROW,MAXCOL) 2963* I10 format 2964 DIMENSION IMAT(MAXROW,MAXCOL) 2965C 2966 DO 100 I = 1, NROW 2967 WRITE(6,1110) (IMAT(I,J),J= 1,NCOL) 2968 100 CONTINUE 2969 1110 FORMAT(/,1X,8I10,/,(1X,8I10)) 2970C 2971 RETURN 2972 END 2973 SUBROUTINE IWRTMA3(IMAT,NROW,NCOL,MAXROW,MAXCOL) 2974 DIMENSION IMAT(MAXROW,MAXCOL) 2975C 2976 DO 100 I = 1, NROW 2977 WRITE(6,1110) I,(IMAT(I,J),J= 1,NCOL) 2978 100 CONTINUE 2979 1110 FORMAT(/"<",I3,">",1X,20(1X,I3),/,(6X,20(1X,I3))) 2980C 2981 RETURN 2982 END 2983 SUBROUTINE IWRTMA(IMAT,NROW,NCOL,MAXROW,MAXCOL) 2984 DIMENSION IMAT(MAXROW,MAXCOL) 2985C 2986 DO 100 I = 1, NROW 2987 WRITE(6,1110) I,(IMAT(I,J),J= 1,NCOL) 2988 100 CONTINUE 2989 1110 FORMAT(/"<",I3,">",1X,10I8,/,(6X,10I8)) 2990C 2991 RETURN 2992 END 2993 SUBROUTINE IWRTMA_T(IMAT,NROW,NCOL,MAXROW,MAXCOL) 2994 DIMENSION IMAT(MAXROW,MAXCOL) 2995C 2996 DO 100 I = 1, NCOL 2997 WRITE(6,1110) I,(IMAT(J,I),J= 1,NROW) 2998 100 CONTINUE 2999 1110 FORMAT(/"<",I3,">",1X,10I8,/,(1X,10I8)) 3000C 3001 RETURN 3002 END 3003 SUBROUTINE LRMTVC(NRANK,NVAR,A,AVEC,VECIN,VECOUT,IZERO) 3004* 3005C calculate the product of a low rank matrix and a vector 3006C the low rank matrix is defined as 3007C sum(i,j) avec(j)*a(j,i)*avec(i)t 3008C (avec: COLUMN vectors) 3009C ( IF IZERO .NE. 0 VECOUT IS ZEROED FIRST) 3010 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3011 REAL * 8 INPROD 3012 DIMENSION A(NRANK,NRANK), AVEC(NVAR,NRANK) 3013 DIMENSION VECIN(1 ),VECOUT(1 ) 3014* 3015 NTEST = 000 3016 IF(NTEST.GE.100) THEN 3017 WRITE(6,*) ' Info from LRMTVC ' 3018 WRITE(6,*) ' =================' 3019 WRITE(6,*) 3020 WRITE(6,*) ' Input vector ' 3021 CALL WRTMAT(VECIN,1,NVAR,1,NVAR) 3022 WRITE(6,*) 3023 WRITE(6,*) ' Input vectors defining subspace' 3024 CALL WRTMAT(AVEC,NRANK,NVAR,NRANK,NVAR) 3025 WRITE(6,*) 3026 WRITE(6,*) ' Subspace matrix ' 3027 CALL WRTMAT(A,NRANK,NRANK,NRANK,NRANK) 3028 END IF 3029* 3030 IF(IZERO.NE.0) CALL SETVEC(VECOUT(1),0.0D0,NVAR) 3031 DO 200 I = 1,NRANK 3032 AVECTV = INPROD(VECIN,AVEC(1,I),NVAR) 3033 DO 180 J = 1,NRANK 3034 FACTOR = A(J,I)*AVECTV 3035 CALL VECSUM ( VECOUT,VECOUT,AVEC(1,J) , 1.0D0,FACTOR,NVAR) 3036 180 CONTINUE 3037 200 CONTINUE 3038* 3039 IF (NTEST.NE.0) THEN 3040 WRITE(6,*) ' MATRIX TIMES VECTOR FOR LRMTVC' 3041 CALL WRTMAT(VECOUT,1,NVAR,1,NVAR) 3042 END IF 3043 3044 RETURN 3045 END 3046 SUBROUTINE LTXEBB(L,X,B,NDIM,IB) 3047C 3048C SOLVE L(TRANSPOSED ) X = B 3049C 3050 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3051 DOUBLE PRECISION L(IB+1,NDIM),X(*),B(*) 3052C 3053 CALL COPVEC(B(1),X(1),NDIM) 3054C 3055 DO 100 I = NDIM,1,-1 3056C 3057 IEFF = MIN(I,IB+1) 3058 RLII = L(IEFF,I) 3059 X(I) = X(I) / RLII 3060 XIM = -X(I) 3061C 3062 JMIN = MAX(1,I-IB) 3063 JMAX = I - 1 3064 NJ = JMAX - JMIN + 1 3065C 3066 CALL VECSUM(X(JMIN),X(JMIN),L(1,I),1.0D0,XIM,NJ) 3067C 3068 100 CONTINUE 3069C 3070 NTEST = 00 3071 IF ( NTEST .NE. 0 ) THEN 3072 WRITE(6,*) ' X AND B FROM LTBEBB ' 3073 CALL WRTMAT(X,1,NDIM,1,NDIM) 3074 CALL WRTMAT(B,1,NDIM,1,NDIM) 3075 END IF 3076C 3077 RETURN 3078 END 3079 SUBROUTINE LTXEBE(L,X,B,NDIM,IB,ILOFF) 3080C 3081C SOLVE L(TRANSPOSED ) X = B 3082C 3083C where L is a lower trinagular matrix stored in envelope fashion 3084C 3085C ILOFF(I) Adress in L of first element of row I 3086C IB(I) Column number of first row of I 3087C L : matrix stores rowwise in one dimensional array . 3088C 3089 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3090 DOUBLE PRECISION L(*),X(*),B(*) 3091 DIMENSION IB(*),ILOFF(*) 3092C 3093C 3094 DO 100 I = NDIM,1,-1 3095C 3096 JMIN = IB(I) 3097 NJ = I - JMIN 3098 IOFF = ILOFF(I) 3099 RLII = L(IOFF+NJ) 3100 X(I) = B(I) / RLII 3101 XIM = -X(I) 3102C 3103 CALL VECSUM(B(JMIN),B(JMIN),L(IOFF),1.0D0,XIM,NJ) 3104C 3105 100 CONTINUE 3106C 3107 NTEST = 0 3108 IF ( NTEST .NE. 0 ) THEN 3109 WRITE(6,*) ' X AND B FROM LTBEBB ' 3110 CALL WRTMAT(X,1,NDIM,1,NDIM) 3111 CALL WRTMAT(B,1,NDIM,1,NDIM) 3112 END IF 3113C 3114 RETURN 3115 END 3116 SUBROUTINE LXEBB(L,X,B,NDIM,IB) 3117C 3118C SOLVE L X = B 3119C 3120C WHERE L IS A LOWER TRIANGULAR MATRIX WITH BAND WIDTH IB, 3121C AND STORED AS DESCRIBED IN CHLFCB. 3122C 3123 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3124 DOUBLE PRECISION L(IB+1,NDIM),X(*),B(*) 3125 REAL * 8 INPROD 3126C 3127C X AND B CAN BE THE SAME VECTOR 3128C 3129 DO 100 I = 1, NDIM 3130C 3131 JTERM = MIN(IB,I-1) 3132 JSTRT = MAX ( 1, I - IB ) 3133C? WRITE(6,*) ' I JTERM JSTRT ',I,JTERM,JSTRT 3134C 3135 X(I) = 3136 & (B(I)-INPROD(L(1,I),X(JSTRT),JTERM) ) /L(JTERM+1,I) 3137C 3138 100 CONTINUE 3139C 3140 NTEST = 00 3141 IF( NTEST .NE. 0 ) THEN 3142 WRITE(6,*) ' X AND B VECTOR ' 3143 CALL WRTMAT(X,1,NDIM,1,NDIM) 3144 CALL WRTMAT(B,1,NDIM,1,NDIM) 3145 END IF 3146C 3147 RETURN 3148 END 3149 SUBROUTINE LXEBE(L,X,B,NDIM,IB,ILOFF) 3150C 3151C SOLVE L X = B 3152C 3153C where L is a lower trinagular matrix stored in envelope fashion 3154C 3155C ILOFF(I) Adress in L of first element of row I 3156C IB(I) Column number of first row of I 3157C L : matrix stored rowwise in one dimensional array . 3158C 3159 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3160 DOUBLE PRECISION L(*),X(*),B(*) 3161 DIMENSION IB(*),ILOFF(*) 3162 REAL * 8 INPROD 3163C 3164C X AND B CAN BE THE SAME VECTOR 3165C 3166C x(i) = (b(i)-sum(j) l(i,j)*x(j)) / l(j,j) 3167C 3168 NTEST = 0 3169 IF( NTEST .NE. 0 ) THEN 3170 WRITE(6,*) ' B VECTOR on input to LXEBE ' 3171 CALL WRTMAT(B,1,NDIM,1,NDIM) 3172 write(6,*) ' ib and iloff ' 3173 call iwrtma(ib,1,ndim,1,ndim) 3174 call iwrtma(iloff,1,ndim,1,ndim) 3175 END IF 3176C 3177 DO 100 I = 1, NDIM 3178 JTERM = I - IB(I) 3179 JSTRT = IB(I) 3180 IOFF = ILOFF(I) 3181 X(I) = 3182 & (B(I)-INPROD(L(IOFF),X(JSTRT),JTERM) ) /L(IOFF+JTERM) 3183 100 CONTINUE 3184C 3185 IF( NTEST .NE. 0 ) THEN 3186 WRITE(6,*) ' X AND B VECTOR on exit from LXEBE ' 3187 CALL WRTMAT(X,1,NDIM,1,NDIM) 3188 CALL WRTMAT(B,1,NDIM,1,NDIM) 3189 END IF 3190C 3191 RETURN 3192 END 3193 SUBROUTINE MATDIF(A,B,NMXDIM,MATDIM) 3194C 3195C A=A-B 3196C 3197 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3198 DIMENSION A(NMXDIM,2),B(NMXDIM,2) 3199C 3200 DO 100 J=1,MATDIM 3201 DO 100 I=1,MATDIM 3202 A(I,J)=A(I,J)-B(I,J) 3203 100 CONTINUE 3204 RETURN 3205 END 3206C 3207 SUBROUTINE MATML2(A,B,C,SCR,MATDIM,NDIM,ITRNSP) 3208C 3209C C=A*B.C AND A CAN OCCUPY SAME SPACE 3210C LENGTH OF SCR AT LEAST NDIM 3211C IF ITRANSP.NE.0 MATRIX A IS TRANSPOSED 3212C 3213 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3214 DIMENSION A(MATDIM,MATDIM),SCR(2) 3215 DIMENSION B(MATDIM,MATDIM),C(MATDIM,MATDIM) 3216C 3217 IF(ITRNSP.NE.0) CALL TRNSPO(A,MATDIM,NDIM) 3218C 3219 DO 300 I=1,NDIM 3220C 3221 DO 250 K =1,NDIM 3222 250 SCR(K)=A(I,K) 3223C 3224 DO 200 J=1,NDIM 3225 X=0.0D0 3226 DO 100 K=1,NDIM 3227 100 X=X+SCR(K)*B(K,J) 3228 A(I,J)=X 3229 200 CONTINUE 3230 300 CONTINUE 3231C 3232 RETURN 3233 END 3234 SUBROUTINE MATML3(A,B,C,MATDIM,NDIM,ITRANS) 3235C 3236C ANOTHER ROUTINE FOR MATRIX MULT : 3237C ITRANS = 0 : C = A*B 3238C ITRANS = 1 : C = A(T) * B 3239C ITRANS = 2 : C = A * B(T) 3240C 3241 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3242 REAL * 8 INPROD 3243 DIMENSION A(1 ),B(1 ), 3244 + C(MATDIM*MATDIM) 3245 3246 CALL SETVEC(C,0.0D0,MATDIM**2) 3247 IF(ITRANS.EQ.0) THEN 3248 DO 100 K = 1,NDIM 3249 DO 100 J = 1,NDIM 3250C BKJ = B(K,J) 3251 BKJ = B( (J-1)*MATDIM + K ) 3252 CALL VECSUM(C((J-1)*MATDIM+1),C((J-1)*MATDIM+1) 3253 + ,A((K-1)*MATDIM+1),1.0D0,BKJ,NDIM) 3254 100 CONTINUE 3255 END IF 3256C 3257 IF(ITRANS.EQ.1) THEN 3258 DO 200 I = 1,NDIM 3259 DO 200 J = 1,NDIM 3260 C((J-1)*MATDIM + I ) = 3261 & INPROD(A((I-1)*MATDIM+1),B((J-1)*MATDIM+1),NDIM) 3262 200 CONTINUE 3263 END IF 3264C 3265 IF(ITRANS.EQ.2) THEN 3266 DO 300 J = 1,NDIM 3267 DO 300 K = 1,NDIM 3268 BJK = B( (K-1)*MATDIM + J) 3269C BJK = B(J,K) 3270 CALL VECSUM(C((J-1)*MATDIM+1),C((J-1)*MATDIM+1) 3271 + ,A((K-1)*MATDIM+1),1.0D0,BJK,NDIM) 3272 300 CONTINUE 3273 END IF 3274C 3275 RETURN 3276 END 3277 SUBROUTINE MATML4(C,A,B,NCROW,NCCOL,NAROW,NACOL, 3278 & NBROW,NBCOL,ITRNSP ) 3279C 3280C MULTIPLY A AND B TO GIVE C 3281C 3282C C = A * B FOR ITRNSP = 0 3283C 3284C C = A(TRANSPOSED) * B FOR ITRNSP = 1 3285C 3286C C = A * B(TRANSPOSED) FOR ITRNSP = 2 3287C 3288C... JEPPE OLSEN, LAST REVISION JULY 24 1987 3289C 3290 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3291 DIMENSION A(NAROW,NACOL),B(NBROW,NBCOL) 3292 DIMENSION C(NCROW,NCCOL) 3293C 3294 NTEST = 00 3295 IF ( NTEST .NE. 0 ) THEN 3296 WRITE(6,*) 3297 WRITE(6,*) ' A AND B MATRIX FROM MATML4 ' 3298 WRITE(6,*) 3299 CALL WRTMAT(A,NAROW,NACOL,NAROW,NACOL) 3300 CALL WRTMAT(B,NBROW,NBCOL,NBROW,NBCOL) 3301 WRITE(6,*) ' NCROW NCCOL NAROW NACOL NBROW NBCOL ' 3302 WRITE(6,'(6I6)') NCROW,NCCOL,NAROW,NACOL,NBROW,NBCOL 3303 END IF 3304* 3305 IF(ITRNSP.LT.0.OR.ITRNSP.GT.2) THEN 3306 WRITE(6,*) ' Illegal value of ITRNSP in MATML4 ', ITRNSP 3307 STOP ' Illegal value of ITRNSP in MATML4 ' 3308 END IF 3309C 3310 CALL SETVEC(C,0.0D0,NCROW*NCCOL) 3311C 3312 IF( ITRNSP .NE. 0 ) GOTO 001 3313 DO 50 J = 1,NCCOL 3314 DO 40 K = 1,NBROW 3315 BKJ = B(K,J) 3316 DO 30 I = 1, NCROW 3317 C(I,J) = C(I,J) + A(I,K)*BKJ 3318 30 CONTINUE 3319 40 CONTINUE 3320 50 CONTINUE 3321C 3322C 3323 001 CONTINUE 3324C 3325 IF ( ITRNSP .NE. 1 ) GOTO 101 3326C... C = A(T) * B 3327 DO 150 J = 1, NCCOL 3328 DO 140 K = 1, NBROW 3329 BKJ = B(K,J) 3330 DO 130 I = 1, NCROW 3331 C(I,J) = C(I,J) + A(K,I)*BKJ 3332 130 CONTINUE 3333 140 CONTINUE 3334 150 CONTINUE 3335C 3336 101 CONTINUE 3337C 3338 IF ( ITRNSP .NE. 2 ) GOTO 201 3339C... C = A*B(T) 3340 DO 250 J = 1,NCCOL 3341 DO 240 K = 1,NBCOL 3342 BJK = B(J,K) 3343 DO 230 I = 1, NCROW 3344 C(I,J) = C(I,J) + A(I,K)*BJK 3345 230 CONTINUE 3346 240 CONTINUE 3347 250 CONTINUE 3348C 3349C 3350 201 CONTINUE 3351C 3352 IF ( NTEST .NE. 0 ) THEN 3353 WRITE(6,*) 3354 WRITE(6,*) ' C MATRIX FROM MATML4 ' 3355 WRITE(6,*) 3356 CALL WRTMAT(C,NCROW,NCCOL,NCROW,NCCOL) 3357 END IF 3358C 3359 RETURN 3360 END 3361 SUBROUTINE MATMUL(A,B,AB,NMXDIM,MATDIM,ITRANS) 3362C MULTIPLY MATRICES A AND B AND STORE IN AB 3363C 3364 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3365 DIMENSION A(NMXDIM,2),B(NMXDIM,2),AB(NMXDIM,2) 3366C 3367 TEST=1.0D-15 3368 IF(ITRANS.NE.0) THEN 3369 STOP 1 3370 END IF 3371 DO 300 I=1,MATDIM 3372 DO 300 J=1,MATDIM 3373 AB(J,I)=0.0D0 3374 300 CONTINUE 3375C 3376 DO 200 K=1,MATDIM 3377 DO 200 J=1,MATDIM 3378C 3379 BKJ=B(K,J) 3380 IF(ABS(BKJ).GT.TEST) THEN 3381 DO 100 I=1,MATDIM 3382 AB(I,J)=AB(I,J)+A(I,K)*BKJ 3383 100 CONTINUE 3384 END IF 3385 200 CONTINUE 3386 RETURN 3387 END 3388 SUBROUTINE MATVCB(MATRIX,VECIN,VECOUT,MATDIM,NDIM,ITRNSP) 3389 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3390 DOUBLE PRECISION MATRIX(MATDIM,MATDIM),VECIN(2),VECOUT(2) 3391C 3392C VECOUT=MATRIX*VECIN FOR ITRNSP=0 3393C VECOUT=MATRIX(TRANSPOSED)*VECIN FOR ITRNSP .NE. 0 3394C 3395 DO 10 I=1,NDIM 3396 10 VECOUT(I)=0.0D0 3397 IF(ITRNSP.EQ.0) THEN 3398C 3399 DO 100 J=1,NDIM 3400 VECINJ=VECIN(J) 3401 DO 90 I=1,NDIM 3402 VECOUT(I)=VECOUT(I)+MATRIX(I,J)*VECINJ 3403 90 CONTINUE 3404 100 CONTINUE 3405 END IF 3406C 3407 IF(ITRNSP.NE.0) THEN 3408 DO 200 I=1,NDIM 3409 X=0.0D0 3410 DO 190 J=1,NDIM 3411 X=X+MATRIX(J,I)*VECIN(J) 3412 190 CONTINUE 3413 VECOUT(I)=X 3414 200 CONTINUE 3415 END IF 3416 RETURN 3417 END 3418 SUBROUTINE MGS(NDIM,NVECIN,IVCFIL,NVECUT 3419 + ,X,A1,A2,B1,B2,MAXVEC) 3420C 3421C SUBROUTINE FOR MODIFIED GRAM SCHMIDT ORTHONORMALIZATION.CARE 3422C HAS BEEN TAKEN IN ORDER TO ASSURE STABLE NUMERICAL PERFORMANCE 3423C JO 10 MARCH '86 3424C 3425C THE NVECIN INPUT VECTORS RESIDE ON DISCFILE IVCFIL WITH A SPACING OF 3426C THE NVECUT ORTHOGONALIZED VECTORS IS DESCRIBED BY MATRIX X: X(OLDVEC,N 3427C THE UNIT BASIS IS ASSUMED ORTHOGONAL. 3428C 3429C 3430C 3431 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3432 REAL * 8 INPROD 3433C 3434 DIMENSION A1(1 ) ,A2(1 ),B1(1 ),B2(1 ) 3435 DIMENSION X(MAXVEC,MAXVEC) 3436C 3437 NTEST=1 3438 IF(NVECIN.GT.MAXVEC) THEN 3439 WRITE(6,1011)NVECIN,MAXVEC 3440 1011 FORMAT(1H0,' ACTUAL SUBSPACE DIMENSION',I3, 3441 + ' GREATER THAN ALLOWED MAXIMUM',I3,'!!!!!') 3442 STOP 3443 END IF 3444C 3445C 3446 XMAX = 1.0D+06 3447 IEFF = 0 3448 DO 10 I = 1,NVECIN 3449 DO 9 J = 1,NVECIN 3450 9 X(I,J)=0.0D0 3451 10 X(I,I)=1.0D0 3452C 3453C LOOP OVER NEW VECTORS 3454 DO 600 I=1,NVECIN 3455C** UNNORMALIZED VECTOR I 3456 ISTOP = I 3457 IADD = 1 3458 IMULT = 2 3459 CALL SETVEC (B1,0.0D0,NDIM) 3460 CALL VECSMF(B1,X(1,I),B2,ISTOP,IMULT,IADD,IVCFIL,NDIM) 3461C** NORMALIZE 3462 BNORM = INPROD(B1,B1,NDIM) 3463 SCALE = 1.0D0/SQRT(BNORM) 3464 CALL SCALVE(B1,SCALE,NDIM) 3465 CALL SCALVE(X(1,I),SCALE,NVECIN) 3466C WRITE(6,*) ' I X(*,I) ',I 3467C CALL WRITVE( X(1,I),NVECIN) 3468 XLARGE = FNDMNX(X(1,I),NVECIN,2) 3469 IF( ABS(XLARGE) .LE. XMAX ) THEN 3470C** NEW VECTOR IS OKAY SO 3471 IEFF = IEFF + 1 3472 IF( IEFF .NE. I ) CALL COPVEC(X(1,I),X(1,IEFF),NVECIN) 3473C** ORTHOGONALIZE REMAINING VECTORS TO THIS VECTOR 3474 IPL1 = I + 1 3475C* OVERLAP BETWEEN NEW VECTOR AND ORIGINAL VECTORS 3476 CALL REWINO( IVCFIL) 3477 DO 500 J=1,NVECIN 3478 IF( J.NE.1) READ(IVCFIL) 3479 CALL FRMDSC(B2,NDIM,-1 ,IVCFIL,IMZERO,IAMPACK) 3480 A1(J)=INPROD(B1,B2,NDIM) 3481 CALL MATVCB(X,A1,A2,MAXVEC,NVECIN,1) 3482 500 CONTINUE 3483C* ORTHOGONALIZE 3484 DO 450 K=IPL1,NVECIN 3485 FAC1 = 1.0D0/(1.0D0 - A2(K)**2) 3486 FAC2= -A2(K)*FAC1 3487 CALL VECSUM(X(1,K),X(1,K),X(1,IEFF),FAC1,FAC2,NVECIN) 3488 450 CONTINUE 3489 END IF 3490 600 CONTINUE 3491C 3492C 3493 NVECUT = IEFF 3494 IF( NVECUT.NE.NVECIN) 3495 + WRITE(6,1010 ) NVECUT 3496 1010 FORMAT(1H0,' number of vectors reduced to..',I4) 3497 RETURN 3498 END 3499C the Structure of files on the following can have one of 3500C three structures.The type of structure is defined by 3501C a parameter LBLK 3502C 3503C LBLK .GT. 0 : 3504C============== 3505C Each record is a single block of length LBLK, 3506C file has structure 3507C Record 1 3508C Record 2 3509C etc 3510C so no information about block size and end of record is 3511C given 3512C 3513C LBLK .EQ. 0 . 3514C============== 3515C Each record can consist of several blocks, information about 3516C length of block and end of record explicitly written on file 3517C file has structure 3518C Loop over records 3519C Loop over blocks of record 3520C LLBLK : .GE. 0 : length of next block 3521C .LT. 0 : End of record 3522C block of size LLBLK 3523C End of loop over blocks 3524C End of loop over records 3525C 3526C LBLK .LT. 0 3527C============= 3528C As LBLK .EQ. 0 , but use FASTIO routines to write/read files 3529 SUBROUTINE MICDV4O(VEC1,VEC2,LU1,LU2,RNRM,EIG,FINEIG,MAXIT,NVAR, 3530 & LU3,LU4,LU5,LUDIA,NROOT,MAXVEC,NINVEC, 3531 & APROJ,AVEC,WORK,IPRT, 3532 & NPRDIM,H0,IPNTR,NP1,NP2,NQ,H0SCR,LBLK,EIGSHF) 3533* 3534* Davidson algorithm , requires two blocks in core 3535* Multi root version 3536* 3537* 3538* Jeppe Olsen Winter of 1991 3539* 3540* Input : 3541* ======= 3542* LU1 : Initial set of vectors 3543* VEC1,VEC2 : Two vectors,each must be dimensioned to hold 3544* largest blocks 3545* LU3,LU4 : Scatch files 3546* LUDIA : File containing diagonal of matrix 3547* NROOT : Number of eigenvectors to be obtained 3548* MAXVEC : Largest allowed number of vectors 3549* must atleast be 2 * NROOT 3550* NINVEC : Number of initial vectors ( atleast NROOT ) 3551* NPRDIM : Dimension of subspace with 3552* nondiagonal preconditioning 3553* (NPRDIM = 0 indicates no such subspace ) 3554* For NPRDIM .gt. 0: 3555* PEIGVC : EIGENVECTORS OF MATRIX IN PRIMAR SPACE 3556* Holds preconditioner matrices 3557* PHP,PHQ,QHQ in this order !! 3558* PEIGVL : EIGENVALUES OF MATRIX IN PRIMAR SPACE 3559* IPNTR : IPNTR(I) IS ORIGINAL ADRESS OF SUBSPACE ELEMENT I 3560* NP1,NP2,NQ : Dimension of the three subspaces 3561* 3562* H0SCR : Scratch space for handling H0, at least 2*(NP1+NP2) ** 2 + 3563* 4 (NP1+NP2+NQ) 3564* LBLK : Defines block structure of matrices 3565* On input LU1 is supposed to hold initial guesses to eigenvectors 3566* 3567* 3568 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 3569#include "errquit.fh" 3570#include "mafdecls.fh" 3571#include "global.fh" 3572 DIMENSION VEC1(*),VEC2(*) 3573 REAL * 8 INPROD 3574 DIMENSION RNRM(MAXIT,NROOT),EIG(MAXIT,NROOT) 3575 DIMENSION APROJ(*),AVEC(*),WORK(*) 3576 DIMENSION H0(*),IPNTR(1) 3577 DIMENSION H0SCR(*) 3578* 3579* Dimensioning required of local vectors 3580* APROJ : MAXVEC*(MAXVEC+1)/2 3581* AVEC : MAXVEC ** 2 3582* WORK : MAXVEC*(MAXVEC+1)/2 3583* H0SCR : 2*(NP1+NP2) ** 2 + 4 * (NP1+NP2+NQ) 3584* 3585 DIMENSION FINEIG(1) 3586 LOGICAL CONVER,RTCNV(10) 3587 REAL*8 INPRDD 3588* 3589 IPICO = 0 3590 IF(IPICO.NE.0) THEN 3591C? WRITE(6,*) ' Perturbative solver ' 3592 MAXVEC = MIN(MAXVEC,2) 3593 ELSE IF(IPICO.EQ.0) THEN 3594C? WRITE(6,*) ' Variational solver ' 3595 END IF 3596* 3597 3598 IOLSTM = 0 3599 IF(IPRT.GT.1.AND.IOLSTM.NE.0) 3600 & WRITE(6,*) ' Inverse iteration modified Davidson ' 3601 IF(IPRT.GT.1.AND.IOLSTM.EQ.0) 3602 & WRITE(6,*) ' Normal Davidson method ' 3603 IF( MAXVEC .LT. 2 * NROOT ) THEN 3604 WRITE(6,*) ' Sorry MICDV4 wounded , MAXVEC .LT. 2*NROOT ' 3605 WRITE(6,*) ' NROOT, MAXVEC :',NROOT,MAXVEC 3606 WRITE(6,*) ' Raise MXCIV to be at least 2 * Nroot ' 3607 WRITE(6,*) ' Enforced stop on MICDV4 ' 3608 STOP 20 3609 END IF 3610* 3611 CALL MEMMAN(KAPROJ,MAXVEC*(MAXVEC+1)/2,'ADDL ',2,'KAPROJ') 3612CNW KAPROJ = 1 3613CNW KFREE = KAPROJ+ MAXVEC*(MAXVEC+1)/2 3614 TEST = 1.0D-8 3615 CONVER = .FALSE. 3616* 3617* =================== 3618*.Initial iteration 3619* =================== 3620 ITER = 1 3621 CALL REWINE(LU1,LBLK) 3622 CALL REWINE(LU2,LBLK) 3623 DO 10 IVEC = 1,NINVEC 3624 CALL REWINO(LU3) 3625 CALL REWINO(LU4) 3626C COPVCD(LUIN,LUOUT,SEGMNT,IREW,LBLK) 3627 CALL COPVCD(LU1,LU3,VEC1,0,LBLK) 3628 CALL MV7(VEC1,VEC2,LU3,LU4,0,0) 3629*. Move sigma to LU2, LU2 is positioned at end of vector IVEC - 1 3630 CALL REWINE(LU4,LBLK) 3631 CALL COPVCD(LU4,LU2,VEC1,0,LBLK) 3632*. Projected matrix 3633 CALL REWINE(LU2,LBLK) 3634 DO 8 JVEC = 1, IVEC 3635 CALL REWINE(LU3,LBLK) 3636 IJ = IVEC*(IVEC-1)/2 + JVEC 3637 APROJ(IJ) = INPRDD(VEC1,VEC2,LU2,LU3,0,LBLK) 3638 8 CONTINUE 3639 10 CONTINUE 3640* 3641 IF( IPRT .GE.10 ) THEN 3642 WRITE(6,*) ' INITIAL PROJECTED MATRIX ' 3643 CALL PRSYM(APROJ,NINVEC) 3644 END IF 3645*. Diagonalize initial projected matrix 3646 CALL COPVEC(APROJ,dbl_mb(KAPROJ),NINVEC*(NINVEC+1)/2) 3647 CALL EIGENL(dbl_mb(KAPROJ),AVEC,NINVEC,0,1) 3648 DO 20 IROOT = 1, NROOT 3649 EIG(1,IROOT) = dbl_mb(KAPROJ-1+IROOT*(IROOT+1)/2 ) 3650 20 CONTINUE 3651* 3652 IF(IPRT .GE. 3 ) THEN 3653 WRITE(6,'(A,I4)') ' Eigenvalues of initial iteration ' 3654 WRITE(6,'(5F18.13)') 3655 & ( EIG(1,IROOT)+EIGSHF,IROOT=1,NROOT) 3656 END IF 3657 IF( IPRT .GE. 5 ) THEN 3658 WRITE(6,*) ' Initial set of eigen values ' 3659 CALL WRTMAT(EIG(1,1),1,NROOT,MAXIT,NROOT) 3660 END IF 3661 NVEC = NINVEC 3662 IF (MAXIT .EQ. 1 ) GOTO 901 3663* 3664* ====================== 3665*. Loop over iterations 3666* ====================== 3667* 3668 1000 CONTINUE 3669 IF(IPRT .GE. 10 ) THEN 3670 WRITE(6,*) ' Info from iteration .... ', ITER 3671 END IF 3672 ITER = ITER + 1 3673* 3674* =============================== 3675*.1 New directions to be included 3676* =============================== 3677* 3678* 1.1 : R = H*X - EIGAPR*X 3679* 3680 IADD = 0 3681 CONVER = .TRUE. 3682 DO 100 IROOT = 1, NROOT 3683 EIGAPR = EIG(ITER-1,IROOT) 3684* 3685 CALL REWINE(LU1,LBLK) 3686 CALL REWINE(LU2,LBLK) 3687 EIGAPR = EIG(ITER-1,IROOT) 3688 DO 60 IVEC = 1, NVEC 3689 FACTOR = AVEC((IROOT-1)*NVEC+IVEC) 3690 IF(IVEC.EQ.1) THEN 3691 CALL REWINE( LU3, LBLK ) 3692* SCLVCD(LUIN,LUOUT,SCALE,SEGMNT,IREW,LBLK) 3693 CALL SCLVCD(LU2,LU3,FACTOR,VEC1,0,LBLK) 3694 ELSE 3695 CALL REWINE(LU3,LBLK) 3696 CALL REWINE(LU4,LBLK) 3697C VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 3698 CALL VECSMD(VEC1,VEC2,1.0D0,FACTOR,LU4,LU2,LU3,0,LBLK) 3699 END IF 3700C 3701 FACTOR = -EIGAPR*AVEC((IROOT-1)*NVEC+ IVEC) 3702 CALL REWINE(LU3,LBLK) 3703 CALL REWINE(LU4,LBLK) 3704 CALL VECSMD(VEC1,VEC2,1.0D0,FACTOR,LU3,LU1,LU4,0,LBLK) 3705 60 CONTINUE 3706 IF ( IPRT .GE. 10 ) THEN 3707 WRITE(6,*) ' ( HX - EX ) ' 3708 CALL WRTVCD(VEC1,LU4,1,LBLK) 3709C WRTVCD(SEGMNT,LU,IREW,LBLK) 3710 END IF 3711* Strange place to put convergence but .... 3712C INPRDD(VEC1,VEC2,LU1,LU2,IREW,LBLK) 3713 RNORM = SQRT( INPRDD(VEC1,VEC1,LU4,LU4,1,LBLK) ) 3714 RNRM(ITER-1,IROOT) = RNORM 3715 IF(RNORM.LT. TEST ) THEN 3716 RTCNV(IROOT) = .TRUE. 3717 ELSE 3718 RTCNV(IROOT) = .FALSE. 3719 CONVER = .FALSE. 3720 END IF 3721 IF( ITER .GT. MAXIT) GOTO 100 3722* ===================================================================== 3723*. 1.2 : Multiply with inverse Hessian approximation to get new directio 3724* ===================================================================== 3725 IF( .NOT. RTCNV(IROOT) ) THEN 3726 IADD = IADD + 1 3727C CALL REWINO( LUDIA) 3728C CALL FRMDSC(VEC2,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 3729C CALL H0M1TV(VEC2,VEC1,VEC1,NVAR,NPRDIM,IPNTR, 3730C & H0,-EIGAPR,H0SCR,XDUMMY,NP1,NP2,NQ) 3731*. Inverted diagonal times (HX-EX) on LU3 3732 CALL DMTVCD(VEC1,VEC2,LUDIA,LU4,LU3,-EIGAPR,1,1,LBLK) 3733 3734 IF ( IPRT .GE. 600) THEN 3735 WRITE(6,*) ' (D-E)-1 *( HX - EX ) ' 3736 CALL WRTVCD(VEC1,LU3,1,LBLK) 3737 END IF 3738* 3739 IF(IOLSTM .NE. 0 ) THEN 3740* add Olsen correction if neccessary 3741* Current eigen-vector on LU4 3742 CALL REWINE(LU1,LBLK) 3743 DO 66 IVEC = 1, NVEC 3744 FACTOR = AVEC((IROOT-1)*NVEC+IVEC) 3745 IF(IVEC.EQ.1) THEN 3746 CALL REWINE( LU4, LBLK ) 3747 CALL SCLVCD(LU1,LU4,FACTOR,VEC1,0,LBLK) 3748 ELSE 3749 CALL REWINE(LU5,LBLK) 3750 CALL REWINE(LU4,LBLK) 3751 CALL VECSMD(VEC1,VEC2,1.0D0,FACTOR,LU4,LU1,LU5,0,LBLK) 3752 CALL COPVCD(LU4,LU5,VEC1,1,LBLK) 3753 END IF 3754 66 CONTINUE 3755 IF ( IPRT .GE. 10 ) THEN 3756 WRITE(6,*) ' (current X ) ' 3757 CALL WRTVCD(VEC1,LU5,1,LBLK) 3758 END IF 3759* (H0 - E )-1 * X on LU4 3760C CALL H0M1TV(VEC2,VEC1,VEC2,NVAR,NPRDIM,IPNTR, 3761C & H0,-EIGAPR,H0SCR,XDUMMY,NP1,NP2,NQ) 3762 CALL DMTVCD(VEC1,VEC2,LUDIA,LU5,LU4,-EIGAPR,1,1,LBLK) 3763* Gamma = X(T) * (H0 - E) ** -1 * X 3764 GAMMA = INPRDD(VEC1,VEC2,LU5,LU4,1,LBLK) 3765* is X an eigen vector for (H0 - 1 ) - 1 3766C VCSMDN(VEC1,VEC2,FAC1,FAC2,LU1,LU2,IREW,LBLK) 3767 VNORM = 3768 & SQRT(VCSMDN(VEC1,VEC2,-GAMMA,1.0D0,LU4,LU5,1,LBLK)) 3769 IF(VNORM .GT. 1.0D-7 ) THEN 3770 IOLSAC = 1 3771 ELSE 3772 IOLSAC = 0 3773 END IF 3774 IF(IOLSAC .EQ. 1 ) THEN 3775 IF(IPRT.GE.5) WRITE(6,*) ' Olsen Correction active ' 3776 DELTA = INPRDD(LU4,LU3,VEC1,VEC2,1,LBLK) 3777 FACTOR = -DELTA/GAMMA 3778 IF(IPRT.GE.5) WRITE(6,*) ' DELTA,GAMMA,FACTOR' 3779 IF(IPRT.GE.5) WRITE(6,*) DELTA,GAMMA,FACTOR 3780C VECSMD(VEC1,VEC2,1.0D0,FACTOR,LU4,LU1,LU5,0,LBLK) 3781 CALL VECSMD(VEC1,VEC2,1.0D0,FACTOR,LU3,LU5,LU4,1,LBLK) 3782 CALL COPVCD(LU4,LU3,VEC1,1,LBLK) 3783 END IF 3784 END IF 3785*. 1.3 Orthogonalize to all previous vectors 3786 CALL REWINE( LU1 ,LBLK) 3787 DO 80 IVEC = 1,NVEC+IADD-1 3788 CALL REWINE(LU3,LBLK) 3789 WORK(IVEC) = INPRDD(VEC1,VEC2,LU1,LU3,0,LBLK) 3790 80 CONTINUE 3791* 3792 CALL REWINE(LU1,LBLK) 3793 DO 82 IVEC = 1,NVEC+IADD-1 3794 CALL REWINE(LU3,LBLK) 3795 CALL REWINE(LU4,LBLK) 3796 CALL VECSMD(VEC1,VEC2,-WORK(IVEC),1.0D0,LU1,LU3, 3797 & LU4,0,LBLK) 3798 CALL COPVCD(LU4,LU3,VEC1,1,LBLK) 3799 82 CONTINUE 3800 IF ( IPRT .GE. 600 ) THEN 3801 WRITE(6,*) ' Orthogonalized (D-E)-1 *( HX - EX ) ' 3802 CALL WRTVCD(VEC1,LU3,1,LBLK) 3803 END IF 3804*. 1.4 Normalize vector 3805 SCALE = INPRDD(VEC1,VEC1,LU3,LU3,1,LBLK) 3806 FACTOR = 1.0D0/SQRT(SCALE) 3807 CALL REWINE(LU3,LBLK) 3808 CALL SCLVCD(LU3,LU1,FACTOR,VEC1,0,LBLK) 3809* 3810 END IF 3811 100 CONTINUE 3812 IF( CONVER ) GOTO 901 3813 IF( ITER.GT. MAXIT) THEN 3814 ITER = MAXIT 3815 GOTO 1001 3816 END IF 3817* 3818** 2 : Optimal combination of new and old directions 3819* 3820* 2.1: Multiply new directions with matrix 3821 CALL SKPVCD(LU1,NVEC,VEC1,1,LBLK) 3822 CALL SKPVCD(LU2,NVEC,VEC1,1,LBLK) 3823 DO 150 IVEC = 1, IADD 3824 CALL REWINE(LU3,LBLK) 3825 CALL COPVCD(LU1,LU3,VEC1,0,LBLK) 3826 CALL MV7(VEC1,VEC2,LU3,LU4,0,0) 3827 CALL REWINE(LU4,LBLK) 3828 CALL COPVCD(LU4,LU2,VEC1,0,LBLK) 3829*. Augment projected matrix 3830 CALL REWINE( LU1,LBLK) 3831 DO 140 JVEC = 1, NVEC+IVEC 3832 CALL REWINE(LU4,LBLK) 3833 IJ = (IVEC+NVEC)*(IVEC+NVEC-1)/2 + JVEC 3834 APROJ(IJ) = INPRDD(VEC1,VEC2,LU1,LU4,0,LBLK) 3835 140 CONTINUE 3836 150 CONTINUE 3837*. Diagonalize projected matrix 3838 NVEC = NVEC + IADD 3839 CALL COPVEC(APROJ,dbl_mb(KAPROJ),NVEC*(NVEC+1)/2) 3840 CALL EIGENL(dbl_mb(KAPROJ),AVEC,NVEC,0,1) 3841 IF(IPICO.NE.0) THEN 3842 E0VAR = dbl_mb(KAPROJ) 3843 C0VAR = AVEC(1) 3844 C1VAR = AVEC(2) 3845*. overwrite with pert solution 3846 C1NRM = SQRT(C0VAR**2 + C1VAR**2) 3847 AVEC(1) = 1.0D0/SQRT(1.0D0+C1NRM**2) 3848 AVEC(2) = -C1NRM/SQRT(1.0D0+C1NRM**2) 3849 E0PERT = AVEC(1)**2*APROJ(1) 3850 & + 2.0D0*AVEC(1)*AVEC(2)*APROJ(2) 3851 & + AVEC(2)**2*APROJ(3) 3852 dbl_mb(KAPROJ) = E0PERT 3853 WRITE(6,*) ' Var and Pert solution, energy and coefficients' 3854 WRITE(6,'(4X,3E15.7)') E0VAR,C0VAR,C1VAR 3855 WRITE(6,'(4X,3E15.7)') E0PERT,AVEC(1),AVEC(2) 3856 END IF 3857 DO 160 IROOT = 1, NROOT 3858 EIG(ITER,IROOT) = dbl_mb(KAPROJ-1+IROOT*(IROOT+1)/2) 3859 160 CONTINUE 3860* 3861 IF(IPRT .GE. 3 ) THEN 3862 WRITE(6,'(A,I4)') ' Eigenvalues of iteration ..', ITER 3863 WRITE(6,'(5F18.13)') 3864 & ( EIG(ITER,IROOT)+EIGSHF,IROOT=1,NROOT) 3865 END IF 3866* 3867 IF( IPRT .GE. 5 ) THEN 3868 WRITE(6,*) ' Projected matrix and eigen pairs ' 3869 CALL PRSYM(APROJ,NVEC) 3870 WRITE(6,'(2X,E13.7)') (EIG(ITER,IROOT),IROOT = 1, NROOT) 3871 CALL WRTMAT(AVEC,NVEC,NROOT,MAXVEC,NROOT) 3872 END IF 3873* 3874** perhaps reset or assemble converged eigenvectors 3875* 3876 901 CONTINUE 3877* 3878 IPULAY = 1 3879 IF(IPULAY.EQ.1 .AND. MAXVEC.EQ.3*NROOT .AND.NVEC.GE.2*NROOT) THEN 3880* Save trial vectors : 1 -- current trial vector 3881* 2 -- previous trial vector orthogonalized 3882*. Current trial vectors 3883 CALL REWINE( LU5,LBLK) 3884 DO 421 IROOT = 1, NROOT 3885 CALL MVCSMD(LU1,AVEC((IROOT-1)*NVEC+1), 3886 & LU3,LU4,VEC1,VEC2,NVEC,1,LBLK) 3887 XNORM = INPRDD(VEC1,VEC1,LU3,LU3,1,LBLK) 3888 CALL REWINE(LU3,LBLK) 3889 SCALE = 1.0D0/SQRT(XNORM) 3890 WORK(IROOT) = SCALE 3891 CALL SCLVCD(LU3,LU5,SCALE,VEC1,0,LBLK) 3892 421 CONTINUE 3893*. Previous trial vectors orthogonalized 3894C ORTVCD(LUIN,LUVEC,LUOUT,LUSCR,VEC1,VEC2,NVEC,LBLK, 3895C & SCR,INORMA) 3896 CALL REWINE(LU1,LBLK) 3897 DO 430 IROOT = 1, NROOT 3898 CALL ORTVCD(LU1,LU5,LU3,LU4,VEC1,VEC2,NROOT+IROOT-1,LBLK, 3899 & AVEC((IROOT-1)*NVEC+1),1) 3900 430 CONTINUE 3901 CALL REWINE(LU3,LBLK) 3902 CALL COPVCD(LU3,LU5,VEC1,0,LBLK) 3903*. Transfer C vectors to LU1 3904 CALL REWINE( LU1,LBLK) 3905 CALL REWINE( LU5,LBLK) 3906 DO 441 IVEC = 1,2*NROOT 3907 CALL COPVCD(LU5,LU1,VEC1,0,LBLK) 3908 441 CONTINUE 3909*. corresponding sigma vectors 3910 CALL REWINE (LU5,LBLK) 3911 CALL REWINE (LU2,LBLK) 3912 DO 450 IROOT = 1, 2*NROOT 3913 CALL MVCSMD(LU2,AVEC((IROOT-1)*NVEC+1), 3914 & LU3,LU4,VEC1,VEC2,NVEC,1,LBLK) 3915* 3916 CALL REWINE(LU3,LBLK) 3917 CALL SCLVCD(LU3,LU5,WORK(IROOT),VEC1,0,LBLK) 3918 450 CONTINUE 3919* 3920* Transfer HC's to LU2 3921 CALL REWINE( LU2,LBLK) 3922 CALL REWINE( LU5,LBLK) 3923 DO 460 IVEC = 1,2*NROOT 3924 CALL COPVCD(LU5,LU2,VEC1,0,LBLK) 3925 460 CONTINUE 3926 NVEC = 2*NROOT 3927* 3928* 3929 CALL SETVEC(AVEC,0.0D0,NVEC**2) 3930 DO 2410 IROOT = 1,NVEC 3931 AVEC((IROOT-1)*NVEC+IROOT) = 1.0D0 3932 2410 CONTINUE 3933*.Projected hamiltonian 3934 CALL REWINO( LU1 ) 3935 DO 2010 IVEC = 1,NVEC 3936 CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 3937 CALL REWINO( LU2) 3938 DO 2008 JVEC = 1, IVEC 3939 CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 3940 IJ = IVEC*(IVEC-1)/2 + JVEC 3941 APROJ(IJ) = INPROD(VEC1,VEC2,NVAR) 3942 2008 CONTINUE 3943 2010 CONTINUE 3944 END IF 3945* 3946 IF(NVEC+NROOT.GT.MAXVEC .OR. CONVER .OR. MAXIT .EQ.ITER)THEN 3947 CALL REWINE( LU5,LBLK) 3948 DO 320 IROOT = 1, NROOT 3949 CALL MVCSMD(LU1,AVEC((IROOT-1)*NVEC+1), 3950 & LU3,LU4,VEC1,VEC2,NVEC,1,LBLK) 3951 XNORM = INPRDD(VEC1,VEC1,LU3,LU3,1,LBLK) 3952 CALL REWINE(LU3,LBLK) 3953 SCALE = 1.0D0/SQRT(XNORM) 3954 WORK(IROOT) = SCALE 3955 CALL SCLVCD(LU3,LU5,SCALE,VEC1,0,LBLK) 3956 320 CONTINUE 3957*. Transfer C vectors to LU1 3958 CALL REWINE( LU1,LBLK) 3959 CALL REWINE( LU5,LBLK) 3960 DO 411 IVEC = 1,NROOT 3961 CALL COPVCD(LU5,LU1,VEC1,0,LBLK) 3962 411 CONTINUE 3963*. corresponding sigma vectors 3964 CALL REWINE (LU5,LBLK) 3965 CALL REWINE (LU2,LBLK) 3966 DO 329 IROOT = 1, NROOT 3967 CALL MVCSMD(LU2,AVEC((IROOT-1)*NVEC+1), 3968 & LU3,LU4,VEC1,VEC2,NVEC,1,LBLK) 3969* 3970 CALL REWINE(LU3,LBLK) 3971 CALL SCLVCD(LU3,LU5,WORK(IROOT),VEC1,0,LBLK) 3972 329 CONTINUE 3973* 3974* Transfer HC's to LU2 3975 CALL REWINE( LU2,LBLK) 3976 CALL REWINE( LU5,LBLK) 3977 DO 400 IVEC = 1,NROOT 3978 CALL COPVCD(LU5,LU2,VEC1,0,LBLK) 3979 400 CONTINUE 3980 NVEC = NROOT 3981* 3982 CALL SETVEC(AVEC,0.0D0,NVEC**2) 3983 DO 410 IROOT = 1,NROOT 3984 AVEC((IROOT-1)*NROOT+IROOT) = 1.0D0 3985 410 CONTINUE 3986* 3987 CALL SETVEC(APROJ,0.0D0,NVEC*(NVEC+1)/2) 3988 DO 420 IROOT = 1, NROOT 3989 APROJ(IROOT*(IROOT+1)/2 ) = EIG(ITER,IROOT) 3990 420 CONTINUE 3991* 3992 END IF 3993 IF( ITER .LE. MAXIT .AND. .NOT. CONVER) GOTO 1000 3994 1001 CONTINUE 3995 3996* ( End of loop over iterations ) 3997* 3998 IF( .NOT. CONVER ) THEN 3999* CONVERGENCE WAS NOT OBTAINED 4000 IF(IPRT .GE. 2 ) 4001 & WRITE(6,1170) MAXIT 4002 1170 FORMAT('0 Convergence was not obtained in ',I3,' iterations') 4003 ELSE 4004* CONVERGENCE WAS OBTAINED 4005 ITER = ITER - 1 4006 IF (IPRT .GE. 2 ) 4007 & WRITE(6,1180) ITER 4008 1180 FORMAT(1H0,' Convergence was obtained in ',I3,' iterations') 4009 END IF 4010* 4011 IF ( IPRT .GT. 1 ) THEN 4012 CALL REWINO(LU1) 4013 DO 1600 IROOT = 1, NROOT 4014 WRITE(6,*) 4015 WRITE(6,'(A,I3)') 4016 & ' Information about convergence for root... ' ,IROOT 4017 WRITE(6,*) 4018 & '============================================' 4019 WRITE(6,*) 4020 FINEIG(IROOT) = EIG(ITER,IROOT) 4021 WRITE(6,1190) FINEIG(IROOT)+EIGSHF 4022 1190 FORMAT(' The final approximation to eigenvalue ',F18.10) 4023 IF(IPRT.GE.400) THEN 4024 WRITE(6,1200) 4025 1200 FORMAT(1H0,'The final approximation to eigenvector') 4026 CALL WRTVCD(VEC1,LU1,0,LBLK) 4027 END IF 4028 WRITE(6,1300) 4029 1300 FORMAT(1H0,' Summary of iterations ',/,1H 4030 + ,' ----------------------') 4031 WRITE(6,1310) 4032 1310 FORMAT 4033 & (1H0,' Iteration point Eigenvalue Residual ') 4034 DO 1330 I=1,ITER 4035 1330 WRITE(6,1340) I,EIG(I,IROOT)+EIGSHF,RNRM(I,IROOT) 4036 1340 FORMAT(1H ,6X,I4,8X,F20.13,2X,E12.5) 4037 1600 CONTINUE 4038 ELSE 4039 DO 1601 IROOT = 1, NROOT 4040 FINEIG(IROOT) = EIG(ITER,IROOT)+EIGSHF 4041 1601 CONTINUE 4042 END IF 4043* 4044 IF(IPRT .EQ. 1 ) THEN 4045 DO 1607 IROOT = 1, NROOT 4046 WRITE(6,'(A,2I3,E13.6,2E10.3)') 4047 & ' >>> CI-OPT Iter Root E g-norm g-red', 4048 & ITER,IROOT,FINEIG(IROOT),RNRM(ITER,IROOT), 4049 & RNRM(1,IROOT)/RNRM(ITER,IROOT) 4050 1607 CONTINUE 4051 END IF 4052C 4053 RETURN 4054 1030 FORMAT(1H0,2X,7F15.8,/,(1H ,2X,7F15.8)) 4055 1120 FORMAT(1H0,2X,I3,7F15.8,/,(1H ,5X,7F15.8)) 4056 END 4057 SUBROUTINE MINDAV(VEC1,VEC2,LU1,LU2,RNRM,EIG,EIGAPR,MAXIT,NVAR, 4058 & LU3,LUDIA) 4059C 4060C MINIMAL DAVIDSON ALGORITHM WITH ONLY TWO VECTOR SEGMEMNTS IN CORE . 4061C 4062C INPUT : 4063C 4064C VEC1,VEC2 : TWO VECTORS,EACH MUST HOLD LATGEST BLOCK OF 4065C VECTOR 4066C 4067C LU1,LU2,LU3 : TWO SCRATCH FILES 4068C LUDIA : FILE CONTAINING CI DIAGONAL 4069C ON INPUT VEC1/LU1 IS SUPPOSED TO HOLD INITIAL GUESS TO EIGENVECTOR 4070 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 4071 DIMENSION VEC1(*),VEC2(*) 4072 REAL * 8 INPROD 4073 DIMENSION RNRM(1 ),EIG(1 ) 4074 LOGICAL CONVER 4075C 4076 NTEST = 1 4077 TEST = 1.0D-5 4078 CONVER = .FALSE. 4079 DO 1234 MACRO = 1,1 4080C 4081C... INITAL ITERATION 4082 ITER = 1 4083*. Does not work ... 4084 CALL MV7(VEC1,VEC2,LU1,LU2,0,0) 4085 EIGAPR = INPROD(VEC1,VEC2,NVAR) 4086 EIG(ITER) = EIGAPR 4087C 4088 CALL REWINO( LU1 ) 4089 CALL REWINO( LU2) 4090 CALL TODSC(VEC1,NVAR,-1 ,LU1) 4091 CALL TODSC(VEC2,NVAR,-1 ,LU2) 4092C 4093C 4094C** LOOP OVER ITERATIONS 4095C 4096 1000 CONTINUE 4097 IF(NTEST .GE. 10 ) THEN 4098 WRITE(6,*) ' INFO FORM ITERATION .... ', ITER 4099 WRITE(6,*) ' EIGEN VECTOR APPROXIMATION ' 4100 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4101 WRITE(6,*) 4102 WRITE(6,*) 'MATRIX TIMES EIGEN VECTOR APPROXIMATION ' 4103 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 4104 END IF 4105 4106 ITER = ITER + 1 4107C 4108C *** 1 : NEW DIRECTION TO BE INCLUDED 4109C 4110C. 1.1 : R = H*X - EIGAPR*X IN VEC2 4111 CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,-EIGAPR,NVAR) 4112 IF(NTEST .GE. 10 ) THEN 4113 WRITE(6,*) ' HX - EX ' 4114 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 4115 END IF 4116C 4117C... STRANGE PLACE FOR CONVERGENCE TEST , BUT. 4118 RNORM = INPROD(VEC2,VEC2,NVAR) 4119 RNORM = SQRT(RNORM) 4120 RNRM(ITER-1) = RNORM 4121 IF(RNORM.LT. TEST ) THEN 4122 CONVER = .TRUE. 4123 GOTO 1001 4124 END IF 4125C. 1.2 : MULTIPLY WITH INVERSE HESSIAN APROXIMATION TO GET NEW DIRECTIO 4126 CALL REWINO( LUDIA) 4127 CALL FRMDSC(VEC1,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 4128 CALL DIAVC2(VEC2,VEC2,VEC1,-EIGAPR,NVAR) 4129 IF ( NTEST .GE. 10 ) THEN 4130 WRITE(6,*) ' (D-E)-1 *( HX - EX ) ' 4131 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 4132 END IF 4133 4134C. 1.3 : ORTHOGONALIZE R TO CURRENT EIGEN VECTOR APROXIMATION (VEC2) 4135 CALL REWINO( LU1 ) 4136 CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4137 OVRLP = INPROD(VEC2,VEC1,NVAR) 4138 CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,-OVRLP,NVAR) 4139 IF ( NTEST .GE. 10 ) THEN 4140 WRITE(6,*) 'ORTHOGONALIZED (D-E)-1 *( HX - EX ) ' 4141 CALL WRTMAT(VEC2,1,NVAR,1,NVAR) 4142 END IF 4143C 4144C 4145C. 1.4 : NORMALIZE NEW DIRECTION TO 1 4146 CALL SCALE2(VEC2,NVAR,FACTOR) 4147C. NEW DIRECTION IS NOW IN VEC2, SAVE IN LU3 4148 CALL REWINO( LU3 ) 4149 CALL TODSC(VEC2,NVAR,-1 ,LU3) 4150 4151C 4152C.. 2 : OPTIMAL COMBINATION OF NEW AND OLD DIRECTION 4153C 4154C. 2.1: MULTIPLY NEW DIRECTION WITH MATRIX 4155 CALL MV7(VEC2,VEC1,LU1,LU2,0,0) 4156C. 2.2: 2 BY 2 PROJECTED MATRIX 4157 E00 = EIGAPR 4158 E11 = INPROD(VEC2,VEC1,NVAR) 4159C PREVIOUS X VECTOR IN VEC2 4160 CALL REWINO( LU1 ) 4161 CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4162 E01 = INPROD(VEC1,VEC2,NVAR) 4163C? WRITE(6,*) ' E00,E01,E11',E00,E01,E11 4164C 4165C 4166C E00 E01 4167C LOWEST EIGENVALUE OF IS 4168C E01 E11 4169C 4170C 4171C -B/2 - SQRT(B**2-4C)/2 WHERE 4172C 4173C B = -(E00+E11), C = E00*E11-E01*E01 4174 B = -E00-E11 4175 C = E00*E11-E01**2 4176C WRITE(6,*) 'B C ',B,C 4177C 4178 EIGAPR = -B/2.0D0 - SQRT(B*B - 4*C )/2.0D0 4179C 4180C NEW EIGENVECTOR IN TWO VECTOR BASE 4181 FAC = SQRT(1.0D0+(E00-EIGAPR)**2/E01**2 ) 4182 FAC = DSQRT(1.0D0+((E00-EIGAPR)/E01)**2) 4183 X1 = 1.0D0/FAC 4184 X2 = -(E00-EIGAPR)/E01/FAC 4185 IF(ABS(E01) .LE. 1.0D-5 ) THEN 4186C FIRST ORDER CORRECTION 4187 DELTA = E01/(E00-E11) 4188 FAC = 1.0D0/DSQRT(1.0D0+DELTA**2) 4189 X1 = FAC 4190 X2 = DELTA * FAC 4191 EIGAPR =(E00*X1**2 + E11*X2**2 + 2*E01*X1*X2)/(X1**2+X2**2) 4192 END IF 4193 WRITE(6,*) ' EIGAPR',EIGAPR 4194C? WRITE(6,*) ' E00 - EIGAPR ',E00-EIGAPR 4195 EIG(ITER) = EIGAPR 4196C? WRITE(6,*) ' X1, X2', X1,X2 4197C? EIGAP2 =(E00*X1**2 + E11*X2**2 + 2*E01*X1*X2)/(X1**2+X2**2) 4198C? WRITE(6,*) ' ANOTHER ENERGY EVALUTION GIVES ',EIGAP2 4199C 4200C OFF DIAGONAL ELEMENT IN NEW BASIS 4201C ? DELTA = (E00-E11)*X1*X2 + E01*(X2**2-X1**2) 4202C ? WRITE(6,*) ' NEW OFF DIAGONAL MATRIX ELELMENT ',DELTA 4203C 4204C** 3 : PREPARE FOR NEXT ITERATION 4205C 4206C H TIMES CURRENT CI VECTOR 4207 CALL REWINO( LU2 ) 4208 CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 4209 CALL VECSUM(VEC1,VEC1,VEC2,X2,X1,NVAR) 4210 CALL REWINO( LU2 ) 4211 CALL TODSC(VEC1,NVAR,-1 ,LU2) 4212C CURRENT CI VECTOR TO DISC 4213 CALL REWINO( LU1 ) 4214 CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4215 CALL REWINO( LU3 ) 4216 CALL FRMDSC(VEC2,NVAR,-1 ,LU3,IMZERO,IAMPACK) 4217 CALL VECSUM(VEC1,VEC1,VEC2,X1,X2,NVAR) 4218 CALL REWINO( LU1 ) 4219 CALL TODSC(VEC1,NVAR,-1 ,LU1) 4220 CALL REWINO( LU2 ) 4221 CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 4222C 4223C 4224 IF( ITER .LT. MAXIT ) GOTO 1000 4225 1001 CONTINUE 4226C 4227C 4228C 4229 IF( .NOT. CONVER ) THEN 4230C CONVERGENCE WAS NOT OBTAINED 4231 WRITE(6,1170) MAXIT 4232 1170 FORMAT('0 CONVERGENCE WAS NOT OBTAINED IN ',I3,'ITERATIONS') 4233 ELSE 4234C CONVERGENCE WAS OBTAINED 4235 ITER = ITER - 1 4236 WRITE(6,1180) ITER 4237 1180 FORMAT(1H0,' Convergence was obtained in ',I3,' iterations') 4238 END IF 4239C 4240 WRITE(6,1190) EIGAPR 4241 1190 FORMAT(' The final approximation to eigenvalue ',F18.10) 4242C WRITE(6,1200) 4243C1200 FORMAT(1H0,'THE FINAL APPROXIMATION TO EIGENVECTOR') 4244C WRITE(6,1030) (VEC1(I),I=1,NVAR) 4245 WRITE(6,1300) 4246 1300 FORMAT(1H0,' Summary of iterations ',/,1H 4247 + ,' ----------------------') 4248 WRITE(6,1310) 4249 1310 FORMAT(1H0,' Iteration point Eigenvalue Residual ') 4250 DO 1330 I=1,ITER 4251 1330 WRITE(6,1340) I,EIG(I),RNRM(I) 4252 1340 FORMAT(1H ,6X,I4,8X,F18.13,2X,E12.5) 4253 1234 CONTINUE 4254C 4255 RETURN 4256 1030 FORMAT(1H0,2X,7F15.8,/,(1H ,2X,7F15.8)) 4257 1120 FORMAT(1H0,2X,I3,7F15.8,/,(1H ,5X,7F15.8)) 4258 END 4259 SUBROUTINE MINDV4(MV7, 4260 & VEC1,VEC2,LU1,LU2,RNRM,EIG,FINEIG,MAXIT,NVAR, 4261 & LU3,LUDIA,NROOT,MAXVEC,NINVEC, 4262 & APROJ,AVEC,WORK,IPRT, 4263 & NPRDIM,H0,IPNTR,NP1,NP2,NQ,H0SCR,EIGSHF, 4264 & IOLSEN,IPICO,CONVER,RNRM_CNV,IROOT_SEL) 4265* 4266* Davidson algorithm , requires two vectors in core 4267* Multi root version 4268* 4269* Allows updating of preconditioning matrix so this is 4270* the current eigenvector approximation 4271* is an eigenvector for the preconditioner 4272* 4273* Jeppe Olsen Sept 89 4274* Jan 92 : MV7 entry 4275* Feb. 13: IROOT_SEL added 4276* 4277* Input : 4278* ======= 4279* MV7 : Name of routine performing matrix*vector calculation 4280* LU1 : Initial set of vectors 4281* VEC1,VEC2 : Two vectors,each must be dimensioned to hold 4282* complete vector 4283* LU2,LU3 : Scatch files 4284* LUDIA : File containing diagonal of matrix 4285* NROOT : Number of eigenvectors to be obtained 4286* MAXVEC : Largest allowed number of vectors 4287* must atleast be 2 * NROOT 4288* NINVEC : Number of initial vectors ( atleast NROOT ) 4289* NPRDIM : Dimension of subspace with 4290* nondiagonal preconditioning 4291* (NPRDIM = 0 indicates no such subspace ) 4292* For NPRDIM .gt. 0: 4293* PEIGVC : EIGENVECTORS OF MATRIX IN PRIMAR SPACE 4294* Holds preconditioner matrices 4295* PHP,PHQ,QHQ in this order !! 4296* PEIGVL : EIGENVALUES OF MATRIX IN PRIMAR SPACE 4297* IPNTR : IPNTR(I) IS ORIGINAL ADRESS OF SUBSPACE ELEMENT I 4298* NP1,NP2,NQ : Dimension of the three subspaces 4299* 4300* H0SCR : Scratch space for handling H0, at least 2*(NP1+NP2) ** 2 + 4301* 4 (NP1+NP2+NQ) 4302* On input LU1 is supposed to hold initial guess to eigenvectors 4303* 4304* IOLSEN : Use inverse iteration modified Davidson 4305* IPICO : Use perturbation estimate of new vector instead of 4306* variational method 4307* 4308 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 4309#include "errquit.fh" 4310#include "mafdecls.fh" 4311#include "global.fh" 4312#include "dra.fh" 4313 integer VEC1,VEC2 4314 REAL * 8 INPROD 4315 DIMENSION RNRM(MAXIT,NROOT),EIG(MAXIT,NROOT) 4316 DIMENSION APROJ(*),AVEC(*),WORK(*) 4317 DIMENSION H0(*),IPNTR(1) 4318 DIMENSION H0SCR(*) 4319 DIMENSION RNRM_CNV(*) 4320 character*100 myname,filename 4321* 4322* Dimensioning required of local vectors 4323* APROJ : MAXVEC*(MAXVEC+1)/2 4324* AVEC : MAXVEC ** 2 4325* WORK : MAXVEC*(MAXVEC+1)/2 4326* H0SCR : 2*(NP1+NP2) ** 2 + 4 * (NP1+NP2+NQ) 4327* 4328 DIMENSION FINEIG(1) 4329 LOGICAL CONVER,RTCNV(1000) 4330* 4331 EXTERNAL MV7 4332* 4333 TEST = 1.0D-6 4334 IPRT= 1 4335 IF(IPRT.GE.1.and.ga_nodeid().eq.0) THEN 4336 WRITE(6,*) ' MINDV4 in action ' 4337 WRITE(6,*) ' Convergence threshold for residual = ', TEST 4338 END IF 4339* 4340 IOLSTM = IOLSEN 4341 if (ga_nodeid().eq.0) then 4342 IF(IPRT.GT.1.AND.(IOLSEN.NE.0.AND.IPICO.EQ.0)) 4343 & WRITE(6,*) ' Inverse iteration modified Davidson, Variational' 4344 IF(IPRT.GT.1.AND.(IOLSEN.NE.0.AND.IPICO.NE.0)) 4345 & WRITE(6,*) ' Inverse iteration modified Davidson, Perturbational' 4346 IF(IPRT.GT.1.AND.(IOLSEN.EQ.0.AND.IPICO.EQ.0)) 4347 & WRITE(6,*) ' Normal Davidson, Variational ' 4348 IF(IPRT.GT.1.AND.(IOLSEN.EQ.0.AND.IPICO.NE.0)) 4349 & WRITE(6,*) ' Normal Davidson, Perturbational' 4350 endif 4351 IF( MAXVEC .LT. 2 * NROOT ) THEN 4352 WRITE(6,*) ' Sorry MINDV4 wounded , MAXVEC .LT. 2*NROOT ' 4353 STOP ' Enforced stop in MINDV4' 4354 END IF 4355* 4356 IF(IPICO.NE.0) THEN 4357 MAXVEC = 2*NROOT 4358 END IF 4359* 4360 CALL MEMMAN(KAPROJ,MAXVEC*(MAXVEC+1)/2,'ADDL ',2,'KAPROJ') 4361CNW KAPROJ = 1 4362CNW KFREE = KAPROJ+ MAXVEC*(MAXVEC+1)/2 4363 CONVER = .FALSE. 4364 DO 1234 MACRO = 1,1 4365* 4366 CALL LUCIAQENTER('MINDV') 4367*. INITAL ITERATION 4368 ITER = 1 4369CNW CALL REWINO( LU1 ) 4370CNW CALL REWINO( LU2 ) 4371 DO 10 IVEC = 1,NINVEC 4372C? WRITE(6,*) ' Before FRMDSC, NVAR = ', NVAR 4373CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4374 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4375 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4376 if(dra_wait(itask).ne.0) call errquit('dra read err',itask,911) 4377* 4378C? CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4379* 4380 call ga_zero(VEC2) 4381 CALL MV7(VEC1,VEC2,0,0,0,0) 4382CNW CALL TODSC(VEC2,NVAR,-1 ,LU2) 4383! write(*,*) ga_nodeid(), NVAR, IVEC 4384 if (dra_write_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4385 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4386 if(dra_wait(itask).ne.0) call errquit('dra writ err',itask,911) 4387 4388* PROJECTED MATRIX 4389CNW CALL REWINO( LU1) 4390 DO 8 JVEC = 1, IVEC 4391CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4392 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4393 & JVEC,JVEC,itask).ne.0) call errquit('dra error',itask,911) 4394 if (dra_wait(itask).ne.0) call errquit('read',itask,911) 4395 IJ = IVEC*(IVEC-1)/2 + JVEC 4396CNW APROJ(IJ) = INPROD(VEC1,VEC2) 4397 APROJ(IJ) = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4398 & VEC2,'N',1,NVAR,1,1) 4399 8 CONTINUE 4400 10 CONTINUE 4401* 4402 IF( IPRT .GE.10 .and. ga_nodeid().eq.0) THEN 4403 WRITE(6,*) ' INITIAL PROJECTED MATRIX ' 4404 CALL PRSYM(APROJ,NINVEC) 4405 END IF 4406* DIAGONALIZE INITIAL PROJECTED MATRIX 4407 CALL COPVEC(APROJ,dbl_mb(KAPROJ),NINVEC*(NINVEC+1)/2) 4408 CALL EIGENL(dbl_mb(KAPROJ),AVEC,NINVEC,0,1) 4409 DO 20 IROOT = 1, NROOT 4410 EIG(1,IROOT) = dbl_mb(KAPROJ-1+IROOT*(IROOT+1)/2 ) 4411 20 CONTINUE 4412* 4413 IF( IPRT .GE. 3 .and. ga_nodeid().eq.0) THEN 4414 WRITE(6,'(A,I4)') ' Initial set of eigenvalues ' 4415 WRITE(6,'(5F22.13)') 4416 & ( (EIG(ITER,IROOT)+EIGSHF),IROOT=1,NROOT) 4417 END IF 4418*. No root selection here 4419 NVEC = NINVEC 4420 IF (MAXIT .EQ. 1 ) GOTO 901 4421* 4422** LOOP OVER ITERATIONS 4423* 4424 1000 CONTINUE 4425 IF(IPRT .GE. 5 .and. ga_nodeid().eq.0) THEN 4426 WRITE(6,*) ' INFO FORM ITERATION .... ', ITER 4427 END IF 4428 4429 4430 ITER = ITER + 1 4431* 4432** 1 NEW DIRECTION TO BE INCLUDED 4433* 4434* 1.1 : R = H*X - EIGAPR*X 4435 IADD = 0 4436 CONVER = .TRUE. 4437 DO 100 IROOT = 1, NROOT 4438CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4439 call ga_zero(VEC1) 4440* 4441CNW CALL REWINO( LU2) 4442 DO 60 IVEC = 1, NVEC 4443CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPAC) 4444 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4445 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4446 if (dra_wait(itask).ne.0) call errquit('dra read err', 4447 & itask,911) 4448 FACTOR = AVEC((IROOT-1)*NVEC+IVEC) 4449 call ga_add(FACTOR,VEC2,1.0D0,VEC1,VEC1) 4450CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4451 60 CONTINUE 4452 EIGAPR = EIG(ITER-1,IROOT) 4453CNW CALL REWINO( LU1) 4454 DO 50 IVEC = 1, NVEC 4455CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4456 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU1,1,NVAR, 4457 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4458 if (dra_wait(itask).ne.0) call errquit('dra read err', 4459 & itask,911) 4460 FACTOR = -EIGAPR*AVEC((IROOT-1)*NVEC+ IVEC) 4461 call ga_add(FACTOR,VEC2,1.0D0,VEC1,VEC1) 4462CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4463 50 CONTINUE 4464 IF ( IPRT .GE.600 ) THEN 4465 WRITE(6,*) ' ( HX - EX ) ' 4466 call ga_print(VEC1) 4467CNW CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4468 END IF 4469* STRANGE PLACE TO TEST CONVERGENCE , BUT .... 4470CNW RNORM = SQRT( INPROD(VEC1,VEC1,NVAR) ) 4471 RNORM = SQRT( ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4472 & VEC1,'N',1,NVAR,1,1)) 4473 RNRM(ITER-1,IROOT) = RNORM 4474 IF(RNORM.LT. TEST ) THEN 4475 RTCNV(IROOT) = .TRUE. 4476 ELSE 4477 RTCNV(IROOT) = .FALSE. 4478 CONVER = .FALSE. 4479 END IF 4480 IF( ITER .GT. MAXIT) GOTO 100 4481*. 1.2 : MULTIPLY WITH INVERSE HESSIAN APROXIMATION TO GET NEW DIRECTIO 4482 IF( .NOT. RTCNV(IROOT) ) THEN 4483 IADD = IADD + 1 4484CNW CALL REWINO( LUDIA) 4485CNW CALL FRMDSC(VEC2,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 4486 if (dra_read_section(.false.,VEC2,1,NVAR,1,1, 4487 & LUDIA,1,NVAR,1,1,itask).ne.0) 4488 & call errquit('dra error',itask,911) 4489 if (dra_wait(itask).ne.0) call errquit('dra read err', 4490 & itask,911) 4491 CALL H0M1TV(VEC2,VEC1,VEC1,NVAR,NPRDIM,IPNTR, 4492 & H0,-EIGAPR,H0SCR,XDUMMY,NP1,NP2,NQ, 4493 & IPRT) 4494 IF ( IPRT .GE. 600) THEN 4495 WRITE(6,*) ' (D-E)-1 *( HX - EX ) ' 4496 call ga_print(VEC1) 4497CNW CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4498 END IF 4499* 4500 IF(IOLSTM .NE. 0 ) THEN 4501* add Olsen correction if neccessary 4502CNW CALL REWINO(LU3) 4503CNW CALL TODSC(VEC1,NVAR,-1,LU3) 4504 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4505 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4506 if (dra_wait(itask).ne.0) call errquit('dra read err', 4507 & itask,911) 4508* Current eigen vector 4509CNW CALL REWINO( LU1) 4510CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4511 call ga_zero(VEC1) 4512 DO 59 IVEC = 1, NVEC 4513CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4514 if (dra_read_section(.false.,VEC2,1,NVAR,1,1, 4515 & LU1,1,NVAR,IVEC,IVEC,itask).ne.0) 4516 & call errquit('dra error',itask,911) 4517 if (dra_wait(itask).ne.0) call errquit('dra read err', 4518 & itask,911) 4519 FACTOR = AVEC((IROOT-1)*NVEC+ IVEC) 4520CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4521 call ga_add(FACTOR,VEC2,1.0D0,VEC1,VEC1) 4522 59 CONTINUE 4523 IF ( IPRT .GE. 600 ) THEN 4524 WRITE(6,*) ' And X ' 4525CNW CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4526 END IF 4527CNW CALL TODSC(VEC1,NVAR,-1,LU3) 4528 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4529 & 2,2,itask).ne.0) call errquit('dra error',itask,911) 4530 if (dra_wait(itask).ne.0) call errquit('dra read err', 4531 & itask,911) 4532* (H0 - E )-1 * X 4533CNW CALL REWINO( LUDIA) 4534CNW CALL FRMDSC(VEC2,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 4535 if (dra_read_section(.false.,VEC2,1,NVAR,1,1, 4536 & LUDIA,1,NVAR,1,1,itask).ne.0) 4537 & call errquit('dra error',itask,911) 4538 if (dra_wait(itask).ne.0) call errquit('dra read err', 4539 & itask,911) 4540 CALL H0M1TV(VEC2,VEC1,VEC2,NVAR,NPRDIM,IPNTR, 4541 & H0,-EIGAPR,H0SCR,XDUMMY,NP1,NP2,NQ, 4542 & IPRT) 4543CNW CALL TODSC(VEC2,NVAR,-1,LU3) 4544 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4545 & 3,3,itask).ne.0) call errquit('dra error',itask,911) 4546 if (dra_wait(itask).ne.0) call errquit('dra read err', 4547 & itask,911) 4548* Gamma = X(T) * (H0 - E) ** -1 * X 4549CNW GAMMA = INPROD(VEC2,VEC1,NVAR) 4550 GAMMA = ga_ddot_patch(VEC2,'N',1,NVAR,1,1, 4551 & VEC1,'N',1,NVAR,1,1) 4552 4553CBERT: H0M1TV and subsequent DDOT can be combined as we don't need 4554CVEC3(2) anymore after we're done 4555 4556* is X an eigen vector for (H0 - 1 ) - 1 4557 call ga_add(GAMMA,VEC1,-1.0D0,VEC2,VEC2) 4558CNW CALL VECSUM(VEC2,VEC1,VEC2,GAMMA,-1.0D0,NVAR) 4559 VNORM = SQRT(MAX(0.0D0,ga_ddot_patch(VEC2,'N',1,NVAR,1,1, 4560 & VEC2,'N',1,NVAR,1,1))) 4561CNW VNORM = SQRT(MAX(0.0D0,INPROD(VEC2,VEC2,NVAR))) 4562 4563 IF(VNORM .GT. 1.0D-7 ) THEN 4564 IOLSAC = 1 4565 ELSE 4566 IOLSAC = 0 4567 END IF 4568 IF(IOLSAC .EQ. 1 ) THEN 4569 IF(IPRT.GE.10) WRITE(6,*) ' Olsen Correction active ' 4570CNW CALL REWINO(LU3) 4571CNW CALL FRMDSC(VEC2,NVAR,-1,LU3,IMZERO,IAMPACK) 4572 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU3,1,NVAR, 4573 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4574 if (dra_wait(itask).ne.0) call errquit('dra read err', 4575 & itask,911) 4576CNW DELTA = INPROD(VEC1,VEC2,NVAR) 4577 DELTA = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4578 & VEC2,'N',1,NVAR,1,1) 4579CNW CALL FRMDSC(VEC1,NVAR,-1,LU3,IMZERO,IAMPACK) 4580CNW CALL FRMDSC(VEC1,NVAR,-1,LU3,IMZERO,IAMPACK) 4581 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4582 & 3,3,itask).ne.0) call errquit('dra error',itask,911) 4583 if (dra_wait(itask).ne.0) call errquit('dra read err', 4584 & itask,911) 4585 FACTOR = -DELTA/GAMMA 4586 IF(IPRT.GE.10.and.ga_nodeid().eq.0) 4587 & WRITE(6,*) ' DELTA,GAMMA,FACTOR' 4588 IF(IPRT.GE.10.and.ga_nodeid().eq.0) 4589 & WRITE(6,*) DELTA,GAMMA,FACTOR 4590CNW CALL VECSUM(VEC1,VEC1,VEC2,FACTOR,1.0D0,NVAR) 4591 call ga_add(FACTOR,VEC2,1.0D0,VEC1,VEC1) 4592 IF(IPRT.GE.600) THEN 4593 WRITE(6,*) ' Modified new trial vector ' 4594CNW CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4595 call ga_print(VEC1) 4596 END IF 4597 ELSE 4598 IF(IPRT.GT.0.and.ga_nodeid().eq.0) WRITE(6,*) 4599 & ' Inverse correction switched of' 4600CNW CALL REWINO(LU3) 4601CNW CALL FRMDSC(VEC1,NVAR,-1,LU3,IMZERO,IAMPACK) 4602 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4603 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4604 if (dra_wait(itask).ne.0) call errquit('dra read err', 4605 & itask,911) 4606 END IF 4607 END IF 4608*. 1.3 ORTHOGONALIZE TO ALL PREVIOUS VECTORS 4609 XNRMI = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4610 & VEC1,'N',1,NVAR,1,1) 4611CNW XNRMI = INPROD(VEC1,VEC1,NVAR) 4612CNW CALL REWINO( LU1 ) 4613 4614 DO 80 IVEC = 1,NVEC+IADD-1 4615CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4616 if (dra_read_section(.false.,VEC2,1,NVAR,1,1, 4617 & LU1,1,NVAR,IVEC,IVEC,itask).ne.0) 4618 & call errquit('dra error',itask,911) 4619 if (dra_wait(itask).ne.0) call errquit('dra read err', 4620 & itask,911) 4621CNW OVLAP = INPROD(VEC1,VEC2,NVAR) 4622 OVLAP = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4623 & VEC2,'N',1,NVAR,1,1) 4624CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,-OVLAP,NVAR) 4625 call ga_add(-OVLAP,VEC2,1.0D0,VEC1,VEC1) 4626 80 CONTINUE 4627*. 1.4 Normalize vector and check for linear dependency 4628CNW SCALE = INPROD(VEC1,VEC1,NVAR) 4629 SCALE = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4630 & VEC1,'N',1,NVAR,1,1) 4631 IF(ABS(SCALE)/XNRMI .LT. 1.0D-10) THEN 4632*. Linear dependency 4633 IADD = IADD - 1 4634 IF ( IPRT .GE. 10 .and. ga_nodeid().eq.0) THEN 4635 WRITE(6,*) ' Trial vector linear dependent so OUT !!! ' 4636 END IF 4637 ELSE 4638 C1NRM = SQRT(SCALE) 4639 FACTOR = 1.0D0/SQRT(SCALE) 4640CNW CALL SCALVE(VEC1,FACTOR,NVAR) 4641 call ga_scale(VEC1,FACTOR) 4642* 4643CNW CALL TODSC(VEC1,NVAR,-1 ,LU1) 4644 if (dra_write_section(.false.,VEC1,1,NVAR,1,1, 4645 & LU1,1,NVAR,NVEC+IADD,NVEC+IADD,itask).ne.0) 4646 & call errquit('dra error',itask,911) 4647 if (dra_wait(itask).ne.0) call errquit('dra read err', 4648 & itask,911) 4649 IF ( IPRT .GE.600 ) THEN 4650 WRITE(6,*) 'ORTHONORMALIZED (D-E)-1 *( HX - EX ) ' 4651CNW CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 4652 call ga_print(VEC1) 4653 END IF 4654 END IF 4655* 4656 END IF 4657 100 CONTINUE 4658 IF( CONVER ) GOTO 901 4659 IF( ITER.GT. MAXIT) THEN 4660 ITER = MAXIT 4661 GOTO 1001 4662 END IF 4663* 4664** 2 : OPTIMAL COMBINATION OF NEW AND OLD DIRECTION 4665* 4666* 2.1: MULTIPLY NEW DIRECTION WITH MATRIX 4667CNW CALL REWINO( LU1) 4668CNW CALL REWINO( LU2) 4669CNW DO 110 IVEC = 1, NVEC 4670CNW CALL FRMDSC(VEC1,NVAR,-1,LU1,IMZERO,IAMPACK) 4671CNW CALL FRMDSC(VEC1,NVAR,-1,LU2,IMZERO,IAMPACK) 4672CNW 110 CONTINUE 4673* 4674 DO 150 IVEC = 1, IADD 4675CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4676 if (dra_read_section(.false.,VEC1,1,NVAR,1,1, 4677 & LU1,1,NVAR,NVEC+IVEC,NVEC+IVEC,itask).ne.0) 4678 & call errquit('dra error',itask,911) 4679 if (dra_wait(itask).ne.0) call errquit('dra read err', 4680 & itask,911) 4681 CALL MV7(VEC1,VEC2,0,0,0,0) 4682CNW CALL TODSC(VEC2,NVAR,-1 ,LU2) 4683 if (dra_write_section(.false.,VEC2,1,NVAR,1,1, 4684 & LU2,1,NVAR,NVEC+IVEC,NVEC+IVEC,itask).ne.0) 4685 & call errquit('dra error',itask,911) 4686 if(dra_wait(itask).ne.0) call errquit('dra read err',itask,911) 4687* AUGMENT PROJECTED MATRIX 4688CNW CALL REWINO( LU1) 4689 DO 140 JVEC = 1, NVEC+IVEC 4690 IJ = (IVEC+NVEC)*(IVEC+NVEC-1)/2 + JVEC 4691CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4692 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4693 & JVEC,JVEC,itask).ne.0) call errquit('dra error',itask,911) 4694 if (dra_wait(itask).ne.0) call errquit('dra read err', 4695 & itask,911) 4696CNW APROJ(IJ) = INPROD(VEC1,VEC2,NVAR) 4697 APROJ(IJ) = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4698 & VEC2,'N',1,NVAR,1,1) 4699 140 CONTINUE 4700 150 CONTINUE 4701* DIAGONALIZE PROJECTED MATRIX 4702 NVEC = NVEC + IADD 4703 CALL COPVEC(APROJ,dbl_mb(KAPROJ),NVEC*(NVEC+1)/2) 4704 CALL EIGENL(dbl_mb(KAPROJ),AVEC,NVEC,0,1) 4705*. Select if required the roots to be followed 4706 IF(IROOT_SEL.NE.0) THEN 4707 ISEL_MET = IROOT_SEL 4708 if (ga_nodeid().eq.0) WRITE(6,*) ' I will do root selection ' 4709* 4710 IF(IPRT .GE. 30 .and. ga_nodeid().eq.0) THEN 4711 WRITE(6,*) ' Info before selection: ' 4712 WRITE(6,*) ' Projected matrix and eigen vectors ' 4713 CALL PRSYM(APROJ,NVEC) 4714 CALL WRTMAT(AVEC,NVEC,NVEC,NVEC,NVEC) 4715 END IF 4716C SEL_ROOT(SUBSPCVC,SUBSPCMT,ISEL_MET,NVEC,NROOT,LUC,VEC1) 4717 CALL SEL_ROOT(AVEC,dbl_mb(KAPROJ),ISEL_MET,NVEC,NROOT,LU1,VEC1) 4718 END IF 4719 4720 4721 4722 IF(IPICO.NE.0) THEN 4723 E0VAR = dbl_mb(KAPROJ) 4724 C0VAR = AVEC(1) 4725 C1VAR = AVEC(2) 4726*. overwrite with pert solution 4727 AVEC(1) = 1.0D0/SQRT(1.0D0+C1NRM**2) 4728 AVEC(2) = -C1NRM/SQRT(1.0D0+C1NRM**2) 4729 E0PERT = AVEC(1)**2*APROJ(1) 4730 & + 2.0D0*AVEC(1)*AVEC(2)*APROJ(2) 4731 & + AVEC(2)**2*APROJ(3) 4732 dbl_mb(KAPROJ) = E0PERT 4733 if (ga_nodeid().eq.0) then 4734 WRITE(6,*) ' Var and Pert solution, energy and coefficients' 4735 WRITE(6,'(4X,3E15.7)') E0VAR,C0VAR,C1VAR 4736 WRITE(6,'(4X,3E15.7)') E0PERT,AVEC(1),AVEC(2) 4737 endif 4738 END IF 4739 DO 160 IROOT = 1, NROOT 4740 EIG(ITER,IROOT) = dbl_mb(KAPROJ-1+IROOT*(IROOT+1)/2) 4741 160 CONTINUE 4742* 4743 IF(IPRT .GE. 3.and.ga_nodeid().eq.0 ) THEN 4744 WRITE(6,'(A,I4)') ' Eigenvalues of iteration ..', ITER 4745 WRITE(6,'(5F22.13)') 4746 & ( (EIG(ITER,IROOT)+EIGSHF) ,IROOT=1,NROOT) 4747 END IF 4748* 4749 IF( IPRT .GE. 5 .and. ga_nodeid().eq.0) THEN 4750 WRITE(6,*) ' PROJECTED MATRIX AND EIGEN PAIRS ' 4751 CALL PRSYM(APROJ,NVEC) 4752 WRITE(6,'(2X,E13.7)') (EIG(ITER,IROOT),IROOT = 1, NROOT) 4753 CALL WRTMAT(AVEC,NVEC,NROOT,NVEC,NROOT) 4754 END IF 4755* 4756** PERHAPS RESET OR ASSEMBLE CONVERGED EIGENVECTORS 4757* 4758 901 CONTINUE 4759* 4760 IPULAY = 1 4761 IF(IPULAY.EQ.1 .AND. MAXVEC.EQ.3 .AND.NVEC.GE.2. 4762 & .AND. .NOT.CONVER) THEN 4763* Save trial vectors : 1 -- current trial vector 4764* 2 -- previous trial vector orthogonalized 4765CNW CALL REWINO( LU3) 4766CNW CALL REWINO( LU1) 4767*. Current trial vector 4768CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4769 call ga_zero(VEC1) 4770 DO 2200 IVEC = 1, NVEC 4771CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4772 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU1,1,NVAR, 4773 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4774 if (dra_wait(itask).ne.0) call errquit('dra read err', 4775 & itask,911) 4776 FACTOR = AVEC(IVEC) 4777CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4778 call ga_add(FACTOR,VEC2,1.0d0,VEC1,VEC1) 4779 2200 CONTINUE 4780CNW SCALE = INPROD(VEC1,VEC1,NVAR) 4781 SCALE = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4782 & VEC1,'N',1,NVAR,1,1) 4783 SCALE = 1.0D0/SQRT(SCALE) 4784CNW CALL SCALVE(VEC1,SCALE,NVAR) 4785 call ga_scale(VEC1,SCALE) 4786CNW CALL TODSC(VEC1,NVAR,-1 ,LU3) 4787 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4788 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4789 if (dra_wait(itask).ne.0) call errquit('dra read err', 4790 & itask,911) 4791* Previous trial vector orthonormalized 4792CNW CALL REWINO(LU1) 4793CNW CALL FRMDSC(VEC2,NVAR,-1,LU1,IMZERO,IAMPACK) 4794 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU1,1,NVAR, 4795 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4796 if (dra_wait(itask).ne.0) call errquit('dra read err', 4797 & itask,911) 4798CNW OVLAP = INPROD(VEC1,VEC2,NVAR) 4799 OVLAP = ga_ddot_patch(VEC1,'N',1,NVAR,1,1, 4800 & VEC2,'N',1,NVAR,1,1) 4801CNW CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,-OVLAP,NVAR) 4802 call ga_add(-OVLAP,VEC1,1.0d0,VEC2,VEC2) 4803CNW SCALE2 = INPROD(VEC2,VEC2,NVAR) 4804 SCALE2 = ga_ddot_patch(VEC2,'N',1,NVAR,1,1, 4805 & VEC2,'N',1,NVAR,1,1) 4806 SCALE2 = 1.0D0/SQRT(SCALE2) 4807CNW CALL SCALVE(VEC2,SCALE2,NVAR) 4808 call ga_scale(VEC2,SCALE2) 4809CNW CALL TODSC(VEC2,NVAR,-1,LU3) 4810 if (dra_write_section(.false.,VEC2,1,NVAR,1,1,LU3,1,NVAR, 4811 & 2,2,itask).ne.0) call errquit('dra error',itask,911) 4812 if (dra_wait(itask).ne.0) call errquit('dra read err', 4813 & itask,911) 4814* 4815CNW CALL REWINO( LU1) 4816CNW CALL REWINO( LU3) 4817 DO 2411 IVEC = 1,2 4818 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4819 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4820 if (dra_wait(itask).ne.0) call errquit('dra read err', 4821 & itask,911) 4822 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4823 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4824 if (dra_wait(itask).ne.0) call errquit('dra read err', 4825 & itask,911) 4826CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU3,IMZERO,IAMPACK) 4827CNW CALL TODSC (VEC1,NVAR,-1, LU1) 4828 2411 CONTINUE 4829*. Corresponding sigma vectors 4830CNW CALL REWINO ( LU3) 4831CNW CALL REWINO( LU2) 4832CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4833 call ga_zero(VEC1) 4834 DO 2250 IVEC = 1, NVEC 4835 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4836 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4837 if (dra_wait(itask).ne.0) call errquit('dra read err', 4838 & itask,911) 4839CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 4840 FACTOR = AVEC(IVEC) 4841CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4842 call ga_add(FACTOR,VEC2,1.0d0,VEC1,VEC1) 4843 2250 CONTINUE 4844* 4845CNW CALL SCALVE(VEC1,SCALE,NVAR) 4846 call ga_scale(VEC1,SCALE) 4847CNW CALL TODSC(VEC1,NVAR,-1, LU3) 4848 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4849 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4850 if (dra_wait(itask).ne.0) call errquit('dra read err', 4851 & itask,911) 4852* Sigma vector corresponding to second vector on LU1 4853CNW CALL REWINO(LU2) 4854CNW CALL FRMDSC(VEC2,NVAR,-1,LU2,IMZERO,IAMPACK) 4855 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4856 & 1,1,itask).ne.0) call errquit('dra error',itask,911) 4857 if (dra_wait(itask).ne.0) call errquit('dra read err', 4858 & itask,911) 4859CNW CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,-OVLAP,NVAR) 4860 call ga_add(-OVLAP,VEC1,1.0d0,VEC2,VEC2) 4861CNW CALL SCALVE(VEC2,SCALE2,NVAR) 4862 call ga_scale(VEC2,SCALE2) 4863CNW CALL TODSC(VEC2,NVAR,-1,LU3) 4864 if (dra_write_section(.false.,VEC2,1,NVAR,1,1,LU3,1,NVAR, 4865 & 2,2,itask).ne.0) call errquit('dra error',itask,911) 4866 if (dra_wait(itask).ne.0) call errquit('dra read err', 4867 & itask,911) 4868* 4869CNW CALL REWINO( LU2) 4870CNW CALL REWINO( LU3) 4871 DO 2400 IVEC = 1,2 4872 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU3,1,NVAR, 4873 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4874 if (dra_wait(itask).ne.0) call errquit('dra read err', 4875 & itask,911) 4876 if (dra_write_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4877 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4878 if (dra_wait(itask).ne.0) call errquit('dra read err', 4879 & itask,911) 4880CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU3,IMZERO,IAMPACK) 4881CNW CALL TODSC (VEC2,NVAR,-1 ,LU2) 4882 2400 CONTINUE 4883 NVEC = 2 4884* 4885 CALL SETVEC(AVEC,0.0D0,NVEC**2) 4886 DO 2410 IROOT = 1,NVEC 4887 AVEC((IROOT-1)*NVEC+IROOT) = 1.0D0 4888 2410 CONTINUE 4889*.Projected hamiltonian 4890CNW CALL REWINO( LU1 ) 4891 DO 2010 IVEC = 1,NVEC 4892 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4893 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4894 if (dra_wait(itask).ne.0) call errquit('dra read err', 4895 & itask,911) 4896CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4897CNW CALL REWINO( LU2) 4898 DO 2008 JVEC = 1, IVEC 4899CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 4900 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR,IVEC, 4901 & IVEC,itask).ne.0) call errquit('dra error',itask,911) 4902 if (dra_wait(itask).ne.0) call errquit('dra read err', 4903 & itask,911) 4904 IJ = IVEC*(IVEC-1)/2 + JVEC 4905 APROJ(IJ) = ga_ddot(VEC1,VEC2) 4906CNW APROJ(IJ) = INPROD(VEC1,VEC2,NVAR) 4907 2008 CONTINUE 4908 2010 CONTINUE 4909 END IF 4910 IF(NVEC+NROOT.GT.MAXVEC .OR. CONVER .OR. MAXIT .EQ.ITER)THEN 4911CNW CALL REWINO( LU3) 4912 DO 320 IROOT = 1, NROOT 4913CNW CALL REWINO( LU1) 4914CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4915 call ga_zero(VEC1) 4916 DO 200 IVEC = 1, NVEC 4917 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU1,1,NVAR, 4918 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4919 if (dra_wait(itask).ne.0) call errquit('dra read err', 4920 & itask,911) 4921CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 4922 FACTOR = AVEC((IROOT-1)*NVEC+IVEC) 4923CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4924 call ga_add(FACTOR,VEC2,1.0d0,VEC1,VEC1) 4925 200 CONTINUE 4926* 4927CNW SCALE = INPROD(VEC1,VEC1,NVAR) 4928 SCALE = ga_ddot_patch(VEC1,'N',1,NVAR,1,1,VEC1,'N',1,NVAR,1,1) 4929 SCALE = 1.0D0/SQRT(SCALE) 4930CNW CALL SCALVE(VEC1,SCALE,NVAR) 4931 call ga_scale(VEC1,SCALE) 4932CNW CALL TODSC(VEC1,NVAR,-1 ,LU3) 4933 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4934 & IROOT,IROOT,itask).ne.0) call errquit('dra error',itask,911) 4935 if (dra_wait(itask).ne.0) call errquit('dra read err', 4936 & itask,911) 4937 320 CONTINUE 4938CNW CALL REWINO( LU1) 4939CNW CALL REWINO( LU3) 4940 DO 411 IVEC = 1,NROOT 4941 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4942 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4943 if (dra_wait(itask).ne.0) call errquit('dra read err', 4944 & itask,911) 4945 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR, 4946 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4947 if (dra_wait(itask).ne.0) call errquit('dra read err', 4948 & itask,911) 4949CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU3,IMZERO,IAMPACK) 4950CNW CALL TODSC (VEC1,NVAR,-1, LU1) 4951 411 CONTINUE 4952* CORRESPONDING SIGMA VECTOR 4953CNW CALL REWINO ( LU3) 4954 DO 329 IROOT = 1, NROOT 4955CNW CALL REWINO( LU2) 4956CNW CALL SETVEC(VEC1,0.0D0,NVAR) 4957 call ga_zero(VEC1) 4958 DO 250 IVEC = 1, NVEC 4959 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4960 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4961 if (dra_wait(itask).ne.0) call errquit('dra read err', 4962 & itask,911) 4963CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 4964 FACTOR = AVEC((IROOT-1)*NVEC+IVEC) 4965CNW CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,FACTOR,NVAR) 4966 call ga_add(FACTOR,VEC2,1.0d0,VEC1,VEC1) 4967 250 CONTINUE 4968* 4969CNW CALL SCALVE(VEC1,SCALE,NVAR) 4970 call ga_scale(VEC1,SCALE) 4971CNW CALL TODSC(VEC1,NVAR,-1, LU3) 4972 if (dra_write_section(.false.,VEC1,1,NVAR,1,1,LU3,1,NVAR, 4973 & IROOT,IROOT,itask).ne.0) call errquit('dra error',itask,911) 4974 if (dra_wait(itask).ne.0) call errquit('dra read err', 4975 & itask,911) 4976 329 CONTINUE 4977* PLACE C IN LU1 AND HC IN LU2 4978CNW CALL REWINO( LU2) 4979CNW CALL REWINO( LU3) 4980 DO 400 IVEC = 1,NROOT 4981 if (dra_read_section(.false.,VEC2,1,NVAR,1,1,LU3,1,NVAR, 4982 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4983 if (dra_wait(itask).ne.0) call errquit('dra read err', 4984 & itask,911) 4985 if (dra_write_section(.false.,VEC2,1,NVAR,1,1,LU2,1,NVAR, 4986 & IVEC,IVEC,itask).ne.0) call errquit('dra error',itask,911) 4987 if (dra_wait(itask).ne.0) call errquit('dra read err', 4988 & itask,911) 4989CNW CALL FRMDSC(VEC2,NVAR,-1 ,LU3,IMZERO,IAMPACK) 4990CNW CALL TODSC (VEC2,NVAR,-1 ,LU2) 4991 400 CONTINUE 4992 NVEC = NROOT 4993* 4994 CALL SETVEC(AVEC,0.0D0,NVEC**2) 4995 DO 410 IROOT = 1,NROOT 4996 AVEC((IROOT-1)*NROOT+IROOT) = 1.0D0 4997 410 CONTINUE 4998* 4999 CALL SETVEC(APROJ,0.0D0,NVEC*(NVEC+1)/2) 5000 DO 420 IROOT = 1, NROOT 5001 APROJ(IROOT*(IROOT+1)/2 ) = EIG(ITER,IROOT) 5002 420 CONTINUE 5003C 5004 END IF 5005C 5006C IF( ITER .LT. MAXIT .AND. .NOT. CONVER) GOTO 1000 5007 IF( ITER .LE. MAXIT .AND. .NOT. CONVER) GOTO 1000 5008 1001 CONTINUE 5009*. Place first eigenvector in vec1 5010CNW CALL REWINO(LU1) 5011CNW CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 5012 if (dra_read_section(.false.,VEC1,1,NVAR,1,1,LU1,1,NVAR,1,1, 5013 & itask).ne.0) call errquit('dra error',itask,911) 5014 if (dra_wait(itask).ne.0) call errquit('dra read err', 5015 & itask,911) 5016 5017* ( End of loop over iterations ) 5018* 5019* 5020* 5021 IF( .NOT. CONVER ) THEN 5022* CONVERGENCE WAS NOT OBTAINED 5023 IF(IPRT .GE. 2 .and. ga_nodeid().eq.0) 5024 & WRITE(6,1170) MAXIT 5025 1170 FORMAT('0 Convergence was not obtained in ',I3,' iterations') 5026 ELSE 5027* CONVERGENCE WAS OBTAINED 5028 ITER = ITER - 1 5029 IF (IPRT .GE. 2 .and. ga_nodeid().eq.0) 5030 & WRITE(6,1180) ITER 5031 1180 FORMAT(1H0,' Convergence was obtained in ',I3,' iterations') 5032 END IF 5033*. Final eigenvalues 5034 DO 1601 IROOT = 1, NROOT 5035 FINEIG(IROOT) = EIG(ITER,IROOT)+EIGSHF 5036 RNRM_CNV(IROOT) = RNRM(ITER,IROOT) 5037 1601 CONTINUE 5038* 5039 IF ( IPRT .GT. 1 ) THEN 5040 DO 1600 IROOT = 1, NROOT 5041 if (ga_nodeid().eq.0) then 5042 WRITE(6,*) 5043 WRITE(6,'(A,I3)') 5044 & ' Information about convergence for root... ' ,IROOT 5045 WRITE(6,*) 5046 & '============================================' 5047 WRITE(6,*) 5048 WRITE(6,1190) FINEIG(IROOT) 5049 1190 FORMAT(' The final approximation to eigenvalue ',F18.10) 5050 endif 5051 IF(IPRT.GE.1000) THEN 5052 WRITE(6,1200) 5053 1200 FORMAT(1H0,'The final approximation to eigenvector') 5054cVOG CALL REWINO( LU1) 5055cVOG CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 5056 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 5057 END IF 5058 if (ga_nodeid().eq.0) then 5059 WRITE(6,1300) 5060 1300 FORMAT(1H0,' Summary of iterations ',/,1H 5061 + ,' ----------------------') 5062 WRITE(6,1310) 5063 1310 FORMAT 5064 & (1H0,' Iteration point Eigenvalue Residual ') 5065 DO 1330 I=1,ITER 5066 1330 WRITE(6,1340) I,EIG(I,IROOT)+EIGSHF,RNRM(I,IROOT) 5067 1340 FORMAT(1H ,6X,I4,8X,F20.13,2X,E12.5) 5068 endif 5069 1600 CONTINUE 5070 END IF 5071* 5072 IF(IPRT .EQ. 1 ) THEN 5073 DO 1607 IROOT = 1, NROOT 5074 if(ga_nodeid().eq.0) WRITE(6,'(A,2I3,E13.6,2E10.3)') 5075 & ' >>> CI-OPT Iter Root E g-norm g-red', 5076 & ITER,IROOT,FINEIG(IROOT), 5077 & RNRM(ITER,IROOT), 5078 & RNRM(1,IROOT)/RNRM(ITER,IROOT) 5079 1607 CONTINUE 5080 END IF 5081 1234 CONTINUE 5082C 5083 CALL LUCIAQEXIT('MINDV') 5084 RETURN 5085 1030 FORMAT(1H0,2X,7F15.8,/,(1H ,2X,7F15.8)) 5086 1120 FORMAT(1H0,2X,I3,7F15.8,/,(1H ,5X,7F15.8)) 5087 END 5088 SUBROUTINE MINGCG(MV8,LU1,LU2,LU3,LUDIA,VEC1,VEC2, 5089 & MAXIT,CONVER,TEST,W,ERROR,NVAR, 5090 & LUPROJ,IPRT) 5091* 5092* Solve set of linear equations 5093* 5094* AX = B 5095* 5096* with preconditioned conjugate gradient method for 5097* case where two complete vectors can be stored in core 5098* 5099* Initial appriximation to solution must reside on LU1 5100* LU2 must contain B.All files are overwritten 5101* 5102* 5103* Final solution vector is stored in LU1 5104* A scalar w can be added to the diagonal of the preconditioner 5105* 5106* If LUPROJ .NE. 0 , the optimization subspace is restricted to be orthogonal 5107* to the first vector in LUPROJ. 5108 IMPLICIT REAL*8(A-H,O-Z) 5109 DIMENSION VEC1(*),VEC2(*),ERROR(MAXIT+1) 5110 REAL*8 INPROD 5111 LOGICAL CONVER 5112* 5113 EXTERNAL MV8 5114* 5115 CONVER = .FALSE. 5116 ITER = 1 5117 NTEST = 0 5118 NTEST = MAX(NTEST,IPRT) 5119* 5120* ============= 5121* Initial point 5122* ============= 5123* 5124*.R = B - (A)*X 5125 CALL REWINO(LU1) 5126 CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 5127 CALL MV8(VEC1,VEC2,0,0) 5128 CALL REWINO(LU2) 5129 CALL FRMDSC(VEC1,NVAR,-1 ,LU2,IMZERO,IAMPACK) 5130 CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,-1.0D0,NVAR) 5131* 5132 RNORM = SQRT( INPROD(VEC1,VEC1,NVAR) ) 5133 ERROR(1) = RNORM 5134 CALL REWINO(LU2) 5135 CALL TODSC(VEC1,NVAR,-1 ,LU2) 5136*. Preconditioner H times initial vector , H * R 5137*.H * R 5138 CALL REWINO(LUDIA) 5139 CALL FRMDSC(VEC2,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 5140 CALL DIAVC2(VEC2,VEC1,VEC2,W,NVAR) 5141 IF(LUPROJ.NE.0) THEN 5142 CALL REWINO(LUPROJ) 5143 CALL FRMDSC(VEC1,NVAR,-1,LUPROJ,IMZERO,IAMPACK) 5144 OVLAP = INPROD(VEC1,VEC2,NVAR) 5145 CALL VECSUM(VEC2,VEC2,VEC1,1.0D0,-OVLAP,NVAR) 5146 CALL REWINO(LU2) 5147 CALL FRMDSC(VEC1,NVAR,-1,LU2,IMZERO,IAMPACK) 5148 END IF 5149*. GAMMA = <R!H!R> 5150 GAMMA = INPROD(VEC1,VEC2,NVAR) 5151*. P = RHO * H*R 5152 RHO = 1.0D0 5153 CALL SCALVE(VEC2,RHO,NVAR) 5154 CALL REWINO(LU3) 5155 CALL TODSC(VEC2,NVAR,-1 ,LU3) 5156 CALL COPVEC(VEC2,VEC1,NVAR) 5157*.S = AP 5158 CALL MV8(VEC1,VEC2,0,0) 5159 CALL REWINO (LU3) 5160 CALL FRMDSC(VEC1,NVAR,-1,LU3,IMZERO,IAMPACK) 5161* 5162* ==================== 5163* Loop over iterations 5164* ==================== 5165* 5166 NITER = 0 5167 DO 1000 ITER = 1, MAXIT 5168*. P is assumed in VEC1 and S = A*P in VEC2 5169 5170 NITER = NITER + 1 5171 IF ( NTEST .GE. 10 ) 5172 & WRITE(6,*) ' INFORMATION FROM ITERATION... ',ITER 5173*. D = <P!S> 5174 D = INPROD(VEC1,VEC2,NVAR) 5175 C = RHO * GAMMA 5176 A = C/D 5177*. R = R - A * S 5178 CALL REWINO(LU2) 5179 CALL FRMDSC(VEC1,NVAR,-1 ,LU2,IMZERO,IAMPACK) 5180 CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,-A,NVAR) 5181 CALL REWINO(LU2) 5182 CALL TODSC(VEC1,NVAR,-1 ,LU2) 5183*. new residual has been obtained , check for convergence 5184 RNORM = INPROD(VEC1,VEC1,NVAR) 5185 ERROR(ITER+1) = SQRT(RNORM) 5186*. X = X + A * P 5187 CALL REWINO(LU1) 5188 CALL FRMDSC(VEC2,NVAR,-1 ,LU1,IMZERO,IAMPACK) 5189 CALL REWINO(LU3) 5190 CALL FRMDSC(VEC1,NVAR,-1 ,LU3,IMZERO,IAMPACK) 5191 CALL VECSUM(VEC1,VEC2,VEC1,1.0D0,A,NVAR) 5192 CALL REWINO(LU1) 5193 CALL TODSC(VEC1,NVAR,-1 ,LU1) 5194* 5195 IF( SQRT(RNORM) .LT. TEST ) THEN 5196 CONVER = .TRUE. 5197 GOTO 1001 5198 ELSE 5199 CONVER = .FALSE. 5200* 5201* ============================ 5202*. Prepare for next iteration 5203* ============================ 5204* 5205*. H * R 5206 CALL REWINO(LU2) 5207 CALL FRMDSC(VEC2,NVAR,-1 ,LU2,IMZERO,IAMPACK) 5208 CALL REWINO(LUDIA) 5209 CALL FRMDSC(VEC1,NVAR,-1 ,LUDIA,IMZERO,IAMPACK) 5210 CALL DIAVC2(VEC1,VEC2,VEC1 ,W,NVAR) 5211 IF(LUPROJ.NE.0) THEN 5212 CALL REWINO(LUPROJ) 5213 CALL FRMDSC(VEC2,NVAR,-1,LUPROJ,IMZERO,IAMPACK) 5214 OVLAP = INPROD(VEC1,VEC2,NVAR) 5215 CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,-OVLAP,NVAR) 5216 CALL REWINO(LU2) 5217 CALL FRMDSC(VEC2,NVAR,-1,LU2,IMZERO,IAMPACK) 5218 END IF 5219 GAMMA = INPROD(VEC1,VEC2,NVAR) 5220 B = GAMMA/C 5221*. P = RHO*(H*R + B*P) 5222 CALL REWINO(LU3) 5223 CALL FRMDSC(VEC2,NVAR,-1 ,LU3,IMZERO,IAMPACK) 5224 CALL VECSUM(VEC1,VEC1,VEC2,1.0D0,B,NVAR) 5225*. Define next RHO 5226 RHO = 1.0D0 5227 CALL SCALVE(VEC1,RHO,NVAR) 5228 CALL REWINO(LU3) 5229 CALL TODSC(VEC1,NVAR,-1 ,LU3) 5230*. S = MATRIX * P 5231 CALL MV8(VEC1,VEC2,0,0) 5232 CALL REWINO(LU3) 5233 CALL FRMDSC(VEC1,NVAR,-1 ,LU3,IMZERO,IAMPACK) 5234*.End of prepations for next iteration 5235 END IF 5236* 5237* 5238 1000 CONTINUE 5239 1001 CONTINUE 5240 IF(NTEST .GT. 0 ) THEN 5241 IF(CONVER) THEN 5242 WRITE(6,1010) NITER ,ERROR(NITER+1) 5243 1010 FORMAT(1H0,' convergence was obtained in...',I3,' iterations',/, 5244 + 1H ,' norm of residual..............',F13.8) 5245 ELSE 5246 WRITE(6,1020) MAXIT ,ERROR(MAXIT +1 ) 5247 1020 FORMAT(1H0,' convergence was not obtained in',I3,'iterations',/, 5248 + 1H ,' norm of residual...............',F13.8) 5249 END IF 5250 END IF 5251C 5252 IF(NTEST.GT. 50 ) THEN 5253 WRITE(6,1025) 5254 1025 FORMAT(1H0,' solution to set of linear equations') 5255 CALL REWINO(LU1) 5256 CALL FRMDSC(VEC1,NVAR,-1 ,LU1,IMZERO,IAMPACK) 5257 CALL WRTMAT(VEC1,1,NVAR,1,NVAR) 5258C? write(6,*) ' Matrix times solutiom through another cal to MV 8' 5259C? CALL MV8(VEC1,VEC2,0,0) 5260C? call wrtmat(vec2,1,nvar,1,nvar) 5261 END IF 5262C 5263 IF(NTEST.GT.0) THEN 5264 WRITE(6,1040) 5265 1040 FORMAT(1H0,10X,'iteration point norm of residual') 5266 DO 350 I=1,NITER+1 5267 II=I-1 5268 WRITE(6,1050)II,ERROR(I) 5269 1050 FORMAT(1H ,12X,I5,13X,E15.8) 5270 350 CONTINUE 5271 END IF 5272C 5273 RETURN 5274 END 5275 SUBROUTINE MINPRD(VU,A,VI,IP,NPROD,NROW) 5276* 5277* VU(I) = SUM(J) A(J,IP(I))*VI(J) 5278* 5279 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5280 DIMENSION VU(*),A(NROW,*),VI(*),IP(*) 5281*. Loop structure for IBM 3090 5282 CALL SETVEC(VU,0.0D0,NPROD) 5283 DO 50 J = 1, NROW 5284 DO 100 I = 1, NPROD 5285 VU(I) = VU(I) + A(J,IP(I))*VI(J) 5286 100 CONTINUE 5287 50 CONTINUE 5288* 5289 RETURN 5290 END 5291 SUBROUTINE MSAXPY(AX,A,X,TEST,NDIM,NVEC,INDEX,NVCEFF) 5292* 5293* AX(I) = SUM(L=1,NVEC) A(L)*X(I,INDEX(L)) 5294* 5295* New version with seperate treatment of small loop lengths 5296* IBM 3090 VERSION 5297* 5298* Jeppe Olsen , Spring of 1990 5299* 5300 5301 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5302 DIMENSION AX(*),X(NDIM,*) 5303 DIMENSION A(*) ,INDEX(*) 5304* 5305 IF(NDIM.EQ.1) THEN 5306*. Loop length 1 5307 X1 = 0.0D0 5308 DO 11 L = 1, NVCEFF 5309 X1 = X1 + A(L)*X(1,INDEX(L)) 5310 11 CONTINUE 5311 AX(1) = X1 5312 RETURN 5313 ELSE IF(NDIM.EQ.2) THEN 5314*. Loop length 2 5315 X1 = 0.0D0 5316 X2 = 0.0D0 5317 DO 12 L = 1, NVCEFF 5318 X1 = X1 + A(L)*X(1,INDEX(L)) 5319 X2 = X2 + A(L)*X(2,INDEX(L)) 5320 12 CONTINUE 5321 AX(1) = X1 5322 AX(2) = X2 5323 RETURN 5324 ELSE IF(NDIM.EQ.3) THEN 5325*. Loop length 3 5326 X1 = 0.0D0 5327 X2 = 0.0D0 5328 X3 = 0.0D0 5329 DO 13 L = 1, NVCEFF 5330 X1 = X1 + A(L)*X(1,INDEX(L)) 5331 X2 = X2 + A(L)*X(2,INDEX(L)) 5332 X3 = X3 + A(L)*X(3,INDEX(L)) 5333 13 CONTINUE 5334 AX(1) = X1 5335 AX(2) = X2 5336 AX(3) = X3 5337 RETURN 5338 ELSE IF(NDIM.EQ.4) THEN 5339*. Loop length 4 5340 X1 = 0.0D0 5341 X2 = 0.0D0 5342 X3 = 0.0D0 5343 X4 = 0.0D0 5344 DO 14 L = 1, NVCEFF 5345 X1 = X1 + A(L)*X(1,INDEX(L)) 5346 X2 = X2 + A(L)*X(2,INDEX(L)) 5347 X3 = X3 + A(L)*X(3,INDEX(L)) 5348 X4 = X4 + A(L)*X(4,INDEX(L)) 5349 14 CONTINUE 5350 AX(1) = X1 5351 AX(2) = X2 5352 AX(3) = X3 5353 AX(4) = X4 5354 RETURN 5355 ELSE IF( NDIM .GE.5) THEN 5356*. Loop length atleast 5 5357 DO 100 I = 1, NDIM 5358 T = 0.0D0 5359 DO 80 L = 1,NVCEFF 5360 T = T + A(L)*X(I,INDEX(L)) 5361 80 CONTINUE 5362 AX(I) = T 5363 100 CONTINUE 5364 RETURN 5365 END IF 5366* 5367 END 5368 5369 5370 5371 SUBROUTINE MVCSMD(LUIN,FAC,LUOUT,LUSCR,VEC1,VEC2,NVEC,IREW,LBLK) 5372C 5373C ADD VECTORS ON FILE LUIN TIMES FACTOR AND STORE ON LUOUT 5374C 5375C LUOUT AND LUSCR ARE INITIALLY REWINDED 5376C 5377 IMPLICIT DOUBLE PRECISION ( A-H,O-Z) 5378 DIMENSION VEC1(1),VEC2(1) 5379 DIMENSION FAC(1) 5380C 5381 IF( MOD(NVEC,2) .EQ. 0 ) THEN 5382 LLUOUT = LUSCR 5383 LLUSCR = LUOUT 5384 ELSE 5385 LLUOUT = LUOUT 5386 LLUSCR = LUSCR 5387 END IF 5388C 5389 IF(IREW .NE. 0 ) CALL REWINE(LUIN,LBLK) 5390C 5391 DO 100 IVEC = 1, NVEC 5392 CALL REWINE(LLUSCR,LBLK) 5393 CALL REWINE(LLUOUT,LBLK) 5394 IF( IVEC .EQ. 1 ) THEN 5395 CALL SCLVCD(LUIN,LLUOUT,FAC(IVEC),VEC1,0,LBLK) 5396 ELSE 5397 CALL VECSMD(VEC1,VEC2,FAC(IVEC),1.0D0,LUIN,LLUSCR,LLUOUT, 5398 & 0,LBLK) 5399 END IF 5400C 5401 LBUF = LLUOUT 5402 LLUOUT = LLUSCR 5403 LLUSCR = LBUF 5404 100 CONTINUE 5405C 5406 RETURN 5407 END 5408 SUBROUTINE NEWDIR(D,X,G,DIAG,E,NVAR,NPRDIM,IPNTR,PEIGVL,PEIGVC, 5409 & INVCOR,WORK) 5410* 5411* Calculate 5412* 5413* D = (H0-E)** (-1) * G (INVCOR = 0 ) 5414* 5415* D = (H0-E)** (-1) * G - ALPHA * (H0 - E)**(-1) * X 5416* 5417* ALPHA = X(T)(H0-E)**(-1)*D / X(T)(H0-E)**(-1)*X (INVCOR .NE.0) 5418* 5419* The latter correction corresponds to inverse iteration 5420* correction to Davidson 5421* 5422* Where H0 consists of a diagonal Diag 5423* and a block matrix of dimension NPRDIM. 5424* 5425* The block matrix is defined by 5426* ============================== 5427* 5428* NPRDIM : Size of block matrix 5429* IPNTR(I) : Scatter array, gives adress of subblock element 5430* I in full matrix 5431* PEIGVL : Eigenvalues of subblock mateix 5432* PEIGVC : Eigenvectors of subblock matrix 5433* 5434* Input 5435*======= 5436* X : for eigenvalue problem X is current eigenvector 5437* (for INVCOR = 0 X can be a dummy variable ) 5438* G : for eigenvalue problem G = (H - E ) * X 5439* Diag : Diaginal of matrix 5440* E : Energy for shift 5441* NVAR : Dimension of full matrix 5442* NPRDIM,IPNTR,PEIGVL,PEIGVC : See above 5443* INVCOR : use(.NE.0) , do not use (.eq.0) inverse correction 5444* Modification 5445* Work : Scratch space , at least ?? 5446* 5447* Output 5448* ====== 5449* D as given above, code has been constructed so D 5450* can occupy the same place as either X,G,DIAG 5451* 5452* Scratch space 5453*=============== 5454* Should at least be of length ??? 5455* 5456* Externals GPRCTV,INPROD 5457*=========== 5458* 5459 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5460 REAL*8 INPROD 5461* 5462 DIMENSION D(*) 5463 DIMENSION X(*),G(*),DIAG(*) 5464 DIMENSION IPNTR(*),PEIGVL(*),PEIGVC(*) 5465 DIMENSION WORK(*) 5466* 5467 NTEST = 0 5468 IF(NTEST.GE.10) THEN 5469 WRITE(6,*) ' Information from NEWDIR ' 5470 WRITE(6,*) ' ========================' 5471 END IF 5472 IF( INVCOR .EQ. 0 ) THEN 5473* (H0 - E ) **(-1) * G , store in D 5474C SUBROUTINE GPRCTV(DIAG,VECIN,VECUT,NVAR,NPRDIM,IPNTR, 5475C & PEIGVL,PEIGVC,SHIFT,WORK) 5476 CALL GPRCTV(DIAG,G,D,NVAR,NPRDIM,IPNTR,PEIGVL,PEIGVC, 5477 & -E,WORK,XDUMMY) 5478 ELSE 5479* (H0 - E ) **(-1) * G , store in G 5480 CALL GPRCTV(DIAG,G,G,NVAR,NPRDIM,IPNTR,PEIGVL,PEIGVC, 5481 & -E,WORK,XDUMMY) 5482* X(T) (H0 - E) ** (-1) X 5483 XH0MEG = INPROD(X,G,NVAR) 5484C? write(6,*) ' XH0MEG ', XH0MEG 5485* (H0 - E ) **(-1) * X , store in X 5486 CALL GPRCTV(DIAG,X,X,NVAR,NPRDIM,IPNTR,PEIGVL,PEIGVC, 5487 & -E,WORK,XH0MEX) 5488C? write(6,*) ' XH0MEX ', XH0MEX 5489* 5490 FACTOR = -XH0MEG/XH0MEX 5491 CALL VECSUM(D,G,X,1.0D0,FACTOR,NVAR) 5492C? write(6,*) ' New direction ' 5493C? call wrtmat(D,1,NVAR,1,NVAR) 5494 END IF 5495* 5496 RETURN 5497 END 5498 SUBROUTINE ONEMAT(A,B,NBAS,N) 5499 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5500C ONEMAT PACK THE UPPER HALF OF A TWO DIM MATRIX 5501C A INTO A ONE DIM MATRIX B 5502 DIMENSION A(NBAS,1),B(1) 5503 DO 100 I=1,N 5504 DO 200 J=1,I 5505 IJ=I*(I-1)/2 + J 5506200 B(IJ)=A(J,I) 5507100 CONTINUE 5508 RETURN 5509 END 5510 SUBROUTINE ORTVCD(LUIN,LUVEC,LUOUT,LUSCR,VEC1,VEC2,NVEC,LBLK, 5511 & SCR,INORMA) 5512* 5513* Orthonormalize vector on file LUIN to NVEC vectors on file LUVEC 5514* and save result on file LUOUT. 5515* If INORMA .ne. 0 the vector is normalized 5516* The transformation vector is returned in SCR 5517* 5518*. All files are rewinded 5519 5520 IMPLICIT DOUBLE PRECISION ( A-H,O-Z) 5521 REAL*8 INPRDD 5522*.Scratch 5523 DIMENSION VEC1(1),VEC2(1) 5524 DIMENSION SCR(1) 5525* 5526 IF(INORMA.NE.0) THEN 5527 IF( MOD(NVEC,2) .EQ. 0 ) THEN 5528 LLUOUT = LUSCR 5529 LLUSCR = LUOUT 5530 ELSE 5531 LLUOUT = LUOUT 5532 LLUSCR = LUSCR 5533 END IF 5534 ELSE IF( INORMA.EQ.0) THEN 5535 IF( MOD(NVEC,2) .EQ. 1 ) THEN 5536 LLUOUT = LUSCR 5537 LLUSCR = LUOUT 5538 ELSE 5539 LLUOUT = LUOUT 5540 LLUSCR = LUSCR 5541 END IF 5542 END IF 5543*.Pass 1 : Obtain overlap vector 5544 CALL REWINE(LUVEC,LBLK) 5545 DO 200 IVEC = 1, NVEC 5546 CALL REWINE(LUIN,LBLK) 5547 SCR(IVEC) = INPRDD(VEC1,VEC2,LUVEC,LUIN,0,LBLK) 5548 200 CONTINUE 5549* Pass 2 : Orthogonalize 5550 CALL COPVCD(LUIN,LLUOUT,VEC1,1,LBLK) 5551 LBUF = LLUOUT 5552 LLUOUT = LLUSCR 5553 LLUSCR = LBUF 5554 CALL REWINE(LUVEC,LBLK) 5555 DO 100 IVEC = 1, NVEC 5556 CALL REWINE(LLUSCR,LBLK) 5557 CALL REWINE(LLUOUT,LBLK) 5558 CALL VECSMD(VEC1,VEC2,SCR(IVEC),1.0D0,LUVEC,LLUSCR,LLUOUT, 5559 & 0,LBLK) 5560 LBUF = LLUOUT 5561 LLUOUT = LLUSCR 5562 LLUSCR = LBUF 5563 100 CONTINUE 5564* 5565 IF(INORMA.NE.0) THEN 5566 XNORM = INPRDD(VEC1,VEC1,LLUSCR,LLUSCR,1,LBLK) 5567 FACTOR = 1.0D0/SQRT(XNORM) 5568C SCLVCD(LUIN,LUOUT,SCALE,SEGMNT,IREW,LBLK) 5569 CALL SCLVCD(LLUSCR,LLUOUT,FACTOR,VEC1,1,LBLK) 5570 CALL SCALVE(SCR,FACTOR,NVEC) 5571 END IF 5572* 5573 RETURN 5574 END 5575 SUBROUTINE OUTPAK(MATRIX,NROW,NCTL) 5576 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5577C...........VERSION = 09/16/73/04 5578C....................................................................... 5579C 5580C OUTPAK PRINTS A REAL SYMMETRIC MATRIX STORED IN ROW-PACKED LOWER 5581C TRIANGULAR FORM (SEE DIAGRAM BELOW) IN FORMATTED FORM WITH NUMBERED 5582C ROWS AND COLUMNS. THE INPUT IS AS FOLLOWS: 5583C 5584C MATRIX(*)...........PACKED MATRIX 5585C NROW................NUMBER OF ROWS TO BE OUTPUT 5586C NCTL................CARRIAGE CONTROL FLAG: 1 FOR SINGLE SPACE, 5587C 2 FOR DOUBLE SPACE, 5588C 3 FOR TRIPLE SPACE. 5589C 5590C THE MATRIX ELEMENTS ARE ARRANGED IN STORAGE AS FOLLOWS: 5591C 5592C 1 5593C 2 3 5594C 4 5 6 5595C 7 8 9 10 5596C 11 12 13 14 15 5597C 16 17 18 19 20 21 5598C 22 23 24 25 26 27 28 5599C 5600C AND SO ON. 5601C 5602C OUTPAK IS SET UP TO HANDLE 8 COLUMNS/PAGE WITH A 8F15.7 FORMAT 5603C FOR THE COLUMNS. IF A DIFFERENT NUMBER OF COLUMNS IS REQUIRED, CHANGE 5604C FORMATS 1000 AND 2000, AND INITIALIZE KCOL WITH THE NEW NUMBER OF 5605C COLUMNS. 5606C 5607C AUTHOR: NELSON H.F. BEEBE, QUANTUM THEORY PROJECT, UNIVERSITY OF 5608C FLORIDA, GAINESVILLE, FLORIDA, AND DIVISION OF THEORETICAL 5609C CHEMISTRY, DEPARTMENT OF CHEMISTRY, AARHUS UNIVERSITY, 5610C AARHUS, DENMARK 5611C 5612C....................................................................... 5613 INTEGER BEGIN,ASA,BLANK,CTL 5614 LOGICAL HEADER 5615 DOUBLE PRECISION MATRIX 5616 DIMENSION MATRIX(1),ASA(3) 5617 DATA KCOL/8/, COLUMN/8HCOLUMN /, ASA/4H ,4H0 ,4H- /, 5618 X BLANK/4H /, ZERO/0.D+00/ 5619 CTL = BLANK 5620 IF ((NCTL.LE.3).AND.(NCTL.GT.0)) CTL = ASA(NCTL) 5621C....................................................................... 5622C 5623C LAST IS THE LAST COLUMN NUMBER IN THE ROW CURRENTLY BEING PRINTED 5624C 5625C....................................................................... 5626 LAST = MIN(NROW,KCOL) 5627C....................................................................... 5628C 5629C BEGIN IS THE FIRST COLUMN NUMBER IN THE ROW CURRENTLY BEING PRINT_D. 5630C 5631C....................................................................... 5632 BEGIN = 1 5633 100 NCOL = 1 5634 NCOL = 1 5635 HEADER = .TRUE. 5636 DO 500 K = BEGIN,NROW 5637 KTOTAL = (K*(K-1))/2 + BEGIN - 1 5638 DO 200 I = 1,NCOL 5639 IF (MATRIX(KTOTAL+I) .NE. ZERO) GO TO 300 5640 200 CONTINUE 5641 GO TO 400 5642 300 IF (HEADER) WRITE (6,10000) (COLUMN,I, I = BEGIN,LAST) 5643 HEADER = .FALSE. 5644 WRITE (6,20000) CTL,K,(MATRIX(KTOTAL+I), I = 1,NCOL) 5645 400 IF (K .LT. (BEGIN+KCOL-1)) NCOL = NCOL + 1 5646 500 CONTINUE 5647 LAST = MIN(LAST+KCOL,NROW) 5648 BEGIN = BEGIN + NCOL 5649 IF (BEGIN .LE. NROW) GO TO 100 5650 RETURN 565110000 FORMAT (1H0,8X,8(5X,A6,I4)) 565220000 FORMAT (A1,4H ROW,I4,8F15.7) 5653 END 5654 SUBROUTINE LUCIAOUTPUT (MATRIX,ROWLOW,ROWHI,COLLOW,COLHI,ROWDIM, 5655 X COLDIM, 5656 X NCTL) 5657 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5658C...........VERSION = 09/16/73/03 5659C....................................................................... 5660C 5661C OUTPUT PRINTS A REAL MATRIX IN FORMATTED FORM WITH NUMBERED ROWS 5662C AND COLUMNS. THE INPUT IS AS FOLLOWS: 5663C 5664C MATRIX(*,*).........MATRIX TO BE OUTPUT 5665C ROWLOW..................ROW NUMBER AT WHICH OUTPUT IS STARTED 5666C ROWHI...............ROW NUMBER AT WHICH OUTPUT IS TO END 5667C COLLOW..............COLUMN NUMBER AT WHICH OUTPUT IS TO BEGIN 5668C COLHI...............COLUMN NUMBER AT WHICH OUTPUT IS TO END 5669C ROWDIM..............ROW DIMENSION OF MATRIX(*,*) 5670C COLDIM..............COLUMN DIMENSION OF MATRIX(*,*) 5671C NCTL................CARRIAGE CONTROL FLAG: 1 FOR SINGLE SPACE 5672C 2 FOR DOUBLE SPACE 5673C 3 FOR TRIPLE SPACE 5674C 5675C THE PARAMETERS THAT FOLLOW MATRIX ARE ALL OF TYPE INTEGER*6*4. THE 5676C PROGRAM IS SET UP TO HANDLE 8 COLUMNS/PAGE WITH A 8F15.7 FORMAT FOR 5677C THE COLUMNS. IF A DIFFERENT NUMBER OF COLUMNS IS REQUIRED, CHANGE 5678C FORMATS 1000 AND 2000, AND INITIALIZE KCOL WITH THE NEW NUMBER OF 5679C COLUMNS. 5680C 5681C AUTHOR: NELSON H.F. BEEBE, QUANTUM THEORY PROJECT, UNIVERSITY OF 5682C FLORIDA, GAINESVILLE, FLORIDA, AND DIVISION OF THEORETICAL 5683C CHEMISTRY, DEPARTMENT OF CHEMISTRY, AARHUS UNIVERSITY, 5684C AARHUS, DENMARK 5685C 5686C....................................................................... 5687 DOUBLE PRECISION MATRIX,COLUMN 5688 INTEGER ROWLOW,ROWHI,COLLOW,COLHI,ROWDIM,COLDIM,BEGIN,ASA,BLANK, 5689 X CTL 5690 LOGICAL HEADER 5691 DIMENSION MATRIX(ROWDIM,COLDIM),ASA(3) 5692 DATA KCOL/8/, COLUMN/8HCOLUMN /, ASA/4H ,4H0 ,4H- /, 5693 X BLANK/4H /, ZERO/0.D+00/ 5694 CTL = BLANK 5695 IF ((NCTL.LE.3).AND.(NCTL.GT.0)) CTL = ASA(NCTL) 5696 IF (ROWHI .LT. ROWLOW) GO TO 500 5697 IF (COLHI .LT. COLLOW) GO TO 500 5698 LAST = MIN(COLHI,COLLOW+KCOL-1) 5699 DO 400 BEGIN = COLLOW,COLHI,KCOL 5700 HEADER = .TRUE. 5701 DO 300 K = ROWLOW,ROWHI 5702 DO 100 I = BEGIN,LAST 5703 IF (MATRIX(K,I) .NE. ZERO) GO TO 200 5704 100 CONTINUE 5705 GO TO 300 5706 200 IF (HEADER) WRITE(6,10000) (COLUMN,I, I = BEGIN,LAST) 5707 HEADER = .FALSE. 5708 WRITE(6,20000) CTL,K,(MATRIX(K,I), I = BEGIN,LAST) 5709 300 CONTINUE 5710 400 LAST = MIN(LAST+KCOL,COLHI) 5711 500 RETURN 571210000 FORMAT (1H0,8X,8(5X,A6,I4)) 571320000 FORMAT (A1,4H ROW,I4,8F15.7) 5714 END 5715 SUBROUTINE PACKDI(A,B,N) 5716 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5717C PACKDI COPY THE DIAGONAL ELEMENTS OF A INTO B 5718 DIMENSION A(1),B(1) 5719 DO 100 I=1,N 5720 II=I*(I+1)/2 5721100 B(I)=A(II) 5722 RETURN 5723 END 5724 SUBROUTINE PACKMT(A,B,NBAS,N) 5725 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5726C PACMMAT PACK A TWO DIM MATRIX THAT IS STORED 5727C AS CULOMN VECTORS IN A ONE DIM ARRAY INTO 5728C A TWO DIM MATRIX. 5729 DIMENSION B(NBAS,1),A(1) 5730 IQ=-N 5731 DO 100 I=1,N 5732 IQ=IQ+N 5733 DO 200 J=1,N 5734 IJ=IQ+J 5735200 B(J,I)=A(IJ) 5736100 CONTINUE 5737 RETURN 5738 END 5739 5740 SUBROUTINE POSIFL(NREC,IFIL) 5741C 5742C POSITION FILE IFIL AT BEGINNING OF RECORD NREC 5743C 5744 CALL REWINO( IFIL ) 5745 ISKIP=NREC-1 5746 IF(ISKIP.NE.0) THEN 5747 DO 100 I=1,ISKIP 5748 READ(IFIL) 5749 100 CONTINUE 5750 END IF 5751C 5752 RETURN 5753 END 5754 SUBROUTINE PRSYM_F7(A,MATDIM) 5755C PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. 5756C THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. 5757 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5758 DIMENSION A(1) 5759 JSTART=1 5760 JSTOP=0 5761 DO 100 I=1,MATDIM 5762 JSTART=JSTART+I-1 5763 JSTOP=JSTOP +I 5764 WRITE(6,1010) I,(A(J),J=JSTART,JSTOP) 5765 100 CONTINUE 5766 RETURN 5767 1010 FORMAT(1H0,2X,I3,10(1X,F7.3),/,(1H ,5X,10(1X,F7.3))) 5768 END 5769 SUBROUTINE PRSYM_EP(A,MATDIM) 5770C PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. 5771C THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. 5772* 5773* Extended precision, E22.15 5774 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5775 DIMENSION A(1) 5776 JSTART=1 5777 JSTOP=0 5778 DO 100 I=1,MATDIM 5779 JSTART=JSTART+I-1 5780 JSTOP=JSTOP +I 5781 WRITE(6,1010) I,(A(J),J=JSTART,JSTOP) 5782 100 CONTINUE 5783 RETURN 5784 1010 FORMAT(1H0,2X,I3,3(1X,E22.15),/,(1H ,5X,3(1X,E22.15))) 5785 END 5786 SUBROUTINE PRSYM(A,MATDIM) 5787C PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. 5788C THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. 5789 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5790 DIMENSION A(1) 5791 JSTART=1 5792 JSTOP=0 5793 DO 100 I=1,MATDIM 5794 JSTART=JSTART+I-1 5795 JSTOP=JSTOP +I 5796 WRITE(6,1010) I,(A(J),J=JSTART,JSTOP) 5797 100 CONTINUE 5798 RETURN 5799 1010 FORMAT(1H0,2X,I3,5(1X,E24.16),/,(1H ,5X,5(1X,E24.16))) 5800 END 5801 SUBROUTINE PRSYM_GEN(A,MATDIM,IROW_OR_COL) 5802C PRINT LOWER HALF OF A SYMMETRIC MATRIX OF DIMENSION MATDIM. 5803C THE LOWER HALF OF THE MATRIX IS SUPPOSED TO BE IN VECTOR A. 5804* 5805* IROW_OR_COL = 1 => Stored rowwise 5806* IROW_OR_COL = 2 => Stored columnwise 5807* 5808 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5809 DIMENSION A(1) 5810* 5811 IF(IROW_OR_COL.EQ.1) THEN 5812 JSTART=1 5813 JSTOP=0 5814 DO 100 I=1,MATDIM 5815 JSTART=JSTART+I-1 5816 JSTOP=JSTOP +I 5817 WRITE(6,1010) I,(A(J),J=JSTART,JSTOP) 5818 100 CONTINUE 5819 ELSE 5820 DO I = 1, MATDIM 5821 WRITE(6,1010) I, (A((J-1)*MATDIM-J*(J-1)/2+I),J=1,I) 5822 END DO 5823 END IF 5824* 5825 1010 FORMAT(1H0,2X,I3,5(1X,E13.7),/,(1H ,5X,5(1X,E13.7))) 5826 RETURN 5827 END 5828 SUBROUTINE REWINE( LU ,LBLK ) 5829* 5830* LBLK .LT. 0 : REWIND SEQ FILE LU WITH FASTIO ROUTINES 5831* LBLK .GE. 0 : rewinf seq file LU with normal REWIND 5832 ICRAY = 1 5833 IF ( ICRAY.EQ.0.AND.LBLK .LT. 0 ) THEN 5834 IDUM = 1 5835 CALL SQFILE(LU,5,IDUM,IDUM) 5836 ELSE 5837 REWIND LU 5838 END IF 5839* 5840 RETURN 5841 END 5842 SUBROUTINE REWINO( LU ) 5843C 5844C REWIND SEQ FILE LU WITH FASTIO ROUTINES 5845C 5846C? WRITE(6,*) ' TO REWIND FILE ',LU 5847 IDUM = 1 5848C CALL SQFILE(LU,5,IDUM,IDUM) 5849 REWIND (LU) 5850C? WRITE(6,*) ' FILE REWOUND ' 5851C 5852 RETURN 5853 END 5854 SUBROUTINE SBINTV(NSBDIM,EIGVC,EIGVL,SHIFT,INDEX,VECI,VECO,X1,X2, 5855 & XHPSX) 5856* 5857* INVERTED SHIFTED SUBSPACE MATRIX TIMES VECTOR 5858* 5859* Last revision, oct 1989 5860* 5861 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5862 DIMENSION EIGVC(NSBDIM,NSBDIM),EIGVL(NSBDIM),INDEX(NSBDIM) 5863 DIMENSION X1(NSBDIM),X2(NSBDIM) 5864 DIMENSION VECI(1),VECO(1) 5865* 5866 CALL GATVEC(X1,VECI,INDEX,NSBDIM) 5867 CALL MATVCB(EIGVC,X1,X2,NSBDIM,NSBDIM,1) 5868 CALL DIAVC3(X1,X2,EIGVL,SHIFT,NSBDIM,XHPSX) 5869 CALL MATVCB(EIGVC,X1,X2,NSBDIM,NSBDIM,0) 5870 CALL SCAVEC(VECO,X2,INDEX,NSBDIM) 5871C 5872 NTEST = 0 5873 IF( NTEST .GE. 2 ) THEN 5874 WRITE(6,*) ' OUTPUT FROM SBINTV, VECTOR IN GATHERED FORM ' 5875 CALL WRTMAT(X1,1,NSBDIM,1,NSBDIM) 5876 END IF 5877C 5878 RETURN 5879 END 5880 SUBROUTINE SCALE2(VECTOR,NDIM,SCALE) 5881C 5882C SCALE VECTOR TO HAVE NORM 1.VECTORS WITH ELEMENTS THAT CANNOT 5883C BE SQARED WITHOUT OVERFLOW CAN BE HANDLED.SCALE FACTOR 5884C IS RETURNED IN SCALE 5885C 5886 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5887 DIMENSION VECTOR(1) 5888C 5889C FIRST FIND GREATEST ELEMENT 5890 GREAT=0.0D0 5891 DO 100 I=1,NDIM 5892 100 IF(ABS(VECTOR(I)).GE.GREAT) GREAT=ABS(VECTOR(I)) 5893C 5894C SCALE DOWN 5895 FACTOR=1.0D0/GREAT 5896 DO 200 I=1,NDIM 5897 200 VECTOR(I)=VECTOR(I)*FACTOR 5898C 5899C NORM OF SCALED VECTOR 5900 FACTOR=0.0D0 5901 DO 300 I=1,NDIM 5902 FACTOR=FACTOR+ VECTOR(I)**2 5903 300 CONTINUE 5904C 5905C THEN NORMALIZE 5906 FACTOR=DSQRT(FACTOR) 5907 DO 400 I=1,NDIM 5908 400 VECTOR(I)=VECTOR(I)/FACTOR 5909C 5910 SCALE=1.0D0/(FACTOR*GREAT) 5911C 5912 RETURN 5913 END 5914 5915 SUBROUTINE SCALVE(VECTOR,FACTOR,NDIM) 5916C 5917C CALCULATE SCALAR(FACTOR) TIMES VECTOR 5918C 5919 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5920 DIMENSION VECTOR(1) 5921 INCLUDE 'rou_stat.inc' 5922C COMMON/ROU_STAT/NCALL_SCALVE,NCALL_SETVEC,NCALL_COPVEC, 5923C & NCALL_MATCG,NCALL_MATCAS,NCALL_ADD_SKAIIB, 5924C & NCALL_GET_CKAJJB, 5925C & XOP_SCALVE,XOP_SETVEC,XOP_COPVEC, 5926C & XOP_MATCG,XOP_MATCAS,XOP_ADD_SKAIIB, 5927C & XOP_GET_CKAJJB 5928C 5929 NCALL_SCALVE = NCALL_SCALVE + 1 5930 XOP_SCALVE = XOP_SCALVE + NDIM 5931* 5932 DO 100 I=1,NDIM 5933 VECTOR(I)=VECTOR(I)*FACTOR 5934 100 CONTINUE 5935C 5936 RETURN 5937 END 5938 SUBROUTINE SSCAVEC(VECO,VECI,INDEX,NDIM) 5939C 5940C SCATTER VECTOR with sign encoded 5941C VECO(ABS(INDEX(I)) = Sign(INDEX(I)*VECI(I) 5942C 5943 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 5944 DIMENSION VECI(1 ),VECO(1),INDEX(1 ) 5945C 5946 DO I = 1, NDIM 5947 IF(INDEX(I).GT.0) THEN 5948 VECO(INDEX(I)) = VECI(I) 5949 ELSE 5950 VECO(-INDEX(I)) = -VECI(I) 5951 END IF 5952 END DO 5953C 5954 RETURN 5955 END 5956 SUBROUTINE SCLVCD(LUIN,LUOUT,SCALE,SEGMNT,IREW,LBLK) 5957C 5958C SCALE VECTOR ON FILE LUIN WITH FACTOR SCALE AND STORE ON LUOUT 5959C 5960C 5961C LBLK DEFINES STRUCTURE OF FILES 5962C 5963 IMPLICIT REAL*8(A-H,O-Z) 5964 DIMENSION SEGMNT(*) 5965C 5966 IF( IREW .NE. 0 ) THEN 5967 IF( LBLK .GE. 0 ) THEN 5968 REWIND LUIN 5969 REWIND LUOUT 5970 ELSE 5971 CALL REWINE( LUIN ,LBLK) 5972 CALL REWINE( LUOUT,LBLK) 5973 END IF 5974 END IF 5975C 5976C LOOP OVER BLOCKS 5977C 5978 1000 CONTINUE 5979 IF ( LBLK .GT. 0 ) THEN 5980 LBL = LBLK 5981 ELSE IF (LBLK .EQ. 0 ) THEN 5982 READ(LUIN) LBL 5983 WRITE(LUOUT) LBL 5984 ELSE IF (LBLK .LT. 0 ) THEN 5985 CALL IFRMDS(LBL,1,-1,LUIN) 5986 CALL ITODS (LBL,1,-1,LUOUT) 5987 END IF 5988C 5989 IF ( LBL .GE. 0 ) THEN 5990 IF( LBLK .GE.0 ) THEN 5991 KBLK = LBL 5992 ELSE 5993 KBLK = -1 5994 END IF 5995C 5996 CALL FRMDSC(SEGMNT,LBL,KBLK,LUIN,IMZERO,IAMPACK) 5997 IF(LBL .GT. 0 ) 5998 & CALL SCALVE(SEGMNT,SCALE,LBL) 5999 CALL TODSC(SEGMNT,LBL,KBLK,LUOUT) 6000 END IF 6001C 6002 IF( LBL .GE. 0 .AND. LBLK .LE. 0) GOTO 1000 6003C 6004 RETURN 6005 END 6006 SUBROUTINE SETDIA(MATRIX,VALUE,NDIM,IPACK) 6007* 6008* Set diagonal elements of matrix MATRIX to VALUE 6009* 6010* IPACK = 0 => full quadratic matrix 6011* IPACK = 1 => lower triangular matrix, row packed 6012* 6013 IMPLICIT REAL*8 (A-H,O-Z) 6014 REAL*8 MATRIX(*) 6015* 6016 IF(IPACK .EQ. 0 ) THEN 6017 DO 100 I=1,NDIM 6018100 MATRIX((I-1)*NDIM+I) = VALUE 6019 ELSE IF (IPACK .EQ. 1 ) THEN 6020 DO 200 I = 1, NDIM 6021 200 MATRIX(I*(I+1)/2) = VALUE 6022 ELSE 6023 WRITE(6,*) ' IPACK called with IPACK = ', IPACK 6024 STOP ' SETDIA ,IPACK out of range ' 6025 END IF 6026* 6027 RETURN 6028 END 6029 SUBROUTINE SETVEC(VECTOR,VALUE,NDIM) 6030C 6031C VECTOR (*) = VALUE 6032C 6033 IMPLICIT REAL*8 (A-H,O-Z) 6034 DIMENSION VECTOR(2) 6035 INCLUDE 'rou_stat.inc' 6036C COMMON/ROU_STAT/NCALL_SCALVE,NCALL_SETVEC,NCALL_COPVEC, 6037C & NCALL_MATCG,NCALL_MATCAS,NCALL_ADD_SKAIIB, 6038C & NCALL_GET_CKAJJB, 6039C & XOP_SCALVE,XOP_SETVEC,XOP_COPVEC, 6040C & XOP_MATCG,XOP_MATCAS,XOP_ADD_SKAIIB, 6041C & XOP_GET_CKAJJB 6042C 6043C 6044 NCALL_SETVEC = NCALL_SETVEC + 1 6045 XOP_SETVEC = XOP_SETVEC + NDIM 6046 DO 10 I=1,NDIM 6047 10 VECTOR(I) = VALUE 6048C 6049 RETURN 6050 END 6051 SUBROUTINE SETVECI(IVECTOR,IVALUE,NDIM) 6052C 6053C VECTOR (*) = VALUE 6054C 6055 IMPLICIT REAL*8 (A-H,O-Z) 6056 DIMENSION IVECTOR(2) 6057 INCLUDE 'rou_stat.inc' 6058C COMMON/ROU_STAT/NCALL_SCALVE,NCALL_SETVEC,NCALL_COPVEC, 6059C & NCALL_MATCG,NCALL_MATCAS,NCALL_ADD_SKAIIB, 6060C & NCALL_GET_CKAJJB, 6061C & XOP_SCALVE,XOP_SETVEC,XOP_COPVEC, 6062C & XOP_MATCG,XOP_MATCAS,XOP_ADD_SKAIIB, 6063C & XOP_GET_CKAJJB 6064C 6065C 6066 NCALL_SETVEC = NCALL_SETVEC + 1 6067 XOP_SETVEC = XOP_SETVEC + NDIM 6068 DO 10 I=1,NDIM 6069 10 IVECTOR(I) = IVALUE 6070C 6071 RETURN 6072 END 6073 6074 SUBROUTINE SKPRC3(IREC,IFILE) 6075C 6076C SKIP IREC RECORDS OF FILE IFILE 6077C 6078 DO 100 I=1,IREC 6079 READ(IFILE) 6080 100 CONTINUE 6081C 6082 RETURN 6083 END 6084 SUBROUTINE SKPVCD(LU,NVEC,SEGMNT,IREW,LBLK) 6085C 6086C SKIP OVER NVEC VECTORS ON FILE LUIN 6087C 6088C LBLK DEFINES STRUCTURE OF FILE 6089C (see note on structure of files ) 6090 IMPLICIT REAL*8(A-H,O-Z) 6091 DIMENSION SEGMNT(*) 6092C 6093 NTEST = 00 6094 IF(NTEST.GE.100) 6095 &WRITE(6,*) ' SKPVCD: LU,NVEC,IREW,LBLK',LU,NVEC,IREW,LBLK 6096 IF( IREW .NE. 0 ) THEN 6097 CALL REWINE(LU ,LBLK) 6098 END IF 6099 DO 1001 IVEC = 1, NVEC 6100 IF(NTEST.GE.100) WRITE(6,*) ' Start IVEC = ', IVEC 6101C 6102C LOOP OVER BLOCKS OF GIVEN VECTOR 6103C 6104 1000 CONTINUE 6105C 6106 IF( LBLK .GT. 0 ) THEN 6107 LBL = LBLK 6108 ELSE IF (LBLK .EQ. 0 ) THEN 6109 READ(LU) LBL 6110 ELSE IF (LBLK .LT. 0 ) THEN 6111 CALL IFRMDS(LBL,1,-1,LU) 6112 END IF 6113C? WRITE(6,*) ' LBL = ', LBL 6114C 6115 IF( LBL .GE. 0 ) THEN 6116 IF(LBLK .GE.0 ) THEN 6117 KBLK = LBLK 6118 ELSE 6119 KBLK = -1 6120 END IF 6121C? WRITE(6,*) 'Before FRMDSC ' 6122 CALL FRMDSC(SEGMNT,LBL,KBLK,LU,IMZERO,IAMPACK) 6123C? WRITE(6,*) ' After Frmdsc ' 6124 END IF 6125 IF( LBL .GE. 0 .AND. LBLK .LE. 0 ) GOTO 1000 6126C? IF(NTEST.GE.100) WRITE(6,*) ' Stop IVEC = ', IVEC 6127 1001 CONTINUE 6128C 6129 RETURN 6130 END 6131 SUBROUTINE SLRMTV(NMAT,NVAR,A,AVEC,NRANK,VECIN,VECOUT,IZERO, 6132 & DISCH,LUHFIL) 6133C CALCULATE PRODUCT OF MATRIX WITH VECTOR 6134C MATRIX IS DEFINED AS A SUM OF NMAT NRANK-MATRICES 6135C 6136C IF DISCH THEN VECTORS ARE ASSUMED STORED ON FILE LUHFIL. LENGTH 6137C OF AVEC MUST THEN AT LEAST BE NRANK*NVAR 6138 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6139 DIMENSION A(*),AVEC(NVAR,*),VECIN(1 ),VECOUT(1 ) 6140 LOGICAL DISCH 6141C 6142 IF ( DISCH ) REWIND LUHFIL 6143C 6144 DO 500 I = 1,NMAT 6145 IF( DISCH) THEN 6146 DO 400 IVEC = 1,NRANK 6147C CALL SQFILE(LUHFIL,2,AVEC(1,IVEC),2*NVAR) 6148 READ(LUHFIL) (AVEC(II,IVEC),II=1,NVAR) 6149 400 CONTINUE 6150 IAVEC = 1 6151 ELSE 6152 IAVEC = (I-1)*NRANK + 1 6153 END IF 6154 IA = (I-1)*NRANK**2 + 1 6155 IF ( I.GT.1) IZERO = 0 6156 CALL LRMTVC(NRANK,NVAR,A(IA),AVEC(1,IAVEC),VECIN,VECOUT,IZERO) 6157 500 CONTINUE 6158C 6159 NTEST = 0 6160 IF (NTEST.NE.0) THEN 6161 WRITE(6,*) ' MATRIX TIMES VECTOR FOR SLRMTVC' 6162 CALL RECPRT(VECOUT,1,NVAR) 6163C CALL WRITVE(VECOUT,NVAR) 6164 END IF 6165C 6166 RETURN 6167 END 6168 6169 SUBROUTINE SWAPVE(VEC1,VEC2,NDIM) 6170C 6171C SWAP ELEMENTS OF VECTORS VEC1 AND VEC2 6172C 6173 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6174 DIMENSION VEC1(1 ) ,VEC2(1 ) 6175 DO 100 I=1,NDIM 6176 BUF=VEC1(I) 6177 VEC1(I)=VEC2(I) 6178 VEC2(I)=BUF 6179 100 CONTINUE 6180C 6181 RETURN 6182 END 6183 SUBROUTINE SYMTVC(A,VECIN,VECOUT,NDIM) 6184C 6185C INPUT : 6186C A : LOWER HALF OF SYMMETRIC MATRIX A 6187C A(I,J) = A((I(I-1)/2+J) (I.GE.J) 6188C VECIN : A VECTOR 6189C NDIM : DIMENSION OF A 6190C OUTPUT : 6191C VECOUT: A*VECIN 6192C 6193 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6194 REAL * 8 INPROD 6195 DIMENSION A(2),VECIN(2),VECOUT(2) 6196C 6197C** 1 : LOWER HALF TIMES VECTOR 6198C 6199 DO 100 I = 1,NDIM 6200 100 VECOUT(I) = INPROD(A((I-1)*I/2+1),VECIN(1),I) 6201C 6202C** 2 : UPPER HALF TIMES VECTOR 6203 DO 200 J = 1,NDIM 6204 JBASE = J*(J-1)/2 6205 VECINJ = VECIN(J) 6206 DO 190 I = 1,(J-1) 6207 VECOUT(I) = VECOUT(I)+ A(JBASE + I)*VECINJ 6208 190 CONTINUE 6209 200 CONTINUE 6210C 6211 NTEST = 0 6212 IF ( NTEST.GT.0) THEN 6213 WRITE(6,*) ' MATRIX TIMES VECTOR FROM SYMTVC ' 6214 CALL WRTMAT(VECOUT,NDIM,1,NDIM,1) 6215 END IF 6216C 6217 RETURN 6218 END 6219*********************************************************************** 6220* * 6221* THIS IS A VERY STUPIDLY CODED PROGRAM FOR TRANSFORMING * 6222* A GENERALIZED EIGENVALUE PROBLEM INTO A NORMAL EIGENVALUE PROBLEM * 6223* * 6224* AUTHOR: M. MASAMURA * 6225* J.COMP.CHEM 9 (1988) 257. * 6226* * 6227* THE ALGORITHM MIGHT BE USEFUL, BUT THE IMPLEMENTION IS FAR FROM * 6228* PREFECT. * 6229* * 6230* THIS CODE HAS BEEN ALMOST DIRECTLY COPIED FROM THE JOURNAL ABOVE * 6231* BY DAGE SUNDHOLM (29.4.1988) * 6232* * 6233*********************************************************************** 6234 6235 SUBROUTINE TRANSH(N,H,S,P,WORK) 6236 IMPLICIT REAL*8 (A-H,O-Z) 6237 6238C Symmetric matrices are assumed 6239C Transform H to H' obtain the transformation matrix P 6240C (HC=ESC) => (H'C'=EC') and (C=PC') 6241 6242C N : Dimension of the problem 6243C H : Hamilton matrix, in H out H' (full matrix) 6244C S : Overlap matrix, in S out I (full matrix) 6245C P : Transformation matrix in trash out P (full matrix) 6246 6247 DIMENSION S(N,N),H(N,N),P(N,N),WORK(N) 6248 6249C Neglect matrix elements less than DEPS 6250 6251 DEPS=0.5D-14 6252 ONE=1.0D0 6253 6254C Set P to unit matrix 6255 6256 CALL SETVEC(P,0.0D0, N ** 2 ) 6257 CALL SETDIA(P,1.0D0,N,0) 6258* 6259C First part of the transformation of the H and P matrices 6260 6261 DO 20 K=1,N-1 6262 DO 20 J=N,K+1,-1 6263 6264 D=S(K,J)/S(K,K) 6265 IF(ABS(D).GT.DEPS) THEN 6266 6267 DO 30 I=K+1,J 626830 S(I,J)=S(I,J)-D*S(K,I) 6269 DO 31 I=K+1,J 627031 H(I,J)=H(I,J)-D*H(K,I) 6271 6272 DO 40 I=1,K 627340 H(I,J)=H(I,J)-D*H(I,K) 6274 6275 DO 50 I=J,N 627650 H(J,I)=H(J,I)-D*H(K,I) 6277 6278 DO 60 I=1,K 627960 P(I,J)=P(I,J)-D*P(I,K) 6280 6281 END IF 628220 CONTINUE 6283 6284C Second part of the transformation obtaining the final H and P matrices 6285C but just the upper triangle. 6286 6287 DO 70 I=1,N 6288 E=SQRT(S(I,I)) 6289 6290 DO 80 J=1,N 629180 H(I,J)=H(I,J)/E 6292 6293 DO 90 J=1,I 629490 H(J,I)=H(J,I)/E 6295 6296 DO 100 J=1,I 6297 P(J,I)=P(J,I)/E 6298100 CONTINUE 629970 CONTINUE 6300 6301C To be sure, copy the upper triangle to the lower triangle 6302C set the S matrix to be unit matrix 6303C (Just in case) 6304 6305 DO 200 I=1,N-1 6306 DO 200 J=I+1,N 6307200 H(J,I)=H(I,J) 6308* 6309 CALL SETVEC(P,0.0D0, N ** 2 ) 6310 CALL SETDIA(P,1.0D0,N,0) 6311* 6312 RETURN 6313 END 6314 SUBROUTINE TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 6315C 6316C ( NOT A SIMPLIFIED VERSION OF TETRAPAK ) 6317C 6318C.. REFORMATING BETWEEN LOWER TRIANGULAR PACKING 6319C AND FULL MATRIX FORM FOR A SYMMETRIC MATRIX 6320C 6321C IWAY =-1 : FULL TO PACKED + SYMMETRIZING 6322C IWAY = 1 : FULL TO PACKED 6323C IWAY = 2 : PACKED TO FULL FORM 6324C 6325 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6326 DIMENSION AUTPAK(MATDIM,MATDIM),APAK(*) 6327C 6328 IF( IWAY .EQ. 1 ) THEN 6329 IJ = 0 6330 DO I = 1,NDIM 6331 DO J = 1, I 6332 APAK(IJ+J) = AUTPAK(J,I) 6333 END DO 6334 IJ = IJ + I 6335 END DO 6336 ELSE IF( IWAY .EQ. -1 ) THEN 6337 IJ = 0 6338 DO I = 1,NDIM 6339 DO J = 1, I 6340 APAK(IJ+J) = 0.5*(AUTPAK(J,I)+AUTPAK(I,J)) 6341 END DO 6342 IJ = IJ + I 6343 END DO 6344 ELSE IF( IWAY .EQ. 2 ) THEN 6345 IJ = 0 6346 DO I = 1,NDIM 6347 DO J = 1, I 6348 AUTPAK(I,J) = APAK(IJ+J) 6349 AUTPAK(J,I) = APAK(IJ+J) 6350 END DO 6351 IJ = IJ + I 6352 END DO 6353 ELSE 6354 STOP 'WHICH WAY? UNKNOWN IWAY IN TRIPAK!' 6355 END IF 6356C 6357 NTEST = 0 6358 IF( NTEST .NE. 0 ) THEN 6359 WRITE(6,*) ' AUTPAK AND APAK FROM TRIPAK ' 6360 CALL WRTMAT(AUTPAK,NDIM,MATDIM,NDIM,MATDIM) 6361 CALL PRSYM(APAK,NDIM) 6362 END IF 6363C 6364 RETURN 6365 END 6366 SUBROUTINE UPTRIPAK(ATRI,AFUL,IWAY,NDIM,NDIMFUL) 6367c 6368c switch between full matrix and upper triangular matrix: 6369c iway = -1 pack and symmetrize 6370c iway = 1 pack 6371c iway = 2 unpack 6372c the algorithm allows for in-place (un)packing, i.e. ATRI and 6373c AFUL may have the same start address 6374c 6375 INCLUDE "implicit.inc" 6376 DIMENSION ATRI(*), AFUL(NDIMFUL,*) 6377 6378 IF (IWAY.EQ.-1) THEN 6379 DO JJ = 1, NDIM 6380 IDXTRI = (JJ-1)*JJ/2 6381 DO II = 1, JJ 6382 ATRI(IDXTRI+II) = 0.5D0*(AFUL(II,JJ)+AFUL(JJ,II)) 6383 END DO 6384 END DO 6385 ELSE IF (IWAY.EQ.1) THEN 6386 DO JJ = 1, NDIM 6387 IDXTRI = (JJ-1)*JJ/2 6388 DO II = 1, JJ 6389 ATRI(IDXTRI+II) = AFUL(II,JJ) 6390 END DO 6391 END DO 6392 ELSE IF (IWAY.EQ.2) THEN 6393 DO JJ = NDIM, 1, -1 6394 IDXTRI = (JJ-1)*JJ/2 6395 DO II = JJ, 1, -1 6396 AFUL(II,JJ) = ATRI(IDXTRI+II) 6397 END DO 6398 END DO 6399 DO JJ = 1, NDIM 6400 IDXTRI = (JJ-1)*JJ/2 6401 DO II = 1, JJ 6402 AFUL(JJ,II) = AFUL(II,JJ) 6403 END DO 6404 END DO 6405 ELSE 6406 WRITE(6,*) 'ILLEGAL VALUE FOR IWAY (',IWAY,')' 6407 STOP 'UPTRIPAK' 6408 END IF 6409 6410 RETURN 6411 END 6412 6413 SUBROUTINE TRNMA2(A,X,SCRA,NDIM,MATDIM,itrans) 6414C 6415C TRANSFORM MATRIX A : if( itrans .eq.1 ) X(TRANS)*A*X 6416c if( itrans .eq.2 ) x * a * x(trans) 6417C A IS OVERWRITTEN BY TRANSFORMED A 6418C 6419 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6420C 6421 DIMENSION A(MATDIM,1),X(MATDIM,1), 6422 + SCRA(MATDIM,1) 6423C 6424C 6425 NTEST=1 6426C 6427 IF(NTEST.GE.3) THEN 6428 WRITE(16,1020) 6429 1020 FORMAT(1H0,'*** OUTPUT FROM TRANMAT') 6430 WRITE(16,1030) 6431 1030 FORMAT(1H0,'A- AND X-MATRIX') 6432C CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM) 6433C CALL WRTMAT(X,NDIM,NDIM,MATDIM,MATDIM) 6434 END IF 6435C 6436 if ( itrans.eq.2) then 6437c sloopy transpose of x 6438 DO 2000 I = 1, NDIM 6439 DO 2000 J = 1, I 6440 BUF = X(I,J) 6441 X(I,J) = X(J,I) 6442 X(J,I) = BUF 6443 2000 CONTINUE 6444 END IF 6445C A*X 6446 DO 1000 I=1,NDIM 6447 DO 900 J=1,NDIM 6448 AX=0.0D0 6449 DO 800 K=1,NDIM 6450 AX=AX+A(I,K)*X(K,J) 6451 800 CONTINUE 6452 SCRA(I,J)=AX 6453 900 CONTINUE 6454 1000 CONTINUE 6455C 6456 IF(NTEST.GE.2) THEN 6457 WRITE(16,1040) 6458 1040 FORMAT(1H0,' AX MATRIX') 6459C CALL WRTMAT(SCRA,NDIM,NDIM,MATDIM,MATDIM) 6460 END IF 6461C 6462C X(TRANS)*(A*X) 6463 DO 600 I=1,NDIM 6464 DO 500 J=1,NDIM 6465 XAX=0.0D0 6466 DO 400 K=1,NDIM 6467 XAX=XAX+X(K,I)*SCRA(K,J) 6468 400 CONTINUE 6469 A(I,J)=XAX 6470 500 CONTINUE 6471 600 CONTINUE 6472C 6473 if ( itrans.eq.2) then 6474c sloopy transpose of x 6475 DO 2100 I = 1, NDIM 6476 DO 2100 J = 1, I 6477 BUF = X(I,J) 6478 X(I,J) = X(J,I) 6479 X(J,I) = BUF 6480 2100 CONTINUE 6481 END IF 6482C 6483 IF(NTEST.GE.1) THEN 6484 WRITE(16,1010) 6485 1010 FORMAT(1H0,' TRANSFORMED MATRIX') 6486C CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM) 6487 END IF 6488C 6489 RETURN 6490 END 6491 SUBROUTINE TRNMAT(A,X,SCRA,NDIM,MATDIM) 6492C 6493C TRANSFORM MATRIX A : X(TRANS)*A*X 6494C A IS OVERWRITTREN BY TRANSFORMED A 6495C 6496 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6497 DIMENSION A(MATDIM,1),X(MATDIM,1), 6498 + SCRA(MATDIM,1) 6499C 6500C 6501 NTEST=0 6502C 6503 IF(NTEST.GE.3) THEN 6504 WRITE(6,1020) 6505 1020 FORMAT(1H0,'*** OUTPUT FROM TRANMAT') 6506 WRITE(6,1030) 6507 1030 FORMAT(1H0,'A- AND X-MATRIX') 6508 CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM) 6509 CALL WRTMAT(X,NDIM,NDIM,MATDIM,MATDIM) 6510 END IF 6511C 6512C A*X 6513 DO 1000 I=1,NDIM 6514 DO 900 J=1,NDIM 6515 AX=0.0D0 6516 DO 800 K=1,NDIM 6517 AX=AX+A(I,K)*X(K,J) 6518 800 CONTINUE 6519 SCRA(I,J)=AX 6520 900 CONTINUE 6521 1000 CONTINUE 6522C 6523 IF(NTEST.GE.2) THEN 6524 WRITE(6,1040) 6525 1040 FORMAT(1H0,' AX MATRIX') 6526 CALL WRTMAT(SCRA,NDIM,NDIM,MATDIM,MATDIM) 6527 END IF 6528C 6529C X(TRANS)*(A*X) 6530 DO 600 I=1,NDIM 6531 DO 500 J=1,NDIM 6532 XAX=0.0D0 6533 DO 400 K=1,NDIM 6534 XAX=XAX+X(K,I)*SCRA(K,J) 6535 400 CONTINUE 6536 A(I,J)=XAX 6537 500 CONTINUE 6538 600 CONTINUE 6539C 6540 IF(NTEST.GE.2) THEN 6541 WRITE(6,1010) 6542 1010 FORMAT(1H0,' TRANSFORMED MATRIX') 6543 CALL WRTMAT(A,NDIM,NDIM,MATDIM,MATDIM) 6544 END IF 6545C 6546 RETURN 6547 END 6548 SUBROUTINE TRNSPO(A,MATDIM,NDIM) 6549C 6550C TRANSPOSE MATRIX A 6551C 6552 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6553 DIMENSION A(MATDIM,MATDIM) 6554 DO 100 I=1,NDIM 6555 DO 100 J=1,I-1 6556 BUF=A(I,J) 6557 A(I,J)=A(J,I) 6558 A(J,I)=BUF 6559 100 CONTINUE 6560C 6561 RETURN 6562 END 6563 SUBROUTINE TRPMAT(XIN,NROW,NCOL,XOUT) 6564C 6565C XOUT(I,J) = XIN(J,I) 6566C 6567 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6568 DIMENSION XIN(NROW,NCOL),XOUT(NCOL,NROW) 6569C 6570 DO 200 IROW =1, NROW 6571 DO 100 ICOL = 1, NCOL 6572 XOUT(ICOL,IROW) = XIN(IROW,ICOL) 6573 100 CONTINUE 6574 200 CONTINUE 6575C 6576 RETURN 6577 END 6578 SUBROUTINE TYMPAK(AIN,AOUT,NVAR) 6579C 6580C PACK SYMMETRIC MATRIX AIN TO LOWER TRIANGULAR FORM 6581C FOR REASON OF ADRESSING THE UPPER HALF OF AIN IS USED TO COPY FROM 6582C 6583 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6584 DIMENSION AIN(NVAR,NVAR),AOUT(NVAR) 6585 6586 IJ = 0 6587 DO 100 I = 1, NVAR 6588 DO 100 J = 1, I 6589 IJ = IJ + 1 6590 AOUT(IJ) = AIN(J,I) 6591 100 CONTINUE 6592C 6593 NTEST = 0 6594 IF ( NTEST .NE. 0 ) THEN 6595 WRITE(6,*) ' MATRIX IN EXPANDED AND PACKED FORMAT ' 6596 CALL WRTMAT(AIN,NVAR,NVAR,NVAR,NVAR) 6597 CALL PRSYM(AOUT,NVAR) 6598 END IF 6599C 6600 RETURN 6601 END 6602 SUBROUTINE UTPAK(A,SCR,NDIM,MATDIM,NNDIM) 6603C 6604C OUTPACK PACKED MATRIX A 6605C 6606 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6607 DIMENSION A(1 ),SCR(NDIM,NDIM) 6608C 6609 IJ=0 6610 DO 100 I=1,NDIM 6611 DO 100 J=1,I 6612 IJ=IJ+1 6613 SCR(I,J)=A(IJ) 6614 100 CONTINUE 6615C 6616 IJ=0 6617 DO 150 I=1,MATDIM 6618 DO 150 J=1,MATDIM 6619 IJ=IJ+1 6620 A(IJ)=0.0 6621 150 CONTINUE 6622C 6623 DO 200 I=1,NDIM 6624 DO 200 J=1,I 6625 A((J-1)*MATDIM+I)= SCR(I,J) 6626 A((I-1)*MATDIM+J)= SCR(I,J) 6627 200 CONTINUE 6628C 6629 RETURN 6630 END 6631 FUNCTION VCSMDN(VEC1,VEC2,FAC1,FAC2,LU1,LU2,IREW,LBLK) 6632* 6633* Norm of sum of two vectors residing on disc 6634* 6635 IMPLICIT REAL*8(A-H,O-Z) 6636 DIMENSION VEC1(*),VEC2(*) 6637 REAL*8 INPROD 6638* 6639 XNORM = 0.0D0 6640 IF(IREW .NE. 0 ) THEN 6641 CALL REWINE( LU1,LBLK) 6642 CALL REWINE( LU2,LBLK) 6643 END IF 6644* 6645* LOOP OVER BLOCKS OF VECTOR 6646* 6647 1000 CONTINUE 6648C 6649 IF( LBLK .GT. 0 ) THEN 6650 NBL1 = LBLK 6651 NBL2 = LBLK 6652 ELSE IF(LBLK .EQ. 0 ) THEN 6653 READ(LU1) NBL1 6654 READ(LU2) NBL2 6655 ELSE IF (LBLK .LT. 0 ) THEN 6656 CALL IFRMDS( NBL1,1,-1,LU1) 6657 CALL IFRMDS( NBL2,1,-1,LU2) 6658 END IF 6659 IF( NBL1 .NE. NBL2 ) THEN 6660 WRITE(6,'(A,2I5)') 'DIFFERENT BLOCKSIZES IN VCSMDN ', 6661 & NBL1,NBL2 6662 STOP ' INCOMPATIBLE BLOCKSIZES IN VECSMF ' 6663 END IF 6664C 6665 IF(NBL1 .GE. 0 ) THEN 6666 IF(LBLK .GE.0 ) THEN 6667 KBLK = NBL1 6668 ELSE 6669 KBLK = -1 6670 END IF 6671 CALL FRMDSC(VEC1,NBL1,KBLK,LU1,IMZERO,IAMPACK) 6672 CALL FRMDSC(VEC2,NBL1,KBLK,LU2,IMZERO,IAMPACK) 6673 IF( NBL1 .GT. 0 ) THEN 6674 CALL VECSUM(VEC1,VEC1,VEC2,FAC1,FAC2,NBL1) 6675 XNORM = XNORM + INPROD(VEC1,VEC1,NBL1) 6676 END IF 6677 END IF 6678* 6679 IF(NBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 6680* 6681 VCSMDN = XNORM 6682 RETURN 6683 END 6684 SUBROUTINE VECSMDP(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 6685C 6686C DISC VERSION OF VECSUM : 6687C 6688C ADD BLOCKED VECTORS ON FILES LU1 AND LU2 6689C AND STORE ON LU3 6690* 6691* Packed version, May 1996 6692C 6693C LBLK DEFINES STRUCTURE OF FILE 6694C 6695 IMPLICIT REAL*8(A-H,O-Z) 6696 DIMENSION VEC1(*),VEC2(*) 6697C 6698 IF(IREW .NE. 0 ) THEN 6699 CALL REWINE( LU1,LBLK) 6700 CALL REWINE( LU2,LBLK) 6701 CALL REWINE( LU3,LBLK) 6702 END IF 6703C 6704C LOOP OVER BLOCKS OF VECTOR 6705C 6706 1000 CONTINUE 6707C 6708 IF( LBLK .GT. 0 ) THEN 6709 NBL1 = LBLK 6710 NBL2 = LBLK 6711 ELSE IF(LBLK .EQ. 0 ) THEN 6712 READ(LU1) NBL1 6713 READ(LU2) NBL2 6714 WRITE(LU3) NBL1 6715 ELSE IF (LBLK .LT. 0 ) THEN 6716 CALL IFRMDS( NBL1,1,-1,LU1) 6717 CALL IFRMDS( NBL2,1,-1,LU2) 6718 CALL ITODS ( NBL1,1,-1,LU3) 6719 END IF 6720 IF( NBL1 .NE. NBL2 ) THEN 6721 WRITE(6,'(A,2I5)') 'DIFFERENT BLOCKSIZES IN VECSMDP', 6722 & NBL1,NBL2 6723 STOP ' INCOMPATIBLE BLOCKSIZES IN VECSMF ' 6724 END IF 6725C 6726 IF(NBL1 .GE. 0 ) THEN 6727 IF(LBLK .GE.0 ) THEN 6728 KBLK = NBL1 6729 ELSE 6730 KBLK = -1 6731 END IF 6732 NO_ZEROING = 1 6733 CALL FRMDSC2(VEC1,NBL1,KBLK,LU1,IMZERO1,IAMPACK,NO_ZEROING) 6734 CALL FRMDSC2(VEC2,NBL1,KBLK,LU2,IMZERO2,IAMPACK,NO_ZEROING) 6735 IF( NBL1 .GT. 0 ) THEN 6736 IF(IMZERO1.EQ.1.AND.IMZERO2.EQ.1) THEN 6737*. Simple zero record 6738 CALL ZERORC(NBL1,LU3,IAMPACK) 6739 ELSE 6740*. Nonvanishing record 6741 ZERO = 0.0D0 6742 IF(IMZERO1.EQ.1) THEN 6743 CALL VECSUM(VEC1,VEC1,VEC2,ZERO,FAC2,NBL1) 6744 ELSE IF(IMZERO2.EQ.1) THEN 6745 CALL VECSUM(VEC1,VEC1,VEC2,FAC1,ZERO,NBL1) 6746 ELSE 6747 CALL VECSUM(VEC1,VEC1,VEC2,FAC1,FAC2,NBL1) 6748 END IF 6749 CALL TODSCP(VEC1,NBL1,KBLK,LU3) 6750 END IF 6751 ELSE IF (NBL1.EQ.0) THEN 6752 CALL TODSCP(VEC1,NBL1,KBLK,LU3) 6753 END IF 6754 END IF 6755C 6756 IF(NBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 6757C 6758 RETURN 6759 END 6760 SUBROUTINE VECSMD(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW,LBLK) 6761C 6762C DISC VERSION OF VECSUM : 6763C 6764C ADD BLOCKED VECTORS ON FILES LU1 AND LU2 6765C AND STORE ON LU3 6766C 6767C LBLK DEFINES STRUCTURE OF FILE 6768C 6769 IMPLICIT REAL*8(A-H,O-Z) 6770 DIMENSION VEC1(*),VEC2(*) 6771C 6772C 6773C 6774 IF(IREW .NE. 0 ) THEN 6775 CALL REWINE( LU1,LBLK) 6776 CALL REWINE( LU2,LBLK) 6777 CALL REWINE( LU3,LBLK) 6778 END IF 6779C 6780C LOOP OVER BLOCKS OF VECTOR 6781C 6782 1000 CONTINUE 6783C 6784 IF( LBLK .GT. 0 ) THEN 6785 NBL1 = LBLK 6786 NBL2 = LBLK 6787 ELSE IF(LBLK .EQ. 0 ) THEN 6788 READ(LU1) NBL1 6789 READ(LU2) NBL2 6790 WRITE(LU3) NBL1 6791 ELSE IF (LBLK .LT. 0 ) THEN 6792 CALL IFRMDS( NBL1,1,-1,LU1) 6793 CALL IFRMDS( NBL2,1,-1,LU2) 6794 CALL ITODS ( NBL1,1,-1,LU3) 6795 END IF 6796 IF( NBL1 .NE. NBL2 ) THEN 6797 WRITE(6,'(A,2I10)') 'DIFFERENT BLOCKSIZES IN VECSMD ', 6798 & NBL1,NBL2 6799 WRITE(6,'(A,2I3,A,I3,A)') 6800 & ' UNITS: ',LU1, LU2,'(IN) - ',LU3,' (OUT)' 6801 CALL UNIT_INFO(LU1) 6802 CALL UNIT_INFO(LU2) 6803 CALL UNIT_INFO(LU3) 6804 WRITE(6,*) 'CURRENT SEGMENT WAS ',IBLK 6805 STOP ' INCOMPATIBLE BLOCKSIZES IN VECSMD ' 6806 END IF 6807C 6808 IF(NBL1 .GE. 0 ) THEN 6809 IF(LBLK .GE.0 ) THEN 6810 KBLK = NBL1 6811 ELSE 6812 KBLK = -1 6813 END IF 6814 CALL FRMDSC(VEC1,NBL1,KBLK,LU1,IMZERO,IAMPACK) 6815 CALL FRMDSC(VEC2,NBL1,KBLK,LU2,IMZERO,IAMPACK) 6816 IF( NBL1 .GT. 0 ) 6817 & CALL VECSUM(VEC1,VEC1,VEC2,FAC1,FAC2,NBL1) 6818 6819 IF(IAMPACK.EQ.0) THEN 6820 CALL TODSC(VEC1,NBL1,KBLK,LU3) 6821 ELSE 6822 CALL TODSCP(VEC1,NBL1,KBLK,LU3) 6823 END IF 6824 END IF 6825C 6826 IF(NBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 6827C 6828 RETURN 6829 END 6830 SUBROUTINE VECSMe(VEC1,VEC2,FAC1,FAC2, LU1,LU2,LU3,IREW) 6831C 6832C DISC VERSION OF VECSUM : 6833C 6834C ADD BLOCKED VECTORS ON FILES LU1 AND LU2 6835C AND STORE ON LU3 6836C 6837 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6838 DIMENSION VEC1(*),VEC2(*) 6839C 6840 IF(IREW .NE. 0 ) THEN 6841 CALL REWINO( LU1) 6842 CALL REWINO( LU2) 6843 CALL REWINO( LU3) 6844 END IF 6845C 6846C LOOP OVER BLOCKS OF VECTOR 6847C 6848 1000 CONTINUE 6849C 6850 READ(LU1) NBL1 6851 READ(LU2) NBL2 6852 IF( NBL1 .NE. NBL2 ) THEN 6853 WRITE(6,'(A,2I5)') 'DIFFERENT BLOCKSIZES IN VECSME ', 6854 & NBL1,NBL2 6855 STOP ' INCOMPATIBLE BLOCKSIZES IN VECSMF ' 6856 END IF 6857C 6858 WRITE(LU3) NBL1 6859 IF(NBL1 .GE. 0 ) THEN 6860 CALL FRMDSC(VEC1,NBL1,-1 ,LU1,IMZERO,IAMPACK) 6861 CALL FRMDSC(VEC2,NBL1,-1 ,LU2,IMZERO,IAMPACK) 6862 IF( NBL1 .GT. 0 ) 6863 & CALL VECSUM(VEC1,VEC1,VEC2,FAC1,FAC2,NBL1) 6864 CALL TODSC(VEC1,NBL1,-1 ,LU3) 6865 END IF 6866C 6867 IF(NBL1 .GE. 0 ) GOTO 1000 6868C 6869 RETURN 6870 END 6871 SUBROUTINE VECSMF(Q,V,SCRA,NVEC,IMULT,IADD,IVCFIL,NDIM) 6872C 6873C CALCULATE SUM OF VECTORS RESIDING ON DISC. 6874C 6875C Q(J)=SUM(IVEC) V(IVEC)*VECTOR(IVEC)(J) 6876C IVEC=(I-1)*IMULT+IADD,I=1,NVEC 6877C 6878 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6879 DIMENSION Q(1),V(1),SCRA(1) 6880C 6881 DO 1000 I=1,NVEC 6882 IF(I.EQ.1) THEN 6883 CALL POSIFL(IADD,IVCFIL) 6884 ELSE 6885 IF(IMULT.NE.1) CALL SKPRC3((IMULT-1),IVCFIL) 6886 END IF 6887 CALL FRMDSC(SCRA,NDIM,-1 ,IVCFIL,IMZERO,IAMPACK) 6888 CALL VECSUM(Q,Q,SCRA,1.0D0,V(I),NDIM) 6889 1000 CONTINUE 6890C 6891 RETURN 6892 END 6893 SUBROUTINE VECSUM(C,A,B,FACA,FACB,NDIM) 6894C 6895C CACLULATE THE VECTOR C(I)=FACA*A(I)+FACB*B(I) 6896C 6897 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6898 DIMENSION A(1 ),B(1 ),C(1 ) 6899* 6900 IF(FACA.NE.0.0D0.AND.FACB.NE.0.0D0) THEN 6901 DO 100 I=1,NDIM 6902 S=FACA*A(I)+FACB*B(I) 6903 C(I)=S 6904 100 CONTINUE 6905* 6906 ELSE IF(FACA.EQ.0.0D0.AND.FACB.NE.0.0D0) THEN 6907 DO 200 I=1,NDIM 6908 S=FACB*B(I) 6909 C(I)=S 6910 200 CONTINUE 6911* 6912 ELSE IF(FACA.NE.0.0D0.AND.FACB.EQ.0.0D0) THEN 6913 DO 300 I=1,NDIM 6914 S=FACA*A(I) 6915 C(I)=S 6916 300 CONTINUE 6917* 6918 ELSE IF(FACA.EQ.0.0D0.AND.FACB.EQ.0.0D0) THEN 6919 DO 400 I=1,NDIM 6920 C(I)=0.0D0 6921 400 CONTINUE 6922 END IF 6923C 6924 RETURN 6925 END 6926 SUBROUTINE VTVTOV(AB,A,B,NDIM) 6927C AB(*) = A(*) * B(*) 6928 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6929 DIMENSION A(1 ),B(1 ),AB(1 ) 6930 DO 100 I = 1,NDIM 6931 AB(I) = A(I)*B(I) 6932 100 CONTINUE 6933C 6934 RETURN 6935 END 6936 SUBROUTINE VVTOV(VECIN1,VECIN2,VECUT,NDIM) 6937C 6938C VECUT(I) = VECIN1(I) * VECIN2(I) 6939C 6940 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6941 DIMENSION VECIN1( 1 ),VECIN2(1 ),VECUT(1 ) 6942C 6943 DO 100 I = 1, NDIM 6944 VECUT(I) = VECIN1(I) * VECIN2(I) 6945 100 CONTINUE 6946C 6947 RETURN 6948 END 6949 SUBROUTINE WRITVE(VEC,NDIM) 6950 DOUBLE PRECISION VEC 6951 DIMENSION VEC(1 ) 6952C 6953 WRITE(6,1010) (VEC(I),I=1,NDIM) 6954 1010 FORMAT(1H0,2X,4(2X,E15.8),/,(1H ,2X,4(2X,E15.8))) 6955 RETURN 6956 END 6957 SUBROUTINE WRTDIA(A,NDIM,IFORM) 6958C 6959C PRINT DIAGONAL OF MATRIX A 6960C 6961C IFORM = 1 : MATRIX IS SQUARE PACKED 6962C IFORM = 2 : MATRIX IS LOWER TRIANGULAR PACKED 6963C 6964 IMPLICIT DOUBLE PRECISION(A-H,O-Z) 6965 DIMENSION A(*) 6966C 6967 IF( IFORM .EQ.1 ) THEN 6968 WRITE(6,'(4(2X,E14.8))') 6969 & (A((I-1)*NDIM+I),I=1,NDIM) 6970 ELSEIF (IFORM .EQ. 2 ) THEN 6971 WRITE(6,'(4(2X,E14.8))') 6972 & (A((I+1)*I/2),I=1,NDIM) 6973 END IF 6974C 6975 RETURN 6976 END 6977 SUBROUTINE WRTMAT_EP(A,NROW,NCOL,NMROW,NMCOL) 6978* 6979* Print matrix, extended precision (E25.15) 6980C 6981 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6982 DIMENSION A(NMROW,NMCOL) 6983C 6984 DO 100 I=1,NROW 6985 WRITE(6,1010) I,(A(I,J),J=1,NCOL) 6986 1010 FORMAT(1H0,I3,2X,2(1X,E25.15),/,(1H ,5X,2(1X,E25.15))) 6987 100 CONTINUE 6988 RETURN 6989 END 6990 SUBROUTINE WRTMAT_F7(A,NROW,NCOL,NMROW,NMCOL) 6991C 6992 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 6993 DIMENSION A(NMROW,NMCOL) 6994C 6995 DO 100 I=1,NROW 6996 WRITE(6,1010) I,(A(I,J),J=1,NCOL) 6997 1010 FORMAT(1H0,I3,2X,10(1X,F7.3),/,(1H ,5X,10(1X,F7.3))) 6998 100 CONTINUE 6999 RETURN 7000 END 7001 SUBROUTINE WRTMAT(A,NROW,NCOL,NMROW,NMCOL) 7002C 7003 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 7004 DIMENSION A(NMROW,NMCOL) 7005C 7006 DO 100 I=1,NROW 7007 WRITE(6,1010) I,(A(I,J),J=1,NCOL) 7008 1010 FORMAT(1H0,I3,2X,4(1X,E24.16),/,(1H ,5X,4(1X,E24.16))) 7009 100 CONTINUE 7010 RETURN 7011 END 7012 SUBROUTINE WRTMAT2(A,NROW,NCOL,NMROW,NMCOL) 7013C 7014 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 7015 DIMENSION A(NMROW,NMCOL) 7016C 7017 ICOLMX=4 7018 ICOLL=0 7019 ICOLH=0 7020 DO WHILE (ICOLH.NE.NCOL) 7021 ICOLL = ICOLH+1 7022 ICOLH = MIN(ICOLL-1+ICOLMX,NCOL) 7023 WRITE(6,1000) (J,J=ICOLL,ICOLH) 7024 DO I=1,NROW 7025 WRITE(6,1010) I,(A(I,J),J=ICOLL,ICOLH) 7026 END DO 7027 END DO 7028 7029 RETURN 7030 1000 FORMAT(1H0,3X,2X,4(1X,6X,I6,6X)) 7031 1010 FORMAT(1H0,I3,2X,4(1X,E18.10)) 7032 END 7033 SUBROUTINE WRTIMAT(IA,NROW,NCOL,NMROW,NMCOL) 7034C 7035 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 7036 DIMENSION IA(NMROW,NMCOL) 7037C 7038 DO 100 I=1,NROW 7039 WRITE(6,1010) I,(IA(I,J),J=1,NCOL) 7040 1010 FORMAT(1H0,I3,2X,6(1X,I10),/,(1H ,5X,6(1X,I10))) 7041 100 CONTINUE 7042 RETURN 7043 END 7044 SUBROUTINE WRTVCD_EP(SEGMNT,LU,IREW,LBLK) 7045C 7046C PRINT VECTOR ON FILE LU 7047C 7048C LBLK DEFINES STRUCTURE OF FILES : 7049C 7050 IMPLICIT REAL*8(A-H,O-Z) 7051 DIMENSION SEGMNT(*) 7052C 7053 IF( IREW .NE. 0 ) THEN 7054 IF( LBLK .GE. 0 ) THEN 7055 REWIND LU 7056 ELSE 7057 CALL REWINE(LU,LBLK) 7058 END IF 7059 END IF 7060C LOOP OVER BLOCKS 7061C 7062 IBLK = 0 7063 1000 CONTINUE 7064 IF ( LBLK .GT. 0 ) THEN 7065 LBL = LBLK 7066 ELSE IF ( LBLK .EQ. 0 ) THEN 7067 READ(LU) LBL 7068 ELSE 7069 CALL IFRMDS(LBL,1,-1,LU) 7070 END IF 7071 IBLK = IBLK + 1 7072 IF(LBL .GE. 0 ) THEN 7073 IF(LBLK .GE.0 ) THEN 7074 KBLK = LBL 7075 ELSE 7076 KBLK = -1 7077 END IF 7078 CALL FRMDSC(SEGMNT,LBL ,KBLK,LU,IMZERO,IAMPACK) 7079 IF(LBL .GT. 0 ) THEN 7080 WRITE(6,'(A,I3,A,I6)') 7081 & ' Number of elements in segment ',IBLK,' IS ',LBL 7082 CALL WRTMAT_EP(SEGMNT,1,LBL,1,LBL) 7083 END IF 7084 END IF 7085C 7086 IF( LBL.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 7087C 7088 RETURN 7089 END 7090 SUBROUTINE WRTVCD(SEGMNT,LU,IREW,LBLK) 7091C 7092C PRINT VECTOR ON FILE LU 7093C 7094C LBLK DEFINES STRUCTURE OF FILES : 7095C 7096 IMPLICIT REAL*8(A-H,O-Z) 7097 DIMENSION SEGMNT(*) 7098C 7099 IF( IREW .NE. 0 ) THEN 7100 IF( LBLK .GE. 0 ) THEN 7101 REWIND LU 7102 ELSE 7103 CALL REWINE(LU,LBLK) 7104 END IF 7105 END IF 7106C LOOP OVER BLOCKS 7107C 7108 IBLK = 0 7109 1000 CONTINUE 7110 IF ( LBLK .GT. 0 ) THEN 7111 LBL = LBLK 7112 ELSE IF ( LBLK .EQ. 0 ) THEN 7113 READ(LU) LBL 7114 ELSE 7115 CALL IFRMDS(LBL,1,-1,LU) 7116 END IF 7117 IBLK = IBLK + 1 7118 IF(LBL .GE. 0 ) THEN 7119 IF(LBLK .GE.0 ) THEN 7120 KBLK = LBL 7121 ELSE 7122 KBLK = -1 7123 END IF 7124 CALL FRMDSC(SEGMNT,LBL ,KBLK,LU,IMZERO,IAMPACK) 7125 IF(LBL .GT. 0 ) THEN 7126 WRITE(6,'(A,I3,A,I6)') 7127 & ' Number of elements in segment ',IBLK,' IS ',LBL 7128 CALL WRTMAT(SEGMNT,1,LBL,1,LBL) 7129 END IF 7130 END IF 7131C 7132 IF( LBL.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 7133C 7134 RETURN 7135 END 7136 SUBROUTINE WRTVSD(SEGMNT,LU,IREW,LBLK) 7137C 7138C PRINT VECTOR STRUCTURE ON FILE LU 7139C 7140C LBLK DEFINES STRUCTURE OF FILES : 7141C 7142 IMPLICIT REAL*8(A-H,O-Z) 7143 DIMENSION SEGMNT(*) 7144 REAL(8), EXTERNAL :: INPROD 7145C 7146 WRITE(6,*) 7147 WRITE(6,*) 'Structure of vector on unit ',lu 7148 CALL UNIT_INFO(LU) 7149C 7150 IF( IREW .NE. 0 ) THEN 7151 IF( LBLK .GE. 0 ) THEN 7152 REWIND LU 7153 ELSE 7154 CALL REWINE(LU,LBLK) 7155 END IF 7156 END IF 7157C LOOP OVER BLOCKS 7158C 7159 IBLK = 0 7160 1000 CONTINUE 7161 IF ( LBLK .GT. 0 ) THEN 7162 LBL = LBLK 7163 ELSE IF ( LBLK .EQ. 0 ) THEN 7164 READ(LU) LBL 7165 ELSE 7166 CALL IFRMDS(LBL,1,-1,LU) 7167 END IF 7168 IBLK = IBLK + 1 7169 IF(LBL .GE. 0 ) THEN 7170 IF(LBLK .GE.0 ) THEN 7171 KBLK = LBL 7172 ELSE 7173 KBLK = -1 7174 END IF 7175 CALL FRMDSC(SEGMNT,LBL ,KBLK,LU,IMZERO,IAMPACK) 7176 IF(LBL .GT. 0 ) THEN 7177 WRITE(6,'(A,I3,A,I6)') 7178 & ' Number of elements in segment ',IBLK,' IS ',LBL 7179 WRITE(6,'(2(A,I3),A,E20.7)') ' zero_flag: ',IMZERO, 7180 & ' pack_flag: ',IAMPACK, 7181 & ' norm: ',SQRT(INPROD(SEGMNT,SEGMNT,LBL)) 7182 END IF 7183 END IF 7184C 7185 IF( LBL.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 7186C 7187 RETURN 7188 END 7189 FUNCTION XFAC(N) 7190* 7191* N ! as double precision real 7192* 7193 IMPLICIT REAL*8(A-H,O-Z) 7194 IF( N .LT. 0 ) THEN 7195 IFAC = 0 7196 WRITE(6,*) ' WARNING FACULTY OF NEGATIVE NUMBER SET TO ZERO ' 7197 ELSE 7198C 7199 XFACN = 1.0D0 7200 DO 100 K = 2,N 7201 XFACN = XFACN * DFLOAT(K) 7202 100 CONTINUE 7203 XFAC = XFACN 7204 END IF 7205C 7206 RETURN 7207 END 7208c----------------------------------------------------------------------c 7209 SUBROUTINE SYMMAT(AMAT,NDIM,MAXDIM) 7210c----------------------------------------------------------------------c 7211c symmetrize NDIMxNDIM block in matrix AMAT 7212c----------------------------------------------------------------------c 7213 include "implicit.inc" 7214 DIMENSION AMAT(MAXDIM,*) 7215 7216 DO I = 1, NDIM 7217 DO J = 1, I-1 7218 ELM = 0.5*(AMAT(J,I)+AMAT(I,J)) 7219 AMAT(J,I)=ELM 7220 AMAT(I,J)=ELM 7221 END DO 7222 END DO 7223 7224 RETURN 7225 END 7226c----------------------------------------------------------------------c 7227 SUBROUTINE TEST_SYMMAT(AMAT,NDIM,MAXDIM) 7228c----------------------------------------------------------------------c 7229c test NDIMxNDIM block in matrix AMAT on symmetry 7230c----------------------------------------------------------------------c 7231 include "implicit.inc" 7232 DIMENSION AMAT(MAXDIM,*) 7233 7234 DO I = 1, NDIM 7235 DO J = 1, I-1 7236 THR = EPSILON(AMAT(J,I)) 7237 IF (ABS(AMAT(J,I)-AMAT(I,J)).GT.THR) THEN 7238 WRITE(6,'(X,A,2I6,A,E12.6)') 7239 & 'Symmetry violation in pair ',I,J,' by ', 7240 & ABS(AMAT(J,I)-AMAT(I,J)) 7241 END IF 7242 END DO 7243 END DO 7244 7245 RETURN 7246 END 7247c----------------------------------------------------------------------c 7248 SUBROUTINE LIST_SL(IMODE,VEC,NDIM,VECLIST,IVECLIST,NLIST) 7249c----------------------------------------------------------------------c 7250c get the NLIST smallest/largest (IMODE=1/2) vectors from VEC(NDIM) 7251c and put them sorted into vector VECLIST(NLIST) (indices on IVECLIST) 7252c----------------------------------------------------------------------c 7253 INCLUDE "implicit.inc" 7254 DIMENSION VEC(NDIM), VECLIST(NLIST), IVECLIST(NLIST) 7255 7256 ILIST=0 7257 XEXTR=0D0 7258 IF(IMODE.EQ.1) XEXTR=HUGE(XEXTR) 7259 7260* Initialization cycles 7261 DO IDX = 1, NLIST 7262 XEL = VEC(IDX) 7263 VECLIST(IDX)=XEL 7264 IVECLIST(IDX)=IDX 7265 IF ((IMODE.EQ.1.AND.XEL.GT.XEXTR).OR. 7266 & (IMODE.EQ.2.AND.XEL.LT.XEXTR)) THEN 7267 XEXTR = XEL 7268 IMAX = IDX 7269 END IF 7270 END DO 7271* Search for further small elements 7272 DO IDX = NLIST+1, NDIM 7273 XEL = VEC(IDX) 7274 IF ((IMODE.EQ.1.AND.XEL.LT.XEXTR).OR. 7275 & (IMODE.EQ.2.AND.XEL.GT.XEXTR)) THEN 7276 VECLIST(IMAX) = XEL 7277 IVECLIST(IMAX) = IDX 7278 XEXTR = 0D0 7279 IF(IMODE.EQ.1) XEXTR=HUGE(XEXTR) 7280 DO JDX = 1, NLIST 7281 XEL = VECLIST(JDX) 7282 IF ((IMODE.EQ.1.AND.XEL.GT.XEXTR).OR. 7283 & (IMODE.EQ.2.AND.XEL.LT.XEXTR)) THEN 7284 XEXTR = XEL 7285 IMAX = JDX 7286 END IF 7287 END DO 7288 END IF 7289 END DO 7290c sort the final list 7291 7292 DO 7293 ISWAP = 0 7294 DO IDX = 2, NLIST 7295 IF ((IMODE.EQ.1.AND.VECLIST(IDX-1).GT.VECLIST(IDX)).OR. 7296 & (IMODE.EQ.2.AND.VECLIST(IDX-1).LT.VECLIST(IDX)) ) THEN 7297 XHLP=VECLIST(IDX) 7298 VECLIST(IDX)=VECLIST(IDX-1) 7299 VECLIST(IDX-1)=XHLP 7300 IHLP=IVECLIST(IDX) 7301 IVECLIST(IDX)=IVECLIST(IDX-1) 7302 IVECLIST(IDX-1)=IHLP 7303 ISWAP = 1 7304 END IF 7305 7306 END DO 7307 7308 IF (ISWAP.EQ.0) EXIT 7309 7310 END DO 7311 7312 RETURN 7313 7314 END 7315c----------------------------------------------------------------------c 7316c----------------------------------------------------------------------c 7317c----------------------------------------------------------------------c 7318 SUBROUTINE LIST_ASL(IMODE,VEC,NDIM,VECLIST,IVECLIST,NLIST) 7319c----------------------------------------------------------------------c 7320c get the NLIST smallest/largest (IMODE=1/2) elements (abs. value) 7321c from VEC(NDIM) and put them sorted into vector VECLIST(NLIST) 7322c (indices on IVECLIST) 7323c----------------------------------------------------------------------c 7324 INCLUDE "implicit.inc" 7325 DIMENSION VEC(NDIM), VECLIST(NLIST), IVECLIST(NLIST) 7326 7327 ILIST=0 7328 XEXTR=0D0 7329 IF(IMODE.EQ.2) XEXTR=HUGE(XEXTR) 7330 7331* Initialization cycles 7332 DO IDX = 1, NLIST 7333 XEL = VEC(IDX) 7334 AXEL = ABS(XEL) 7335 VECLIST(IDX)=XEL 7336 IVECLIST(IDX)=IDX 7337 IF ((IMODE.EQ.1.AND.AXEL.GT.XEXTR).OR. 7338 & (IMODE.EQ.2.AND.AXEL.LT.XEXTR)) THEN 7339 XEXTR = AXEL 7340 IMAX = IDX 7341 END IF 7342 END DO 7343* Search for further small elements 7344 DO IDX = NLIST+1, NDIM 7345 XEL = VEC(IDX) 7346 AXEL = ABS(XEL) 7347 IF ((IMODE.EQ.1.AND.AXEL.LT.XEXTR).OR. 7348 & (IMODE.EQ.2.AND.AXEL.GT.XEXTR)) THEN 7349 VECLIST(IMAX) = XEL 7350 IVECLIST(IMAX) = IDX 7351 XEXTR = 0D0 7352 IF(IMODE.EQ.2) XEXTR=HUGE(XEXTR) 7353 DO JDX = 1, NLIST 7354 XEL = VECLIST(JDX) 7355 AXEL = ABS(XEL) 7356 IF ((IMODE.EQ.1.AND.AXEL.GT.XEXTR).OR. 7357 & (IMODE.EQ.2.AND.AXEL.LT.XEXTR)) THEN 7358 XEXTR = AXEL 7359 IMAX = JDX 7360 END IF 7361 END DO 7362 END IF 7363 END DO 7364c sort the final list 7365 7366 DO 7367 ISWAP = 0 7368 DO IDX = 2, NLIST 7369 IF ((IMODE.EQ.1.AND. 7370 & ABS(VECLIST(IDX-1)).GT.ABS(VECLIST(IDX))).OR. 7371 & (IMODE.EQ.2.AND. 7372 & ABS(VECLIST(IDX-1)).LT.ABS(VECLIST(IDX))) ) THEN 7373 XHLP=VECLIST(IDX) 7374 VECLIST(IDX)=VECLIST(IDX-1) 7375 VECLIST(IDX-1)=XHLP 7376 IHLP=IVECLIST(IDX) 7377 IVECLIST(IDX)=IVECLIST(IDX-1) 7378 IVECLIST(IDX-1)=IHLP 7379 ISWAP = 1 7380 END IF 7381 7382 END DO 7383 7384 IF (ISWAP.EQ.0) EXIT 7385 7386 END DO 7387 7388 RETURN 7389 7390 END 7391c----------------------------------------------------------------------c 7392c----------------------------------------------------------------------c 7393 REAL*8 FUNCTION FDMNXD(LUVE,MINMAX,SEGMNT,IREW,LBLK) 7394C 7395C FIND ELEMENT WITH SMALLEST (MINMAX==1) OR LARGEST (MINMAX==2) ABSOLUTE 7396C VALUE OF ELEMENTS OF VECTOR ON FILE LUVE 7397C OR THE SMALLEST (MINMAX=-1) OR THE LARGEST (MINMAX=-2) ELEMENT 7398C 7399C LBLK DEFINES STRUCTURE OF FILES 7400C 7401 IMPLICIT REAL*8(A-H,O-Z) 7402 DIMENSION SEGMNT(*) 7403 LOGICAL FIRST 7404C 7405 IF( IREW .NE. 0 ) THEN 7406 IF( LBLK .GE. 0 ) THEN 7407 REWIND LUVE 7408 ELSE 7409 CALL REWINE( LUVE ,LBLK) 7410 END IF 7411 END IF 7412C 7413 IF (MINMAX.LT.-2.OR.MINMAX.GT.2.OR.MINMAX.EQ.0) THEN 7414 WRITE(6,*) 'Illegal parameter MINMAX in FDMNXD!' 7415 STOP 'Illegal parameter MINMAX in FDMNXD!' 7416 END IF 7417 FIRST=.TRUE. 7418C 7419C LOOP OVER BLOCKS 7420C 7421 1000 CONTINUE 7422 IF ( LBLK .GT. 0 ) THEN 7423 LBL = LBLK 7424 ELSE IF (LBLK .EQ. 0 ) THEN 7425 READ(LUVE) LBL 7426 ELSE IF (LBLK .LT. 0 ) THEN 7427 CALL IFRMDS(LBL,1,-1,LUVE) 7428 END IF 7429C 7430 IF ( LBL .GE. 0 ) THEN 7431 IF( LBLK .GE.0 ) THEN 7432 KBLK = LBL 7433 ELSE 7434 KBLK = -1 7435 END IF 7436C 7437 CALL FRMDSC(SEGMNT,LBL,KBLK,LUVE,IMZERO,IAMPACK) 7438 IF(LBL .GT. 0 ) THEN 7439 IF (FIRST) THEN 7440 XMNX = ABS(SEGMNT(1)) 7441 FIRST = .FALSE. 7442 END IF 7443 XMNXBLK = FNDMNX(SEGMNT,LBL,MINMAX) 7444 IF (ABS(MINMAX).EQ.1) XMNX = MIN(XMNX,XMNXBLK) 7445 IF (ABS(MINMAX).EQ.2) XMNX = MAX(XMNX,XMNXBLK) 7446 END IF 7447 END IF 7448C 7449 IF( LBL .GE. 0 .AND. LBLK .LE. 0) GOTO 1000 7450C 7451 FDMNXD = XMNX 7452C 7453 RETURN 7454 END 7455c----------------------------------------------------------------------c 7456 SUBROUTINE CMP2VCD(VEC1,VEC2,LU1,LU2,THRSH,IREW,LBLK) 7457C 7458C DISC VERSION OF CMP2VC : 7459C 7460C COMPARE BLOCKED VECTORS ON FILES LU1 AND LU2 7461C 7462C LBLK DEFINES STRUCTURE OF FILE 7463C 7464 IMPLICIT REAL*8(A-H,O-Z) 7465 DIMENSION VEC1(*),VEC2(*) 7466C 7467 IF(IREW .NE. 0 ) THEN 7468 CALL REWINE( LU1,LBLK) 7469 CALL REWINE( LU2,LBLK) 7470 END IF 7471C 7472C LOOP OVER BLOCKS OF VECTOR 7473C 7474 IBLK = 0 7475 NBL1 = 0 7476C 7477C loop over blocks 7478 DO 7479C 7480 IF( LBLK .GT. 0 ) THEN 7481 NBL1 = LBLK 7482 NBL2 = LBLK 7483 ELSE IF(LBLK .EQ. 0 ) THEN 7484 READ(LU1) NBL1 7485 READ(LU2) NBL2 7486 ELSE IF (LBLK .LT. 0 ) THEN 7487 CALL IFRMDS( NBL1,1,-1,LU1) 7488 CALL IFRMDS( NBL2,1,-1,LU2) 7489 END IF 7490 IBLK = IBLK+1 7491 IF( NBL1 .NE. NBL2 ) THEN 7492 WRITE(6,'(A,2I5)') 'DIFFERENT BLOCKSIZES IN CMP2VCD', 7493 & NBL1,NBL2 7494 STOP ' INCOMPATIBLE BLOCKSIZES IN CMP2VCD ' 7495 END IF 7496C 7497 IF(NBL1 .GE. 0 ) THEN 7498 IF(LBLK .GE.0 ) THEN 7499 KBLK = NBL1 7500 ELSE 7501 KBLK = -1 7502 END IF 7503 NO_ZEROING = 1 7504 CALL FRMDSC2(VEC1,NBL1,KBLK,LU1,IMZERO1,IAMPACK,NO_ZEROING) 7505 CALL FRMDSC2(VEC2,NBL1,KBLK,LU2,IMZERO2,IAMPACK,NO_ZEROING) 7506 IF( NBL1 .GT. 0 ) THEN 7507 WRITE(6,*) 'Current segment: ',IBLK,NBL1 7508 IF(IMZERO1.EQ.1.AND.IMZERO2.EQ.1) THEN 7509 WRITE(6,*) 'Segment is zero on both files' 7510 ELSE 7511*. Nonvanishing record 7512 ZERO = 0.0D0 7513 IF(IMZERO1.EQ.1) THEN 7514 CALL SETVEC(VEC1,ZERO,NBL1) 7515 ELSE IF(IMZERO2.EQ.1) THEN 7516 CALL SETVEC(VEC2,ZERO,NBL1) 7517 END IF 7518 CALL CMP2VC(VEC1,VEC2,NBL1,THRSH) 7519 END IF 7520 END IF 7521 END IF 7522C 7523 IF (.NOT.(NBL1.GE. 0 .AND. LBLK .LE. 0)) EXIT 7524C 7525 END DO 7526C 7527 RETURN 7528 END 7529c----------------------------------------------------------------------- 7530 subroutine prtrlt(v,m) 7531 implicit real*8(a-h,o-z) 7532c 7533c ----- print out the lower triangle of a symmetric matrix (stored 7534c in packed canonical form (actually an upper triangle) !) ----- 7535c 7536 dimension v(m*(m+1)/2) 7537 7538 max=5 7539 imax = 0 7540 do while(imax.lt.m) 7541 imin = imax+1 7542 imax = min(imax+max,m) 7543 write(*,'(/,5x,10(6x,i4,5x)/)') (i,i = imin,imax) 7544 do i=1,m 7545 ii = i*(i-1)/2 7546 mm = imin + ii 7547 kk = min(i,imax) + ii 7548 if(mm.le.kk) then 7549 write(*,'(i4,1x,10e15.7)') i,(v(j),j=mm,kk) 7550 end if 7551 end do 7552 end do 7553 write(*,*) 7554 return 7555 end 7556 SUBROUTINE CMP2VSC(VEC1,VEC2,LU1,LU2,IREW,LBLK) 7557C 7558C COMPARE STRUCTURE OF BLOCKED VECTORS ON FILES LU1 AND LU2 7559C 7560C LBLK DEFINES STRUCTURE OF FILE 7561C 7562 IMPLICIT REAL*8(A-H,O-Z) 7563 DIMENSION VEC1(*),VEC2(*) 7564C 7565 IF(IREW .NE. 0 ) THEN 7566 CALL REWINE( LU1,LBLK) 7567 CALL REWINE( LU2,LBLK) 7568 END IF 7569C 7570C LOOP OVER BLOCKS OF VECTOR 7571C 7572 IBLK = 0 7573 NBL1 = 0 7574C 7575C loop over blocks 7576 DO 7577C 7578 IF( LBLK .GT. 0 ) THEN 7579 NBL1 = LBLK 7580 NBL2 = LBLK 7581 ELSE IF(LBLK .EQ. 0 ) THEN 7582 READ(LU1) NBL1 7583 READ(LU2) NBL2 7584 ELSE IF (LBLK .LT. 0 ) THEN 7585 CALL IFRMDS( NBL1,1,-1,LU1) 7586 CALL IFRMDS( NBL2,1,-1,LU2) 7587 END IF 7588 IBLK = IBLK+1 7589C 7590 IF (NBL1.EQ.-1.AND.NBL2.NE.-1.OR. 7591 & NBL2.EQ.-1.AND.NBL1.NE.-1) THEN 7592 WRITE(6,*) 'Premature end of one vector: ',NBL1, NBL2 7593 RETURN 7594 END IF 7595C 7596 IF(NBL1 .GE. 0 ) THEN 7597 WRITE(6,*) 'Current segment: ',IBLK,NBL1,NBL2 7598 IF( NBL1 .NE. NBL2 ) THEN 7599 WRITE(6,'(A,2I5)') 'DIFFERENT BLOCKSIZES !', 7600 & NBL1,NBL2 7601 END IF 7602 7603 IF(LBLK .GE.0 ) THEN 7604 KBLK = NBL1 7605 ELSE 7606 KBLK = -1 7607 END IF 7608 NO_ZEROING = 1 7609 CALL FRMDSC2(VEC1,NBL1,KBLK,LU1,IMZERO1,IAMPACK1,NO_ZEROING) 7610 IF(LBLK .GE.0 ) THEN 7611 KBLK = NBL2 7612 ELSE 7613 KBLK = -1 7614 END IF 7615 CALL FRMDSC2(VEC2,NBL2,KBLK,LU2,IMZERO2,IAMPACK2,NO_ZEROING) 7616 IF( NBL1 .GT. 0 ) THEN 7617 WRITE(6,*) 'Current segment is non-empty on: ',LU1,IBLK,NBL1 7618 IF(IMZERO1.EQ.1) THEN 7619 WRITE(6,*) 'Segment is zero on ', LU1 7620 END IF 7621 IF(IMPACK1.EQ.1) THEN 7622 WRITE(6,*) 'Segment is packed on ', LU1 7623 END IF 7624 END IF 7625 IF( NBL2 .GT. 0 ) THEN 7626 WRITE(6,*) 'Current segment is non-empty on: ',LU2,IBLK,NBL2 7627 IF(IMZERO2.EQ.1) THEN 7628 WRITE(6,*) 'Segment is zero on ', LU2 7629 END IF 7630 IF(IMPACK2.EQ.1) THEN 7631 WRITE(6,*) 'Segment is packed on ', LU2 7632 END IF 7633 END IF 7634 END IF 7635C 7636 IF (.NOT.(NBL1.GE. 0 .AND. LBLK .LE. 0)) EXIT 7637C 7638 END DO 7639C 7640 RETURN 7641 END 7642 7643 REAL*8 FUNCTION INPRDD3(VEC1,VEC2,LU1,LU2,LU3, 7644 & SHIFT,XPOT,IREW,LBLK) 7645C 7646C CALC X = sum_i f_i (m_i+shift)**xpot g_i 7647C 7648C LBLK DEFINES STRUCTURE OF FILE 7649C 7650*. Last revision, Sept 2003 : FRMDSC => FRMDSC2 to simplify handling 7651* of vectors containing many zeo blocks 7652 IMPLICIT REAL*8(A-H,O-Z) 7653 REAL*8 INPROD 7654 DIMENSION VEC1(*),VEC2(*) 7655 LOGICAL DIFVEC 7656C 7657 X = 0.0D0 7658 IF( LU1 .NE. LU2 ) THEN 7659 DIFVEC = .TRUE. 7660 ELSE 7661 DIFVEC = .FALSE. 7662 END IF 7663C 7664 IF( IREW .NE. 0 ) THEN 7665 IF( LBLK .GE. 0 ) THEN 7666 REWIND LU1 7667 IF(DIFVEC) REWIND LU2 7668 REWIND LU3 7669 ELSE 7670 CALL REWINE( LU1,LBLK) 7671 IF( DIFVEC ) CALL REWINE( LU2,LBLK) 7672 CALL REWINE( LU3,LBLK) 7673 END IF 7674 END IF 7675C 7676C LOOP OVER BLOCKS OF VECTORS 7677C 7678 1000 CONTINUE 7679C 7680 IF( LBLK .GT. 0 ) THEN 7681 NBL1 = LBLK 7682 NBL2 = LBLK 7683 NBL3 = LBLK 7684 ELSE IF ( LBLK .EQ. 0 ) THEN 7685 READ(LU1) NBL1 7686 IF( DIFVEC) READ(LU2) NBL2 7687 READ(LU3) NBL3 7688 ELSE IF ( LBLK .LT. 0 ) THEN 7689 CALL IFRMDS(NBL1,1,-1,LU1) 7690 IF( DIFVEC)CALL IFRMDS(NBL2,1,-1,LU2) 7691 CALL IFRMDS(NBL3,1,-1,LU3) 7692 END IF 7693C 7694 NO_ZEROING = 1 7695 IF(NBL1 .GE. 0 ) THEN 7696 IF(LBLK .GE.0 ) THEN 7697 KBLK = NBL1 7698 ELSE 7699 KBLK = -1 7700 END IF 7701 CALL FRMDSC2(VEC1,NBL1,KBLK,LU1,IMZERO1,IAMPACK,NO_ZEROING) 7702C FRMDSC2(ARRAY,NDIM,MBLOCK,IFILE,IMZERO,I_AM_PACKED, 7703C & NO_ZEROING) 7704 CALL FRMDSC2(VEC2,NBL3,KBLK,LU3,IMZERO3,IAMPACK,NO_ZEROING) 7705 XPOTABS = ABS(XPOT) 7706 DO II = 1, NBL3 7707 VEC2(II) = (VEC2(II)+SHIFT)**XPOTABS 7708 END DO 7709 IF (XPOT.LT.0d0) THEN 7710 CALL DIAVC2(VEC2,VEC1,VEC2,0d0,NBL1) 7711 ELSE 7712 CALL VVTOV(VEC1,VEC2,VEC2,NBL1) 7713 END IF 7714 IF( DIFVEC) THEN 7715 CALL FRMDSC2(VEC1,NBL1,KBLK,LU2,IMZERO2,IAMPACK, 7716 & NO_ZEROING) 7717 IF(NBL1 .GT. 0 .AND. IMZERO1.EQ.0.AND.IMZERO2.EQ.0) 7718 & X = X + INPROD(VEC1,VEC2,NBL1) 7719 ELSE 7720 IF(NBL1 .GT. 0 .AND. IMZERO1.EQ.0 ) 7721 & X = X + INPROD(VEC1,VEC2,NBL1) 7722 END IF 7723 END IF 7724 IF(NBL1.GE. 0 .AND. LBLK .LE. 0) GOTO 1000 7725C 7726 INPRDD3 = X 7727C 7728 RETURN 7729 END 7730 7731 subroutine iptchma(imat,nlin,ncol,ilin,icol,ival) 7732 7733 implicit none 7734 7735 integer, intent(in) :: 7736 & nlin,ncol,ilin,icol,ival 7737 integer, intent(inout) :: 7738 & imat(nlin,ncol) 7739 7740 imat(ilin,icol) = ival 7741 7742 return 7743 end 7744*----------------------------------------------------------------------* 7745* follows: exp and log of matrices 7746*----------------------------------------------------------------------* 7747 subroutine expgmat(ndim,expx,xmat,xscr1,xscr2,thrsh) 7748*----------------------------------------------------------------------* 7749* calculate exp(X), returned on expx, of (ndim,ndim)-matrix X, 7750* input on xmat, by Taylor expansion (threshold thrsh) 7751* xscr is a scratch matrix of the same dimensions as xmat, expx 7752* 7753* any quadratic matrix may be supplied 7754* 7755* andreas, aug 2004 7756* 7757*----------------------------------------------------------------------* 7758 7759 implicit none 7760 7761 integer, parameter :: ntest = 100, maxn = 100 7762 7763 integer, intent(in) :: 7764 & ndim 7765 real(8), intent(in) :: 7766 & thrsh 7767 real(8), intent(inout) :: 7768 & expx(ndim,ndim), xmat(ndim,ndim), 7769 & xscr1(ndim,ndim), xscr2(ndim,ndim) 7770 7771 logical :: 7772 & conv 7773 integer :: 7774 & n, ndim2, ii 7775 real(8) :: 7776 & xnrm, fac 7777 7778 real(8), external :: 7779 & inprod 7780 7781 expx(1:ndim,1:ndim) = xmat(1:ndim,1:ndim) 7782 xscr2(1:ndim,1:ndim) = xmat(1:ndim,1:ndim) 7783 7784 do ii = 1, ndim 7785 expx(ii,ii) = expx(ii,ii) + 1d0 7786 end do 7787 7788 ndim2 = ndim*ndim 7789 n = 1 7790 conv = .false. 7791 7792 do while (.not.conv) 7793 n = n+1 7794 if (n.gt.maxn) exit 7795 7796 fac = 1d0/dble(n) 7797 7798 ! Xscr = 1/N Xscr * X 7799 call matml7(xscr1,xscr2,xmat, 7800 & ndim,ndim, 7801 & ndim,ndim, 7802 & ndim,ndim,0d0,fac,0) 7803 7804 xnrm = sqrt(inprod(xscr1,xscr1,ndim2)) 7805 if (xnrm.lt.thrsh) conv = .true. 7806 7807 if (ntest.ge.10) 7808 & write(6,*) ' N = ',n,' |1/N! X^N| = ',xnrm 7809 7810 expx(1:ndim,1:ndim) = expx(1:ndim,1:ndim) + xscr1(1:ndim,1:ndim) 7811c call vecsum(expx,expx,xscr1,1d0,1d0,ndim2) 7812 7813 xscr2(1:ndim,1:ndim) = xscr1(1:ndim,1:ndim) 7814c call copvec(xscr1,xscr2,ndim2) 7815 7816 end do 7817 7818 if (.not.conv) then 7819 write(6,*) ' Taylor expansion of exp(X) did not converge!' 7820 stop 'expgmat' 7821 end if 7822 7823 return 7824 end 7825*----------------------------------------------------------------------* 7826 subroutine logumat(ndim,xlogx,xmat,xscr1,xscr2,xscr3) 7827*----------------------------------------------------------------------* 7828* calculate the logarithm of a unitary matrix 7829* 7830* the algorithm will use the eispack-routine rg() to calculate the 7831* eigenvalues of the matrix which are decompose in modulus and angle. 7832* the modulus should be one always, else the routine exits. 7833* 7834* andreas, aug 2004 7835* 7836*----------------------------------------------------------------------* 7837 7838 implicit none 7839 7840 integer, parameter :: ntest = 00, maxn = 100 7841 7842 integer, intent(in) :: 7843 & ndim 7844 real(8), intent(inout) :: 7845 & xlogx(ndim,ndim), xmat(ndim,ndim), 7846 & xscr1(ndim,ndim), xscr2(ndim,ndim), xscr3(ndim,ndim) 7847 7848 integer :: 7849 & ii, ierr 7850 real(8) :: 7851 & ang, xmod ,ang1,ang2 7852 7853* O(N) scratch 7854 real(8) :: 7855 & eigr(ndim), eigi(ndim), scr(ndim) 7856 integer :: 7857 & iscr(ndim) 7858 7859 7860 if (ntest.gt.0) then 7861 write(6,*) ' ==================== ' 7862 write(6,*) ' LOGUMAT at work !! ' 7863 write(6,*) ' ==================== ' 7864 7865 end if 7866 7867 if (ntest.ge.100) then 7868 write(6,*) ' xmat on entry:' 7869 call wrtmat2(xmat,ndim,ndim,ndim,ndim) 7870 end if 7871 7872 xscr2(1:ndim,1:ndim) = xmat(1:ndim,1:ndim) 7873 7874 ! get eigenvalues and -vectors ... 7875 call rg(ndim,ndim,xscr2, 7876 & eigr,eigi,1,xscr1, 7877 & iscr,scr,ierr) 7878 ! and normalize vectors (not done by rg) 7879 call nrmvec(ndim,xscr1,eigi) 7880 7881 if (ierr.ne.0) then 7882 write(6,*) 'error code from rg: ',ierr 7883 stop 'logumat (1)' 7884 end if 7885 7886 if (ntest.ge.10) write(6,*) ' eigenvalues of matrix:' 7887 7888*----------------------------------------------------------------------* 7889* the eigenvalues are v = exp(a+ib) so the logarithm log(v) yields 7890* a and b. as the matrix is unitary, a is always 0 and we are left 7891* with b, which is the angle in the complex plane. 7892* the angles will be collected in eigr(), later referred to as 7893* matrix D 7894*----------------------------------------------------------------------* 7895 ierr = 0 7896 do ii = 1, ndim 7897 xmod = eigr(ii)*eigr(ii) + eigi(ii)*eigi(ii) 7898 if (abs(xmod-1d0).gt.100d0*epsilon(1d0)) ierr = ierr+1 7899 ang1 = atan2(eigi(ii),eigr(ii)) 7900c ang2 = acos(eigr(ii))*sign(1d0,eigi(ii)) 7901 if (ntest.ge.10) 7902 & write(6,'(i4,2(2x,e20.10),3(2x,f15.10))') 7903 & ii,eigr(ii),eigi(ii),xmod,ang1,ang2 7904 eigr(ii) = ang1 7905 end do 7906 7907 if (ierr.gt.0) then 7908 write(6,*) 'error: detected eigenvalues with |v| != 1' 7909 stop 'logumat (2)' 7910 end if 7911 7912 ! sort components of transformation matrix into 7913 ! real and imaginary part: U = A + iB 7914 ! A on xscr1 7915 ! B on xscr2 7916 7917 ii = 0 7918 do while(ii.lt.ndim) 7919 ii = ii+1 7920 if (eigi(ii).eq.0d0) then ! real eigenvalue 7921 xscr2(1:ndim,ii) = 0d0 7922 else ! complex pair 7923 xscr2(1:ndim,ii) = xscr1(1:ndim,ii+1) ! imag. part 7924 xscr2(1:ndim,ii+1) = -xscr2(1:ndim,ii) ! and cmplx. conj. 7925 xscr1(1:ndim,ii+1) = xscr1(1:ndim,ii) 7926 ii = ii+1 ! add. increment 7927 end if 7928 end do 7929 7930 if (ntest.ge.100) then 7931 write(6,*) ' eigenvectors (Re):' 7932 call wrtmat2(xscr1,ndim,ndim,ndim,ndim) 7933 write(6,*) ' eigenvectors (Im):' 7934 call wrtmat2(xscr1,ndim,ndim,ndim,ndim) 7935 end if 7936 7937*----------------------------------------------------------------------* 7938* 7939* now we have to calculate U iD U^+ 7940* 7941* the real part is 7942* A iD (iB)^+ + (iB) iD A^+ = A D B^T - B D A^T 7943* 7944* the imaginary part is 7945* A iD A^+ + iB iD (iB)^+ = i (A D A^T + B D B^T) 7946* 7947* as iD has either zero or pairwise conjugate entries, the imaginary 7948* part vanishes (note that we started from a real unitary matrix) 7949* 7950*----------------------------------------------------------------------* 7951 7952 ! A on xscr1 7953 ! B on xscr2 7954 7955 ! A D --> xscr3 7956 do ii = 1, ndim 7957 xscr3(1:ndim,ii) = xscr1(1:ndim,ii)*eigr(ii) 7958 end do 7959 7960 ! AD B^T --> xlogx 7961 call matml7(xlogx,xscr3,xscr2, 7962 & ndim,ndim, 7963 & ndim,ndim, 7964 & ndim,ndim, 7965 & 0d0,1d0, 2 ) 7966 7967 ! B D --> xscr3 7968 do ii = 1, ndim 7969 xscr3(1:ndim,ii) = xscr2(1:ndim,ii)*eigr(ii) 7970 end do 7971 7972 !-BD A^T --> xlogx 7973 call matml7(xlogx,xscr3,xscr1, 7974 & ndim,ndim, 7975 & ndim,ndim, 7976 & ndim,ndim, 7977 & 1d0,-1d0, 2 ) 7978 7979 if (ntest.ge.100) then 7980 write(6,*) ' result on xlogx:' 7981 call wrtmat2(xlogx,ndim,ndim,ndim,ndim) 7982 end if 7983 7984 return 7985 7986 end 7987 7988*----------------------------------------------------------------------* 7989 subroutine nrmvec(ndim,eigvec,eigvi) 7990*----------------------------------------------------------------------* 7991* normalize the eigenvectors in array eigvec(ndim,ndim) 7992* imaginary pairs are handled as described in rg(), eispack.f 7993*----------------------------------------------------------------------* 7994 7995 implicit none 7996 7997 integer, parameter :: 7998 & ntest = 100 7999 8000 integer, intent(in) :: 8001 & ndim 8002 real(8), intent(in) :: 8003 & eigvi(ndim) 8004 real(8), intent(inout) :: 8005 & eigvec(ndim,ndim) 8006 8007 integer :: 8008 & ivec 8009 real(8) :: 8010 & xnrm 8011 8012 real(8), external :: 8013 & inprod 8014 8015 ivec = 0 8016 do while (ivec.lt.ndim) 8017 ivec = ivec+1 8018 8019 xnrm = inprod(eigvec(1,ivec),eigvec(1,ivec),ndim) 8020 8021 if (eigvi(ivec).ne.0d0) then 8022 if (ivec+1.gt.ndim) then 8023 write(6,*) 'inconsistency in eigenvalue structure' 8024 stop 'nrmvec' 8025 end if 8026 8027 xnrm = xnrm + inprod(eigvec(1,ivec+1),eigvec(1,ivec+1),ndim) 8028 end if 8029 8030 xnrm = sqrt(xnrm) 8031 8032 call scalve(eigvec(1,ivec),1d0/xnrm,ndim) 8033 8034 if (eigvi(ivec).ne.0d0) then 8035 call scalve(eigvec(1,ivec+1),1d0/xnrm,ndim) 8036 ivec = ivec+1 8037 end if 8038 8039 end do 8040 8041 return 8042 8043 end 8044 8045*----------------------------------------------------------------------* 8046 8047 integer function ifndmax(ivec,idxoff,lvec,inc) 8048 8049 implicit none 8050 8051 integer, intent(in) :: 8052 & ivec(*), lvec, inc, idxoff 8053 8054 integer :: 8055 & i, imx, idx 8056 8057 imx = -huge(imx) 8058 idx = idxoff 8059 do i = 1, lvec 8060 imx = max(imx,ivec(idx)) 8061 idx = idx + inc 8062 end do 8063 8064 ifndmax = imx 8065 8066 return 8067 end 8068 8069*----------------------------------------------------------------------* 8070 8071 integer function ifndmin(ivec,idxoff,lvec,inc) 8072 8073 implicit none 8074 8075 integer, intent(in) :: 8076 & ivec(*), lvec, inc, idxoff 8077 8078 integer :: 8079 & i, imn, idx 8080 8081 imn = huge(imn) 8082 idx = idxoff 8083 do i = 1, lvec 8084 imn = min(imn,ivec(idx)) 8085 idx = idx + inc 8086 end do 8087 8088 ifndmin = imn 8089 8090 return 8091 end 8092 8093*----------------------------------------------------------------------* 8094 8095 subroutine sweepvec(vec,ndim) 8096 8097* purpose: replace numerical zeroes by real zeroes 8098* (convenient for debugging) 8099 8100 implicit none 8101 8102 integer, intent(in) :: 8103 & ndim 8104 real(8), intent(inout) :: 8105 & vec(ndim) 8106 8107 integer :: 8108 & i 8109 real(8) :: 8110 & thr 8111 8112 thr = 100d0*epsilon(1d0) 8113 do i = 1, ndim 8114 if (abs(vec(i)).lt.thr) vec(i) = 0d0 8115 end do 8116 8117 return 8118 end 8119 SUBROUTINE WRT_2VEC(VEC1,VEC2,NDIM) 8120* 8121* Write two vectors 8122* 8123 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 8124 DIMENSION VEC1(NDIM),VEC2(NDIM) 8125C 8126 DO I=1,NDIM 8127 WRITE(6,1010) I,VEC1(I),VEC2(I) 8128 END DO 8129 1010 FORMAT(1H0,I5,2X,E18.10,2X,E18.10) 8130 RETURN 8131 END 8132 FUNCTION IELSUM_IND(IACT,NACT,IVEC) 8133* 8134* IELSUM_IND = sum_I=1 ^NACT IVEC(IACT(I)) 8135* 8136 INCLUDE 'implicit.inc' 8137 INTEGER IVEC(*), IACT(NACT) 8138* 8139 NTEST = 000 8140 IF(NTEST.GE.1000) THEN 8141 WRITE(6,*) ' Output from IELSUM_IND ' 8142 WRITE(6,*) ' NACT = ', NACT 8143 WRITE(6,*) ' IACT: ' 8144 CALL IWRTMA(IACT,1,NACT,1,NACT) 8145 END IF 8146* 8147 ISUM = 0 8148 DO I = 1, NACT 8149 ISUM = ISUM + IVEC(IACT(I)) 8150 END DO 8151* 8152 IELSUM_IND = ISUM 8153* 8154 RETURN 8155 END 8156 SUBROUTINE MULT_MAT_SPMAT_MAT(AOUT,AIN,X,NAOUT_R,NAOUT_C,NX_C, 8157 & IAINPAK ) 8158* 8159* AOUT = X*AIN, where AIN is sparse 8160* IF IAINPAK = 1, then AIN is symmetric and delivered in standard 8161* lower packed form(i*(i-1)/2+j ) 8162* 8163*. Jeppe Olsen, June 2012 - for transforming Hamilton matrices ... 8164* 8165* 8166 INCLUDE 'implicit.inc' 8167*. Input 8168 DIMENSION X(NAOUT_R,NX_C),AIN(*) 8169C AIN(NX_C,NAOUT_C) 8170*. Output 8171 DIMENSION AOUT(NAOUT_R,NAOUT_C) 8172* 8173 NTEST = 000 8174 IF(NTEST.GE.100) THEN 8175 WRITE(6,*) ' Info from MULT_MAT_SPMAT_MAT ' 8176 WRITE(6,*) ' =============================' 8177 WRITE(6,*) 8178 WRITE(6,'(A,3(2X,I6))') ' NAOUT_R,NAOUT_C,NX_C = ', 8179 & NAOUT_R,NAOUT_C,NX_C 8180 WRITE(6,'(A,I3)') ' IAINPAK = ', IAINPAK 8181 END IF 8182 8183 IF(NTEST.GE.1000) THEN 8184 WRITE(6,*) ' X and AIN matrices (input) ' 8185 CALL WRTMAT(X, NAOUT_R, NX_C,NAOUT_R, NX_C) 8186 WRITE(6,*) 8187 IF(IAINPAK.EQ.0) THEN 8188 CALL WRTMAT(AIN, NX_C, NAOUT_C,NX_C, NAOUT_C) 8189 ELSE 8190 CALL PRSYM(AIN,NX_C) 8191 END IF 8192 END IF 8193* 8194 ZERO = 0.0D0 8195 CALL SETVEC(AOUT,ZERO,NAOUT_R*NAOUT_C) 8196* 8197* AOUT(I,J) = Sum(k) X(I,K) AIN(K,J) 8198* 8199 DO K = 1, NX_C 8200 DO J = 1,NAOUT_C 8201 IF(IAINPAK.EQ.0) THEN 8202C AIN(NX_C,NAOUT_C) 8203 AINKJ = AIN((J-1)*NX_C + K) 8204 ELSE 8205 KJ = MAX(K,J)*(MAX(K,J)-1)/2 + MIN(K,J) 8206 AINKJ = AIN(KJ) 8207 END IF 8208 8209 IF(AINKJ.NE.0.0D0) THEN 8210 DO I = 1, NAOUT_R 8211 AOUT(I,J) = AOUT(I,J) + AINKJ*X(I,K) 8212 END DO 8213 END IF 8214 END DO 8215 END DO 8216* 8217 IF(NTEST.GE.1000) THEN 8218 WRITE(6,*) ' The AOUT matrix ' 8219 CALL WRTMAT(AOUT,NAOUT_R, NAOUT_C,NAOUT_R, NAOUT_C) 8220 END IF 8221* 8222 RETURN 8223 END 8224 FUNCTION IS_I1_EQ_I2(I1,I2,NDIM) 8225* Two integer arrays I1 and I2 are given. Are the identical 8226* 8227 INCLUDE 'implicit.inc' 8228 INTEGER I1(NDIM), I2(NDIM) 8229* 8230 NTEST = 000 8231* 8232 IDENT = 1 8233 DO I = 1, NDIM 8234 IF(I1(I).NE.I2(I)) IDENT = 0 8235 END DO 8236* 8237 IS_I1_EQ_I2 = IDENT 8238* 8239 IF(NTEST.GE.100) THEN 8240 WRITE(6,*) 'Output from IS_I1_EQ_I2 ' 8241 IF(IDENT.EQ.1) THEN 8242 WRITE(6,*) ' The two integer arrays are identical ' 8243 ELSE 8244 WRITE(6,*) ' The two integer arrays differs ' 8245 END IF 8246 END IF 8247* 8248 IF(NTEST.GE.1000) THEN 8249 WRITE(6,*) ' The two integer arrays ' 8250 CALL IWRTMA3(I1,1,NDIM,1,NDIM) 8251 WRITE(6,*) 8252 CALL IWRTMA3(I2,1,NDIM,1,NDIM) 8253 END IF 8254* 8255 RETURN 8256 END 8257 SUBROUTINE FIND_XVAL_WITH_THRES(A,THRES, XVAL, NDIM,IVAL) 8258* 8259* Find first element in A with ABS(A-XVAL).LE.THRES 8260* 8261*. Jeppe Olsen, Feb 13, 2013 8262* 8263 IMPLICIT REAL*8(A-H,O-Z) 8264*. Input 8265 DIMENSION A(NDIM) 8266* 8267 NTEST = 100 8268* 8269 IVAL = 0 8270 DO I = 1, NDIM 8271 IF(ABS(A(I)-XVAL).LE.THRES) THEN 8272 IVAL = I 8273 GOTO 1001 8274 END IF 8275 END DO 8276 1001 CONTINUE 8277* 8278 IF(IVAL.EQ.0) THEN 8279 WRITE(6,*) ' FIND_XVAL_WITH_THRES in trouble ' 8280 WRITE(6,*) ' Requested value and tolerance ', XVAL, THRES 8281 WRITE(6,*) ' No such value obtained ' 8282 END IF 8283* 8284 IF(NTEST.GE.100) THEN 8285 WRITE(6,*) ' output from FIND_XVAL_WITH_THRES ' 8286 WRITE(6,*) ' target value: ', XVAL 8287 WRITE(6,*) ' Obtained address ', IVAL 8288 END IF 8289* 8290 RETURN 8291 END 8292 8293 8294 8295c $Id$ 8296