1 SUBROUTINE GET_MINMAX_ADR_IN_CISPACE 2 & (MINAC,MAXAC,MINMAX_ORB,ISM,ISPC,IADR,NELMNT,ICNF) 3* 4* A space is given by a MINMAX distribution, MINMAX. 5* Obtain the addresses of components of this space in full space 6* and the configurations (if CSFs are in action) 7* 8*. Jeppe Olsen, July 3, 2013 9* 10 INCLUDE 'implicit.inc' 11 INCLUDE 'mxpdim.inc' 12 INCLUDE 'wrkspc-static.inc' 13 INCLUDE 'glbbas.inc' 14 INCLUDE 'crun.inc' 15 INCLUDE 'cicisp.inc' 16 INCLUDE 'spinfo.inc' 17 INCLUDE 'orbinp.inc' 18 INCLUDE 'csm.inc' 19 INCLUDE 'strbas.inc' 20 INCLUDE 'gasstr.inc' 21 INCLUDE 'stinf.inc' 22 INCLUDE 'strinp.inc' 23#include "errquit.fh" 24#include "mafdecls.fh" 25#include "global.fh" 26*. Input 27 INTEGER MINAC(*), MAXAC(*), MINMAX_ORB(*) 28*. Output 29 INTEGER IADR(*), ICNF(*) 30* 31 NTEST = 000 32* 33 IDUM = 0 34 CALL LUCIAQENTER('GTMNAD') 35 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTMNAD') 36* 37 IF(NTEST.GE.100) THEN 38 WRITE(6,*) 39 WRITE(6,*) ' Output from GET_MINMAX_ADR_IN_FULL_SPACE' 40 WRITE(6,*) ' ========================================' 41 WRITE(6,*) 42 WRITE(6,*) ' Symmetry and space in action ', ISM, ISPC 43 END IF 44* 45*. Standard def 46* 47 IATP = 1 48 IBTP = 2 49* 50 NAEL = NELEC(IATP) 51 NBEL = NELEC(IBTP) 52* 53 NOCTPA = NOCTYP(IATP) 54 NOCTPB = NOCTYP(IBTP) 55* 56 IOCTPA = IBSPGPFTP(IATP) 57 IOCTPB = IBSPGPFTP(IBTP) 58 59* 60*. Size of blocks (assumed in Z_BLKFO) 61* 62 IF(ISIMSYM.EQ.1.OR.ICISTR.EQ.2) THEN 63 LBLOCK = MXSOOB_AS 64 ELSE 65 LBLOCK = MXSOOB 66 END IF 67 IF(NOCSF.EQ.0.OR.ICNFBAT.EQ.-2) THEN 68CERR LBLOCK = MAX(NSD_FOR_OCCLS_MAX,LBLOCK) 69 LBLOCK = MAX(N_SDAB_PER_OCCLS_MAX,LBLOCK) 70 END IF 71 LBLOCK = MAX(LBLOCK,LCSBLK) 72 IF(NTEST.GE.100) WRITE(6,*) ' TEST: LBLOCK = ', LBLOCK 73* 74* 75* 76*. Information on blocks of CI-expansion 77* 78 ILTEST = 3006 79 CALL Z_BLKFO_FOR_CISPACE(ISPC,ISM,LBLOCK,ICOMP, 80 & NTEST,NCBLOCK,NCBATCH, 81 & int_mb(KCIOIO),int_mb(KCBLTP),NCOCCLS_ACT,int_mb(KCIOCCLS_ACT), 82 & int_mb(KCLBT),int_mb(KCLEBT),int_mb(KCLBLK),int_mb(KCI1BT), 83 & int_mb(KCIBT), 84 & int_mb(KCNOCCLS_BAT),int_mb(KCIBOCCLS_BAT),ILTEST) 85*. Space for strings 86 IF(NOCSF.EQ.1) THEN 87 CALL MEMMAN(KLASTR,MXNSTR*NAEL,'ADDL ',1,'KLASTR') !done 88 CALL MEMMAN(KLBSTR,MXNSTR*NBEL,'ADDL ',1,'KLBSTR') !done 89*. 90C GET_MINMAX_ADR_IN_CISPACE_SD( 91C & IADR,NDET_UT,MINAC,MAXAC,MINMAX_ORB,NSSOA,NSSOB,NOCTPA,NOCTPB, 92C & IOCTPA,IOCTPB,NBLOCK,IBLOCK, 93C & NAEL,NBEL, 94C & IASTR,IBSTR,IBLTP,NSMST, 95C & NGAS,NORB,NACOB,NINOB) 96 CALL GET_MINMAX_ADR_IN_CISPACE_SD( 97 & IADR,NELMNT,MINAC,MAXAC,MINMAX_ORB,int_mb(KNSTSO(IATP)), 98 & int_mb(KNSTSO(IBTP)), 99 & NOCTPA,NOCTPB,IOCTPA,IOCTPB,NCBLOCK,int_mb(KCIBT), 100 & NAEL,NBEL, 101 & int_mb(KLASTR),int_mb(KLBSTR),int_mb(KCBLTP),NSMST, 102 & NGAS,NTOOB,NACOB,NINOB) 103 ELSE 104C GET_MINMAX_ADR_IN_CISPACE_CSF(IADR,NELMNT,MINAC,MAXAC,MINMAX_ORB, 105C & NOCCLS_SPC,IOCCLS_SPC,ISYM,ICONF_OCC,NCONF_FOR_OPEN, 106C & INCLUDE_CONFS,ICONF_OCC_SEL,NOP_CONF_SEL,NCONF_OCC_SEL) 107C? WRITE(6,*) ' NCONF_SUB(1) = ', NCONF_SUB 108 CALL GET_MINMAX_ADR_IN_CISPACE_CSF(IADR,NELMNT,MINAC,MAXAC, 109 & MINMAX_ORB,NCOCCLS_ACT,int_mb(KCIOCCLS_ACT),ISM, 110 & int_mb(KICONF_OCC(ISM)),NCONF_PER_OPEN(1,ISM),1, 111 & int_mb(KSBCNFOCC),int_mb(KSBCNFOP),NCONF_SUB) 112 113 END IF 114* 115 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTMNAD') 116 CALL LUCIAQEXIT('GTMNAD') 117* 118 RETURN 119 END 120 SUBROUTINE GET_MINMAX_ADR_IN_CISPACE_SD( 121 & IADR,NDET_UT,MINAC,MAXAC,MINMAX_ORB,NSSOA,NSSOB, 122 & NOCTPA,NOCTPB,IOCTPA,IOCTPB,NBLOCK,IBLOCK, 123 & NAEL,NBEL, 124 & IASTR,IBSTR,IBLTP,NSMST, 125 & NGAS,NORB,NACOB,NINOB) 126* 127* Determine addresses of determinant in a CISPACE that 128* is in the MINMAX space defined by MINMAX 129* 130* 131* Jeppe Olsen, July 2013 132* 133 INCLUDE 'implicit.inc' 134 INCLUDE 'mxpdim.inc' 135*· 136*. General input 137 138*. Specific input 139 INTEGER MINAC(NGAS),MAXAC(NGAS),MINMAX_ORB(*) 140 INTEGER IBLOCK(8,NBLOCK) 141 INTEGER NSSOA(NSMST,*), NSSOB(NSMST,*) 142 INTEGER IBLTP(*) 143*. Scratch 144 DIMENSION IASTR(NAEL,*),IBSTR(NBEL,*) 145*. Local scratch 146 INTEGER IACC_CONF(MXPORB),IOCCX(MXPORB), IOCCX2(MXPORB) 147 INTEGER IACC2_CONF(MXPORB) 148*. Output 149 DIMENSION IADR(*) 150* 151 NTEST = 10 152 IF(NTEST.GE.10) THEN 153 WRITE(6,*) ' GET_MINMAX_ADR_IN_CISPACE_SD reporting:' 154 WRITE(6,*) ' =======================================' 155 WRITE(6,*) 156 WRITE(6,*) ' NINOB, NACOB, NSEL = ', NINOB, NACOB, NSEL 157 END IF 158* 159 IDET_IN = 0 160 IDET_UT = 0 161* 162 DO JBLOCK = 1, NBLOCK 163 IATP = IBLOCK(1,JBLOCK) 164 IBTP = IBLOCK(2,JBLOCK) 165 IASM = IBLOCK(3,JBLOCK) 166 IBSM = IBLOCK(4,JBLOCK) 167 IF(NTEST.GE.100) THEN 168 WRITE(6,'(A,4I4)') 169 & ' IATP, IBTP, IASM, IBSM = ', IATP, IBTP, IASM, IBSM 170 END IF 171* 172*. Obtain alpha strings of sym IASM and type IATP 173 IDUM = 0 174 CALL GETSTR_TOTSM_SPGP(1,IATP,IASM,NAEL,NASTR1,IASTR, 175 & NORB,0,IDUM,IDUM) 176*. Obtain Beta strings of sym IBSM and type IBTP 177 IDUM = 0 178 CALL GETSTR_TOTSM_SPGP(2,IBTP,IBSM,NBEL,NBSTR1,IBSTR, 179 & NORB,0,IDUM,IDUM) 180* 181 IF(IBLTP(IASM).EQ.2) THEN 182 IRESTR = 1 183 ELSE 184 IRESTR = 0 185 END IF 186* 187 NIA = NSSOA(IASM,IATP) 188 NIB = NSSOB(IBSM,IBTP) 189* 190 IBBAS = 1 191 IABAS = 1 192* 193 DO IB = IBBAS,IBBAS+NIB-1 194 IF(IRESTR.EQ.1.AND.IATP.EQ.IBTP) THEN 195 MINIA = IB - IBBAS + IABAS 196 ELSE 197 MINIA = IABAS 198 END IF 199 DO IA = MINIA,IABAS+NIA-1 200* 201 IDET_IN = IDET_IN + 1 202*. Is this determinent in MINMAX space 203*. Accumulated form 204C IAIB_TO_ACCCONF(IA,IB,NAEL,NBEL,IACC,NACOB,NINOB) 205 CALL IAIB_TO_ACCCONF 206 & (IASTR(1,IA),IBSTR(1,IB),NAEL, NBEL, 207 & IACC_CONF,NACOB,NINOB) 208*. Return to standard (not accumulated )form in IOCCX 209C REFORM_CONF_ACCOCC(JACOCC,JOCC,1,NORBL) 210 CALL REFORM_CONF_ACCOCC(IACC_CONF,IOCCX,1,NACOB) 211*. Reorder orbitals to the order that is assumed in the min max arrays 212C REO_OB_CONFE(ICONFP_IN, ICONFP_UT,IREO_NO,NOB) 213 CALL REO_OB_CONFE(IOCCX,IOCCX2,MINMAX_ORB,NACOB) 214*. And put reordered configuration in accumulated form 215 CALL REFORM_CONF_ACCOCC(IACC2_CONF,IOCCX2,2,NACOB) 216 IM_IN = IS_IACC_CONF_IN_MINMAX_SPC 217 & (IACC2_CONF,MINAC,MAXAC,NACOB) 218C IS_IACC_CONF_IN_MINMAX_SPC(IOCC,MIN_OCC,MAX_OCC,NORB) 219 IF(IM_IN.EQ.1) THEN 220*. Enroll! 221 IF(NTEST.GE.1000) 222 & WRITE(6,*) ' Determinant in MINMAX space' 223 IDET_UT = IDET_UT + 1 224 IADR(IDET_UT) = IDET_IN 225 END IF 226 END DO 227* ^ End of loop over alpha strings 228 END DO 229* ^ End of loop over beta strings 230 END DO 231* ^ End of loop over blocks 232 NDET_UT = IDET_UT 233* 234 IF(NTEST.GE.10) THEN 235 WRITE(6,*) ' Obtained number of dets in MINMAX-space ', IDET_UT 236 END IF 237 IF(NTEST.GE.1000) THEN 238 WRITE(6,*) ' Address of the obtained determinants' 239 CALL IWRTMA(IADR,1,NDET_UT,1,NET_UT) 240 END IF 241* 242 RETURN 243 END 244 SUBROUTINE IAIB_TO_ACCCONF(IA,IB,NAEL,NBEL,IACC,NACOB,NINOB) 245* 246* Alpha and beta strings are given, obtain corresponding 247* accumulated configuration 248* 249*. Note: configuration is only over active orbitals, whereas 250* strings has ninob + 1 as first active orbital 251* 252*. Jeppe Olsen, July 3, 2013 253* 254 INCLUDE 'implicit.inc' 255*. Input 256 INTEGER IA(NAEL),IB(NBEL) 257*. Output 258 INTEGER IACC(NACOB) 259* 260 NTEST = 000 261 IF(NTEST.GE.100) THEN 262 WRITE(6,*) ' Info from IAIB_TO_ACCCONF ' 263 WRITE(6,*) ' ==========================' 264 WRITE(6,*) 265 WRITE(6,*) ' NAEL, NBEL, NACOB = ', NAEL, NBEL,NACOB 266 END IF 267* 268 IZERO = 0 269 CALL ISETVC(IACC,IZERO,NACOB) 270* 271 DO JAEL = 1, NAEL 272 IORB = IA(JAEL) - NINOB 273 DO JORB = IORB, NACOB 274 IACC(JORB) = IACC(JORB) + 1 275 END DO 276 END DO 277* 278 DO JBEL = 1, NAEL 279 IORB = IB(JBEL) - NINOB 280 DO JORB = IORB, NACOB 281 IACC(JORB) = IACC(JORB) + 1 282 END DO 283 END DO 284* 285 IF(NTEST.GE.100) THEN 286 WRITE(6,*) ' Input: a- and b-strings: ' 287 CALL IWRTMA(IA,1,NAEL,1,NAEL) 288 CALL IWRTMA(IB,1,NBEL,1,NBEL) 289* 290 WRITE(6,*) ' Output: accumulated occupation ' 291 CALL IWRTMA(IACC,1,NACOB,1,NACOB) 292 END IF 293* 294 RETURN 295 END 296 SUBROUTINE GET_IAIB_FOR_SEL_DETS(ISM,ISPC,ISEL,NSEL,IA,IB) 297* 298* Obtain the alpha- and beta-strings for selected determinants in CI-space ISPC 299* 300*. Jeppe Olsen, July 4, 2013 (my old man would have turned 86 today...) 301* 302* 303 INCLUDE 'implicit.inc' 304 INCLUDE 'mxpdim.inc' 305 INCLUDE 'wrkspc-static.inc' 306 INCLUDE 'glbbas.inc' 307 INCLUDE 'crun.inc' 308 INCLUDE 'cicisp.inc' 309 INCLUDE 'spinfo.inc' 310 INCLUDE 'orbinp.inc' 311 INCLUDE 'csm.inc' 312 INCLUDE 'strbas.inc' 313 INCLUDE 'gasstr.inc' 314 INCLUDE 'stinf.inc' 315 INCLUDE 'strinp.inc' 316#include "errquit.fh" 317#include "mafdecls.fh" 318#include "global.fh" 319*. Input 320 INTEGER ISEL(NSEL) 321*. Output 322 INTEGER IA(*), IB(*) 323* 324 NTEST = 000 325* 326 IDUM = 0 327 CALL LUCIAQENTER('GTSLDT') 328 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTSLDT') 329* 330 IF(NTEST.GE.100) THEN 331 WRITE(6,*) 332 WRITE(6,*) ' Output from GET_IAIB_FOR_SEL_DETS ' 333 WRITE(6,*) ' ==================================' 334 WRITE(6,*) 335 WRITE(6,*) ' Symmetry and space in action ', ISM, ISPC 336 WRITE(6,*) ' Number of selected determinants ', NSEL 337 END IF 338 IF(NTEST.GE.200) THEN 339 WRITE(6,*) ' Selected determinants: ' 340 CALL IWRTMA(ISEL,1,NSEL,1,NSEL) 341 END IF 342* 343*. Standard def 344* 345 IATP = 1 346 IBTP = 2 347* 348 NAEL = NELEC(IATP) 349 NBEL = NELEC(IBTP) 350* 351 NOCTPA = NOCTYP(IATP) 352 NOCTPB = NOCTYP(IBTP) 353* 354 IOCTPA = IBSPGPFTP(IATP) 355 IOCTPB = IBSPGPFTP(IBTP) 356 357* 358*. Size of blocks (assumed in Z_BLKFO) 359* 360 IF(ISIMSYM.EQ.1.OR.ICISTR.EQ.2) THEN 361 LBLOCK = MXSOOB_AS 362 ELSE 363 LBLOCK = MXSOOB 364 END IF 365 IF(NOCSF.EQ.0.OR.ICNFBAT.EQ.-2) THEN 366CERR LBLOCK = MAX(NSD_FOR_OCCLS_MAX,LBLOCK) 367 LBLOCK = MAX(N_SDAB_PER_OCCLS_MAX,LBLOCK) 368 END IF 369 LBLOCK = MAX(LBLOCK,LCSBLK) 370 IF(NTEST.GE.100) WRITE(6,*) ' TEST: LBLOCK = ', LBLOCK 371* 372*. Information on blocks of CI-expansion 373* 374 ILTEST = 3006 375 CALL Z_BLKFO_FOR_CISPACE(ISPC,ISM,LBLOCK,ICOMP, 376 & NTEST,NCBLOCK,NCBATCH, 377 & int_mb(KCIOIO),int_mb(KCBLTP),NCOCCLS_ACT, 378 & int_mb(KCIOCCLS_ACT), 379 & int_mb(KCLBT),int_mb(KCLEBT),int_mb(KCLBLK),int_mb(KCI1BT), 380 & int_mb(KCIBT), 381 & int_mb(KCNOCCLS_BAT),int_mb(KCIBOCCLS_BAT),ILTEST) 382*. Space for strings 383 CALL MEMMAN(KLASTR,MXNSTR*NAEL,'ADDL ',1,'KLASTR') !done 384 CALL MEMMAN(KLBSTR,MXNSTR*NBEL,'ADDL ',1,'KLBSTR') !done 385*. 386 CALL GET_IAIB_FOR_SEL_DETS_IN( 387 & ISEL,NSEL,IA,IB,int_mb(KNSTSO(IATP)), 388 & int_mb(KNSTSO(IBTP)), 389 & NOCTPA,NOCTPB,IOCTPA,IOCTPB,NCBLOCK,int_mb(KCIBT), 390 & NAEL,NBEL, 391 & int_mb(KLASTR),int_mb(KLBSTR),int_mb(KCBLTP),NSMST, 392 & NGAS,NTOOB,NACOB,NINOB) 393* 394 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTSLDT') 395 CALL LUCIAQEXIT('GTSLDT') 396* 397 RETURN 398 END 399 SUBROUTINE GET_IAIB_FOR_SEL_DETS_IN( 400 & ISEL,NSEL,IA_UT,IB_UT,NSSOA,NSSOB,NOCTPA,NOCTPB, 401 & IOCTPA,IOCTPB,NBLOCK,IBLOCK, 402 & NAEL,NBEL, 403 & IASTR,IBSTR,IBLTP,NSMST, 404 & NGAS,NORB,NACOB,NINOB) 405* 406* Obtain alpha- and beta-strings for determinants with addresses given by ISEL 407* 408* 409* Jeppe Olsen, July 2013 410* 411 INCLUDE 'implicit.inc' 412 INCLUDE 'mxpdim.inc' 413*. Specific input 414 INTEGER ISEL(NSEL) 415 INTEGER IBLOCK(8,NBLOCK) 416 INTEGER NSSOA(NSMST,*), NSSOB(NSMST,*) 417 INTEGER IBLTP(*) 418*. Scratch 419 DIMENSION IASTR(NAEL,*),IBSTR(NBEL,*) 420*. Local scratch 421 DIMENSION IACC_CONF(MXPORB) 422*. Output 423 DIMENSION IA_UT(NAEL,NSEL),IB_UT(NBEL,NSEL) 424* 425 NTEST = 00 426 IF(NTEST.GE.100) THEN 427 WRITE(6,*) ' Info from GET_IAIB_FOR_SEL_DETS_IN ' 428 WRITE(6,*) ' Requested dets: ' 429 CALL IWRTMA(ISEL,1,NSEL,1,NSEL) 430 END IF 431* 432 IDET_IN = 0 433 IDET_UT = 1 434* 435 DO JBLOCK = 1, NBLOCK 436 IATP = IBLOCK(1,JBLOCK) 437 IBTP = IBLOCK(2,JBLOCK) 438 IASM = IBLOCK(3,JBLOCK) 439 IBSM = IBLOCK(4,JBLOCK) 440 IF(NTEST.GE.1000) THEN 441 WRITE(6,'(A,4I4)') 442 & ' IATP, IBTP, IASM, IBSM = ', IATP, IBTP, IASM, IBSM 443 END IF 444* 445*. Obtain alpha strings of sym IASM and type IATP 446 IDUM = 0 447 CALL GETSTR_TOTSM_SPGP(1,IATP,IASM,NAEL,NASTR1,IASTR, 448 & NORB,0,IDUM,IDUM) 449*. Obtain Beta strings of sym IBSM and type IBTP 450 IDUM = 0 451 CALL GETSTR_TOTSM_SPGP(2,IBTP,IBSM,NBEL,NBSTR1,IBSTR, 452 & NORB,0,IDUM,IDUM) 453* 454 IF(IBLTP(IASM).EQ.2) THEN 455 IRESTR = 1 456 ELSE 457 IRESTR = 0 458 END IF 459* 460 NIA = NSSOA(IASM,IATP) 461 NIB = NSSOB(IBSM,IBTP) 462* 463 IBBAS = 1 464 IABAS = 1 465* 466 DO IB = IBBAS,IBBAS+NIB-1 467 IF(IRESTR.EQ.1.AND.IATP.EQ.IBTP) THEN 468 MINIA = IB - IBBAS + IABAS 469 ELSE 470 MINIA = IABAS 471 END IF 472 DO IA = MINIA,IABAS+NIA-1 473 IF(NTEST.GE.1000) THEN 474 WRITE(6,*) ' IA, IB = ', IA, IB 475 END IF 476* 477 IDET_IN = IDET_IN + 1 478 IF(IDET_IN.EQ.ISEL(IDET_UT)) THEN 479*. Next det has been determined, enroll 480 CALL ICOPVE(IASTR(1,IA),IA_UT(1,IDET_UT),NAEL) 481 CALL ICOPVE(IBSTR(1,IB),IB_UT(1,IDET_UT),NBEL) 482 IF(IDET_UT.EQ.NSEL) GOTO 1001 483 IDET_UT = IDET_UT + 1 484 END IF 485 END DO 486* ^ End of loop over alpha strings 487 END DO 488* ^ End of loop over beta strings 489 END DO 490* ^ End of loop over blocks 491 1001 CONTINUE 492* 493*. Check that the required number of dets was obtained 494* 495 NDET_UT = IDET_UT 496 IF(NDET_UT.NE.NSEL) THEN 497 WRITE(6,*) ' Obtained number of dets differ from requested ' 498 WRITE(6,*) ' Obtained and requested dimensions: ', NDET_UT, NSEL 499 STOP ' Obtained number of dets differ from requested ' 500 END IF 501* 502 IF(NTEST.GE.1000) THEN 503 WRITE(6,*) ' Obtained alpha- and beta-strings: ' 504 DO JSEL = 1, NSEL 505 WRITE(6,*) ' Determinant ', ISEL(JSEL) 506 WRITE(6,'(4X,10I4)') (IA_UT(IEL,JSEL),IEL = 1, NAEL ) 507 WRITE(6,'(4X,10I4)') (IB_UT(IEL,JSEL),IEL = 1, NBEL ) 508 END DO 509 END IF 510* 511 RETURN 512 END 513 SUBROUTINE GET_SUBSPC_PRECOND_SPC(ISPC,ISM,ISEL,NSEL, 514 & CBLK) 515* 516* 517* Obtain the preconditioner subspace in the form of 518* a set of addresses of variables. 519* 520* It is assumed that diagonal has been calculated and stored on LUDIA 521* 522*. Jeppe Olsen, July 4, 2013 523* 524 INCLUDE 'implicit.inc' 525 INCLUDE 'mxpdim.inc' 526 INCLUDE 'wrkspc-static.inc' 527 INCLUDE 'glbbas.inc' 528 INCLUDE 'crun.inc' 529 INCLUDE 'clunit.inc' 530 INCLUDE 'strinp.inc' 531 INCLUDE 'cands.inc' 532 INCLUDE 'cgas.inc' 533 INCLUDE 'cecore.inc' 534 INCLUDE 'orbinp.inc' 535 INCLUDE 'cstate.inc' 536 INCLUDE 'gasstr.inc' 537 INCLUDE 'stinf.inc' 538#include "errquit.fh" 539#include "mafdecls.fh" 540#include "global.fh" 541*. Scratch holding a block of CI vector 542 DIMENSION CBLK(*) 543*. Output 544 DIMENSION ISEL(*) 545* 546 IDUM = 0 547 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SBSPCN') 548 CALL LUCIAQENTER('SBSPCN') 549 NTEST = 100 550 IF(NTEST.GE.100) THEN 551 WRITE(6,*) ' Info from GET_SUBSPC_PRECOND_SPC:' 552 WRITE(6,*) ' =================================' 553 WRITE(6,*) 554 WRITE(6,*) ' ISBSPC_SEL = ', ISBSPC_SEL 555 WRITE(6,*) ' MXP1, MXP2, MXQ = ', MXP1, MXP2, MXQ 556 END IF 557* 558*. Some general info 559* 560 IATP = 1 561 IBTP = 2 562* 563 NAEL = NELEC(IATP) 564 NBEL = NELEC(IBTP) 565* 566 NOCTPA = NOCTYP(IATP) 567 NOCTPB = NOCTYP(IBTP) 568* 569 IOCTPA = IBSPGPFTP(IATP) 570 IOCTPB = IBSPGPFTP(IBTP) 571* 572 MXDM = MXP1 + MXP2 + MXQ 573* 574*. Obtain the determinants to be included in the subspace 575* 576 IF(ISBSPC_SEL.EQ.1) THEN 577* 578*. Obtain subspace from lowest elements of CI diagonal 579* 580*. Local scratch 581 CALL MEMMAN(KL1,3*(MXDM+1),'ADDL ',1,'KL1 ') !done 582 CALL MEMMAN(KL2,2*(MXDM+1),'ADDL ',2,'KL2 ') !done 583 CALL MEMMAN(KL3,2*(MXDM+1),'ADDL ',2,'KL3 ') !done 584 WRITE(6,*) ' MXDM, KL1, KL2, KL3 = ', KL1, KL2, KL3 585 LBLK = -1 586*. And determine total subspace space 587 CALL FNDMND(LUDIA,LBLK,CBLK,MXDM,NPRDET,int_mb(KL1), 588 & dbl_mb(KL2),ISEL,dbl_mb(KL3),NTEST ) 589 590* 591* Check for boundaries between P1, P2, and Q 592* 593* P1-P2 594 IF(MXP1 .GT. 0 ) THEN 595 IIDET = MXP1 596 101 CONTINUE 597 IF(ABS(dbl_mb(KL3-1+IIDET+1)-dbl_mb(KL3-1+IIDET)) 598 & .LE. 0.000001D0) THEN 599 IIDET = IIDET - 1 600 GOTO 101 601 END IF 602 NP1 = IIDET 603 ELSE 604 NP1 = 0 605 END IF 606 IF(NTEST .GE. 2) 607 & WRITE(6,*) ' Actual dimension of P1 Space ', NP1 608*. P2 - Q space 609 IF(MXP2.GT.0) THEN 610 IF(MXP1+MXP2.GE.NPRDET) THEN 611 NP2 = NPRDET - NP1 612 ELSE 613 IIDET = MXP1 + MXP2 614 102 CONTINUE 615 IF( ABS(dbl_mb(KL3-1+IIDET+1)-dbl_mb(KL3-1+IIDET)) 616 & .LE. 0.0000001) THEN 617 IIDET = IIDET - 1 618 GOTO 102 619 END IF 620 NP2 = IIDET - NP1 621 END IF 622 ELSE 623 NP2 = 0 624 END IF 625 IF( NTEST .GE. 2 ) 626 & WRITE(6,*) ' Actual dimension of P2 Space ', NP2 627*. Q space 628 IF(MXQ.NE.0) THEN 629 NQ = MXP1 + MXP2 + MXQ - NP1 - NP2 630 ELSE 631 NQ = 0 632 END IF 633 IF( NTEST .GE. 2 ) 634 & WRITE(6,*) ' Actual dimension of Q Space ', NQ 635 NPVAR = NP1 + NP2 636 NPRVAR = NP1 + NP2 + NQ 637*. The determinants/CSFs should be delivered in ascending order, so sort 638* ORDINT(IINST,IOUTST,NELMNT,INO,IPRNT) 639 CALL ORDINT(ISEL,int_mb(KL1),NP1,dbl_mb(KL2),0) 640 CALL ICOPVE(int_mb(KL1),ISEL,NP1) 641*. Should add for P2 and Q space when and if relevant 642 ELSE IF (ISBSPC_SEL.EQ.2) THEN 643* 644*. Just choose the first elements 645* 646* No check that the dimensions are less or equal to dim of actual space.. 647 NP1 = MXP1 648 NP2 = MXP2 649 NQ = MXQ 650 NPVAR = NP1 + NP2 651 NPRVAR = NP1 + NP2 + NQ 652C ISTVC2(IVEC,IBASE,IFACT,NDIM) 653 CALL ISTVC2(ISEL,0,1,NPRVAR) 654* 655 ELSE IF (ISBSPC_SEL.EQ.3) THEN 656*. A CI space is chosen as explicit preconditioner space 657 WRITE(6,*) ' STOP: ISPSPC_SEL = 3 has not been programmed yet ' 658 STOP ' ISPSPC_SEL = 3 has not been programmed yet ' 659 ELSE IF (ISBSPC_SEL.EQ.4) THEN 660* 661* Obtain subspace from a MINMAX space 662* 663 IF(NOCSF.EQ.1) THEN 664*. Define parameters connected with CSFs 665 MULTS = MS2 + 1 666 MINOP = 0 667 END IF 668* 669 CALL GET_NSD_MINMAX_SPACE(ISBSPC_MINMAX(1,1),ISBSPC_MINMAX(1,2), 670 & ISBSPC_ORB,ISM,MS2,MULTS,NSD,NCM,NCSF,NCONF,LOCC) 671C GET_NSD_MINMAX_SPACE(MIN_OCC,MAX_OCC,ISYM,MS2X,MULTSX, 672C & NSD,NCM,NCSF,NCONF,LOCC) 673 IF(NOCSF.EQ.0) THEN 674 NP1 = NCSF 675 ELSE 676 NP1 = NCM 677 END IF 678 NPRVAR = NP1 679 NSEL = NP1 680 NP2 = 0 681 NQ = 0 682*. And the space 683C GET_MINMAX_ADR_IN_CISPACE(MINAC,MAXAC,ISM,ISPC,IADR,NELMNT) 684 CALL GET_MINMAX_ADR_IN_CISPACE( 685 & ISBSPC_MINMAX(1,1),ISBSPC_MINMAX(1,2),ISBSPC_ORB_INV, 686 & ISM,ISPC,ISEL,NSEL) 687 END IF 688 NSEL = NPRVAR 689* 690 IF(NTEST.GE.100) THEN 691 WRITE(6,*) ' Dimension of preconditioner subspace =', NP1 692 END IF 693 IF(NTEST.GE.200) THEN 694 WRITE(6,*) ' And the addresses of the subspace variables' 695 CALL IWRTMA(ISEL,1,NSEL,1,NSEL) 696 END IF 697* 698 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SBSPCN') 699 CALL LUCIAQEXIT('SBSPCN') 700* 701 RETURN 702 END 703 SUBROUTINE GET_SUBSPC_PRECOND_MAT(ISPC,ISM,H0,ISEL,NSEL, 704 & EIGVAL, EIGVEC) 705* 706* Obtain subspace preconditioner matrix for CI 707* 708* The preconditioner space is assumed already determined and is 709* given by SEL, NSEL 710* 711* 712* At the moment a single space preconditioner is assumed 713* 714* NP1, NP2, NQ transferred through common block 715* 716*. Jeppe Olsen, July 4, 2013, last change July 22, 2013 717* 718 INCLUDE 'implicit.inc' 719 INCLUDE 'mxpdim.inc' 720 INCLUDE 'wrkspc-static.inc' 721 INCLUDE 'glbbas.inc' 722 INCLUDE 'crun.inc' 723 INCLUDE 'clunit.inc' 724 INCLUDE 'strinp.inc' 725 INCLUDE 'cands.inc' 726 INCLUDE 'cgas.inc' 727 INCLUDE 'cecore.inc' 728 INCLUDE 'orbinp.inc' 729 INCLUDE 'cstate.inc' 730 INCLUDE 'gasstr.inc' 731 INCLUDE 'stinf.inc' 732 INCLUDE 'spinfo.inc' 733 INCLUDE 'lucinp.inc' 734#include "errquit.fh" 735#include "mafdecls.fh" 736#include "global.fh" 737*. Output 738 DIMENSION H0(*), ISEL(*), EIGVAL(*), EIGVEC(*) 739* 740 IDUM = 0 741 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'SBSPMT') 742 CALL LUCIAQENTER('SBSPMT') 743 NTEST = 100 744 IF(NTEST.GE.100) THEN 745 WRITE(6,*) ' Info from GET_SUBSPC_PRECOND_MAT: ' 746 WRITE(6,*) ' ==================================' 747 WRITE(6,*) 748 WRITE(6,*) ' ISPC, ISM = ', ISPC, ISM 749 WRITE(6,*) ' Dimension of subspace = ', NSEL 750 END IF 751 IF(NTEST.GE.1000) THEN 752 WRITE(6,*) ' Addresses of subspace ' 753 CALL IWRTMA(ISEL,1,NSEL,1,NSEL) 754 END IF 755 IF(NP2.NE.0.OR.NQ.NE.0) THEN 756 WRITE(6,*) ' NP2 or NQ ne 0, ', NP2, NQ 757 WRITE(6,*) ' Only P1 preconditioner in action ' 758 STOP ' NP2 or NQ ne 0 ' 759 END IF 760* 761*. Some general info 762* 763 IATP = 1 764 IBTP = 2 765* 766 NAEL = NELEC(IATP) 767 NBEL = NELEC(IBTP) 768* 769 NOCTPA = NOCTYP(IATP) 770 NOCTPB = NOCTYP(IBTP) 771* 772 IOCTPA = IBSPGPFTP(IATP) 773 IOCTPB = IBSPGPFTP(IBTP) 774* 775 MXDM = MXP1 + MXP2 + MXQ 776* 777 NPRVAR = NP1 778 NSEL = NPRVAR 779* 780* Obtain the SD/CSFs defining the P-space 781* 782COLD GET_IAIB_FOR_SEL_DETS( 783COLD & ISEL,NSEL,IA_UT,IB_UT,NSSOA,NSSOB,NOCTPA,NOCTPB, 784COLD & IOCTPA,IOCTPB,NBLOCK,IBLOCK, 785COLD & NAEL,NBEL, 786COLD & IASTR,IBSTR,IBLTP,NSMST, 787COLD & NGAS,NORB,NACOB,NINOB) 788 IF(NOCSF.EQ.1) THEN 789*. Obtain alpha and beta-strings for the selected determinants 790 CALL MEMMAN(KLIASTR,NPRVAR*NAEL,'ADDL ',1,'IASTR ') !done 791 CALL MEMMAN(KLIBSTR,NPRVAR*NBEL,'ADDL ',1,'IBSTR ') !done 792C GET_IAIB_FOR_SEL_DETS(ISM,ISPC,ISEL,NSEL,IA,IB) 793 CALL GET_IAIB_FOR_SEL_DETS(ISM,ISPC,ISEL,NPRVAR, 794 & int_mb(KLIASTR),int_mb(KLIBSTR)) 795* 796*. And obtain the corresponding Hamilton matrix 797* 798C DIHDJ2_LUCIA_CONF 799C & (IASTR,IBSTR,NIDET,JASTR,JBSTR,NJDET,NAEL,NBEL,IADOB,NORB, 800C & IHORS,HAMIL,C,SIGMA,IWORK,ISYM,ECORE,ICOMBI,PSIGN, 801C & NTERMS,NDIF0,NDIF1,NDIF2,I12OP,I_DO_ORBTRA,IORBTRA, 802C & NTOOB,RJ,RK) 803 XDUM = 0.0D0 804 LSCR = 4*NTOOB + NSEL 805 IF(PSSIGN.NE.0.0D0) THEN 806 ICOMBI_L = 1 807 ELSE 808 ICOMBI_L = 0 809 END IF 810 CALL MEMMAN(KLSCR,LSCR,'ADDL ',1,'LSCR ') !done 811 XRJ = -1.0D0 812 XRK = -1.0D0 813*. In DIHDJ2 it is assumed that the I-and J-strings are in different 814*. arrays (I-strings are interchanged when using combinations). 815*. add extra copy if combinations are active 816 IF(ICOMBI_L.EQ.0) THEN 817 KLJASTR = KLIASTR 818 KLJBSTR = KLIBSTR 819 ELSE 820 CALL MEMMAN(KLJASTR,NPRVAR*NAEL,'ADDL ',1,'LJASTR') !done 821 CALL MEMMAN(KLJBSTR,NPRVAR*NBEL,'ADDL ',1,'LJBSTR') !done 822 CALL ICOPVE(int_mb(KLIASTR),int_mb(KLJASTR),NPRVAR*NAEL) 823 CALL ICOPVE(int_mb(KLIBSTR),int_mb(KLJBSTR),NPRVAR*NBEL) 824 END IF 825* 826 CALL DIHDJ2_LUCIA_CONF( 827 & int_mb(KLIASTR),int_mb(KLIBSTR),NPRVAR, 828 & int_mb(KLJASTR),int_mb(KLJBSTR),NPRVAR,NAEL,NBEL,0,NTOOB, 829 & 1, H0,XDUM,XDUM,int_mb(KLSCR),ISM,ECORE,ICOMBI_L,PSSIGN, 830 & NTERMS, NDIF0,NDIF1,NDIF2,2,0,IDUM,NTOOB,XRJ,XRK) 831 ELSE 832* 833* CSF approach 834* 835C CNHCN_FOR_CNLIST(ICNOCC,ICNOP,NCN,HCSF,ISCR,SCR,RJ,RK) 836* 837* Scratch 838* 839 NOP_MAX = IMNMX(int_mb(KSBCNFOP),NCONF_SUB,2) 840 NPDT_MAX = NPDTCNF(NOP_MAX+1) 841 WRITE(6,*) ' NOP_MAX, NPDT_MAX = ', NOP_MAX, NPDT_MAX 842 LISCR = 2*NPDT_MAX*NACTEL + NPDT_MAX + 6*NACOB 843 LRSCR = 2*NPDT_MAX**2 844 CALL MEMMAN(KLISCR,LISCR,'ADDL ',1,'CNISCR') !done 845 CALL MEMMAN(KLRSCR,LRSCR,'ADDL ',2,'CNRSCR') !done 846C? WRITE(6,*) ' NCONF_SUB(2) = ', NCONF_SUB 847 CALL CNHCN_FOR_CNLIST(int_mb(KSBCNFOCC),int_mb(KSBCNFOP), 848 & NCONF_SUB,H0,int_mb(KLISCR),dbl_mb(KLRSCR),XRJ,XRK) 849C CNHCN_FOR_CNLIST(ICNOCC,ICNOP,NCN,HCSF,ISCR,SCR,RJ,RK) 850 END IF! Dets of CSFs are in use 851* 852 IF(NTEST.GE.1000) THEN 853 WRITE(6,*) ' Output subspace Hamilton matrix ' 854 CALL PRSYM(H0,NPRVAR) 855 END IF 856* 857*. Diagonalize 858* 859*. Outpack matrix to complete form 860 CALL TRIPAK(EIGVEC,H0,2,NPRVAR,NPRVAR) 861C TRIPAK(AUTPAK,APAK,IWAY,MATDIM,NDIM) 862*. and diagonalize 863 CALL MEMMAN(KLSCRVEC,NSEL,'ADDL ',2,'SCRVEC') !done 864C DIAG_SYMMAT_EISPACK(A,EIGVAL,SCRVEC,NDIM,IRETURN) 865 CALL DIAG_SYMMAT_EISPACK(EIGVEC,EIGVAL,dbl_mb(KLSCRVEC),NPRVAR, 866 & IRETURN) 867* 868 IF(NTEST.GE.100) THEN 869 WRITE(6,*) ' Lowest subspace eigenvalues: ' 870 NPRINT = 10 871 ELSE IF (NTEST.GE.1000) THEN 872 WRITE(6,*) ' Subspace eigenvalues: ' 873 NPRINT = NPRVAL 874 END IF 875 IF(NTEST.GE.100) THEN 876 CALL WRTMAT(EIGVAL,1,NPRINT,1,NPRINT) 877 END IF 878* 879 IF(NTEST.GE.1000) THEN 880 WRITE(6,*) ' Subspace eigenvectors ' 881 CALL WRTMAT(EIGVEC,NPRVAR,NPRVAR,NPRVAR) 882 END IF 883* 884* 885 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'SBSPMT') 886 CALL LUCIAQEXIT('SBSPMT') 887* 888 RETURN 889 END 890C KNCN_PER_OP_SM 891 SUBROUTINE AVE_CSFDIA_CNF(LUDIA,LUDIA_AV,NOCCLS_SPC,IOCCLS_SPC, 892 & ISM,CIVEC,NCN_PER_OP_SM) 893* 894* A CSF diagonal of H is given on LUDIA 895*. Average over elements belonging to the same configuration 896* 897*. Jeppe Olsen, July 19, 2013 898* 899 INCLUDE 'implicit.inc' 900 INCLUDE 'mxpdim.inc' 901 INCLUDE 'spinfo.inc' 902 INCLUDE 'lucinp.inc' 903 INCLUDE 'crun.inc' 904* 905 INTEGER NCN_PER_OP_SM(MAXOP+1,NIRREP,*) 906*. Specific input 907 INTEGER IOCCLS_SPC(NOCCLS_SPC) 908*. Scratch 909 DIMENSION CIVEC(*) 910* 911 IF(ICNFBAT.EQ.1) THEN 912 WRITE(6,*) ' Average of CSF diag not programmed for CNFBAT = 1' 913 STOP ' Average of CSF diag not programmed for CNFBAT = 1' 914 ELSE 915* 916 CALL REWINO(LUDIA) 917 CALL REWINO(LUDIA_AV) 918* 919 DO IIOCCLS = 1, NOCCLS_SPC 920 IOCCLS = IOCCLS_SPC(IIOCCLS) 921 CALL FRMDSCN(CIVEC,1,-1,LUDIA) 922 ICNBS = 1 923 DO IOPEN = 0, MAXOP 924 NNCNF = NCN_PER_OP_SM(IOPEN+1,ISM,IOCCLS) 925 NPCSF = NPCSCNF(IOPEN+1) 926 DO ICNF = 1, NNCNF 927 DIASUM = ELSUM(CIVEC(ICNBS),NPCSF) 928 AVE = DIASUM/FLOAT(NPCSF) 929 CALL SETVEC(CIVEC(ICNBS),AVE,NPCSF) 930 ICNBS = ICNBS + NPCSF 931 END DO 932 END DO 933 LENGTH = ICNBS - 1 934 CALL TODSCN(CIVEC,1,LENGTH,-1,LUDIA_AVE) 935 END DO 936 END IF ! CNFBAT switch 937* 938 RETURN 939 END 940 SUBROUTINE CNHCN_FOR_CNLIST(ICNOCC,ICNOP,NCN,HCSF,ISCR,SCR,RJ,RK) 941* 942* Calculate CI matrix for list of configurations specified by ICNOCC,ICNOP 943* 944*. Jeppe Olsen, July 2013 945* 946 INCLUDE 'implicit.inc' 947 INCLUDE 'mxpdim.inc' 948 INCLUDE 'glbbas.inc' 949 INCLUDE 'wrkspc-static.inc' 950 INCLUDE 'lucinp.inc' 951 INCLUDE 'spinfo.inc' 952 INCLUDE 'orbinp.inc' 953 INCLUDE 'cecore.inc' 954#include "errquit.fh" 955#include "mafdecls.fh" 956#include "global.fh" 957*. Specific input 958 INTEGER ICNOCC(*), ICNOP(*) 959 DIMENSION RJ(*), RK(*) 960*. Scratch through input 961 DIMENSION ISCR(*), SCR(*) 962*. Output 963 DIMENSION HCSF(*) 964* 965 NTEST = 1000 966 IF(NTEST.GE.100) THEN 967 WRITE(6,*) ' Output from CNHCN_FOR_CNLIST: ' 968 WRITE(6,*) ' ==============================' 969 WRITE(6,*) 970 WRITE(6,*) ' Number of configurations in action = ', NCN 971 END IF 972 973 CALL LUCIAQENTER('CNHCNL') 974 IDUM = 0 975 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'CNHCNL') 976*. Largest number of open shells 977 IOP_MAX = 0 978 NCSF_T = 0 979 DO ICN = 1, NCN 980 IOP_MAX = MAX(IOP_MAX,ICNOP(ICN)) 981 NCSF_T = NCSF_T + NPCSCNF(ICNOP(ICN)+1) 982 END DO 983 NCSF_MAX = NPCSCNF(IOP_MAX+1) 984*. Local memory for a H-matrix over a conf 985 LHCNF = NCSF_MAX**2 986 CALL MEMMAN(KLHCNF,LHCNF,'ADDL ',2,'HCNF ') !done 987* 988 IB_OCL = 1 989 IB_CSL = 1 990* 991 DO ICNL = 1, NCN 992 IOPL = ICNOP(ICNL) 993 ICLL = (NACTEL - IOPL)/2 994 IOCL = IOPL + ICLL 995 NCSFL = NPCSCNF(IOPL+1) 996 IB_CSR = 1 997 IB_OCR = 1 998 DO ICNR = 1, ICNL 999 IOPR = ICNOP(ICNR) 1000 ICLR = (NACTEL - IOPR)/2 1001 IOCR = IOPR + ICLR 1002 NCSFR = NPCSCNF(IOPR+1) 1003 IF(ICNL.EQ.ICNR) THEN 1004 ISYMG = 1 1005 ELSE 1006 ISYMG = 0 1007 END IF 1008*. For test 1009 ISYMG = 0 1010 1011*. H-matrix over Confs in WORK(KLHCNF) 1012C CNHCN_CSF_BLK(ICNL,IOPL,ICNR,IOPR,CNHCNM,IADOB, 1013C & IPRODT,DTOC,I12OP,ISCR,SCR,ECORE,IONLY_DIAG,ISYMG, 1014C & RJ, RK) 1015 CALL CNHCN_CSF_BLK(ICNOCC(IB_OCL),IOPL,ICNOCC(IB_OCR),IOPR, 1016 & dbl_mb(KLHCNF),NINOB,int_mb(KDFTP),int_mb(KDTOC), 1017 & 2,ISCR,SCR,ECORE,0,ISYMG,RJ,RK) 1018*. Expand to complete matrix 1019C EXTR_OR_CP_MAT(ABIG,LRBIG,LCBIG,ISYMBIG, 1020C & ASMA,LRSMA,LCSMA,ISYMSMA, 1021C & IOFFR,IOFFC,IEC) 1022 CALL EXTR_OR_CP_MAT(HCSF,NCSF_T,NCSF_T,1, 1023 & dbl_mb(KLHCNF),NCSFL,NCSFR,ISYMG,IB_CSL,IB_CSR,2) 1024 1025*. Update pointers 1026 IB_OCR = IB_OCR + IOCR 1027 IB_CSR = IB_CSR + NCSFR 1028 END DO ! Loop over ICNR 1029*. Update pointers 1030 IB_OCL = IB_OCL + IOCL 1031 IB_CSL = IB_CSL + NCSFL 1032 END DO ! Loop over ICNL 1033 1034 1035 1036 1037 CALL LUCIAQEXIT('CNHCNL') 1038 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'CNHCNL') 1039* 1040 RETURN 1041 END 1042 SUBROUTINE EXTR_OR_CP_MAT(ABIG,LRBIG,LCBIG,ISYMBIG, 1043 & ASMA,LRSMA,LCSMA,ISYMSMA, 1044 & IOFFR,IOFFC,IEC) 1045* 1046* 1047* Copy or extract a smaller matrix, ASMA, from/to a larger matrix, ABIG 1048* 1049* IEC = 1 => Extract from big to small matrix 1050* IEC = 2 => Extract from small to big matrix 1051* 1052*. Jeppe Olsen, July 19, 2013 1053* 1054 INCLUDE 'implicit.inc' 1055*. Input or output 1056 DIMENSION ASMA(*),ABIG(*) 1057* 1058 NTEST = 000 1059 IF(NTEST.GE.100) THEN 1060 WRITE(6,*) ' Info from EXTR_OR_CP_MAT' 1061 WRITE(6,*) ' ========================' 1062 WRITE(6,*) 1063 WRITE(6,*) ' LRBIG, LCBIG = ', LRBIG, LCBIG 1064 WRITE(6,*) ' LRSAM, LCSMA = ', LRSMA, LCSMA 1065 WRITE(6,*) ' IOFFR, IOFFC = ', IOFFR, IOFFC 1066 WRITE(6,*) ' ISYMBIG, ISYMSMA = ', ISYMBIG,ISYMSMA 1067 WRITE(6,*) ' IEC = ', IEC 1068 END IF 1069 IF(NTEST.GE.1000) THEN 1070 WRITE(6,*) ' Input small matrix ' 1071 IF(ISYMSMA.EQ.0) THEN 1072 CALL WRTMAT(ASMA,LRSMA, LCSMA, LRSMA, LCSMA) 1073 ELSE 1074 CALL PRSYM(ASMA, LRSMA) 1075 END IF 1076 END IF 1077* 1078* 1079*. Extract small matrix from larger 1080* 1081 DO JC_SMA = 1, LCSMA 1082 IF(ISYMSMA.EQ.0) THEN 1083 JRMIN = 1 1084 ELSE 1085 JRMIN = JC 1086 END IF 1087 DO JR_SMA = JRMIN, LRSMA 1088 JC_BIG = JC_SMA + IOFFC - 1 1089 JR_BIG = JR_SMA + IOFFR - 1 1090 IF(ISYMBIG.EQ.0.OR.(ISYMBIG.EQ.1.AND.JR_BIG.GE.JC_BIG)) THEN 1091 IF(ISYMSMA.EQ.0) THEN 1092 IADR_SMA = (JC_SMA-1)*LRSMA+JR_SMA 1093 ELSE 1094 IADR_SMA = JR_SMA*(JR_SMA-1)/2 + JC_SMA 1095 END IF 1096 IF(ISYMBIG.EQ.0) THEN 1097 IADR_BIG = (JC_BIG-1)*LRBIG+JR_BIG 1098 ELSE 1099 IADR_BIG = JR_BIG*(JR_BIG-1)/2 + JC_BIG 1100 END IF 1101 IF(IEC.EQ.1) THEN 1102 ASMA(IADR_SMA) = ABIG(IADR_BIG) 1103 ELSE 1104 ABIG(IADR_BIG) = ASMA(IADR_SMA) 1105 END IF 1106 END IF 1107 END DO 1108 END DO 1109* 1110 RETURN 1111 END 1112 SUBROUTINE GET_MINMAX_ADR_IN_CISPACE_CSF(IADR,NELMNT,MINAC,MAXAC, 1113 & MINMAX_ORB, 1114 & NOCCLS_SPC,IOCCLS_SPC,ISYM,ICONF_OCC,NCONF_FOR_OPEN, 1115 & INCLUDE_CONFS,ICONF_OCC_SEL,NOP_CONF_SEL,NCONF_OCC_SEL) 1116* 1117* Address in CI space of CSF's belonging to a given MINMAX space 1118* 1119* 1120*. Jeppe Olsen, July 2013 1121* 1122 INCLUDE 'implicit.inc' 1123 INCLUDE 'mxpdim.inc' 1124 INCLUDE 'spinfo.inc' 1125 INCLUDE 'lucinp.inc' 1126 INCLUDE 'orbinp.inc' 1127 REAL*8 INPROD 1128*. Input 1129 DIMENSION MINAC(NACOB),MAXOC(NACOB),MINMAX_ORB(NACOB) 1130 DIMENSION IOCCLS_SPC(NOCCLS_SPC) 1131 DIMENSION ICONF_OCC(*),NCONF_FOR_OPEN(*) 1132*. Local scratch 1133 INTEGER IOCCL(MXPORB),IOCCL2(MXPORB) 1134*. Output 1135 INTEGER IADR(*) 1136 INTEGER ICONF_OCC_SEL(*), NOP_CONF_SEL(*) 1137* 1138 CALL MEMMAN(IDUM,IDUM,'MARK ',IDUM,'GTMNCS') 1139 CALL LUCIAQENTER('GTMNCS') 1140 1141 1142 IOUT = 6 1143 NTEST = 10 1144 IF(NTEST.GE.10) THEN 1145 WRITE(IOUT,*) 1146 WRITE(IOUT,'(1H ,A)') ' ===================================== ' 1147 WRITE(IOUT,'(1H ,A)') ' Info from GET_MINMAX_ADR_IN_CISPACE_CS' 1148 WRITE(IOUT,'(1H ,A)') ' ===================================== ' 1149 WRITE(IOUT,*) 1150 WRITE(IOUT,*) 1151 END IF 1152* 1153* 1154*. Loop over occupation classes 1155* 1156* 1157 ISEL = 0 1158 NCIVAR = 0 1159 ICSF = 0 1160 NCONF_SEL = 0 1161 IBCONF_OCC_SEL = 1 1162 DO IIOCLS = 1, NOCCLS_SPC 1163 IOCLS = IOCCLS_SPC(IIOCLS) 1164*. Generate Conformation (only configurations are needed) 1165 CALL GEN_CNF_INFO_FOR_OCCLS(IOCLS,0,ISYM) 1166 NCSF_OCCLS = IELSUM(NCS_FOR_OC_OP_ACT,MAXOP+1) 1167 NCIVAR = NCIVAR + NCSF_OCCLS 1168* 1169 IF(NTEST.GE.200) THEN 1170 WRITE(6,*) ' IIOCLS, IOCLS, NCSF_OCCLS = ', 1171 & IIOCLS, IOCLS, NCSF_OCCLS 1172 END IF 1173*. Loop over configurations and CSF's for given configuration 1174 ICNBS0 = 1 1175 DO IOPEN = 0, MAXOP 1176 IF(NTEST.GE.200) WRITE(6,*) ' IOPEN = ', IOPEN 1177 ITYP = IOPEN + 1 1178 ICL = (NACTEL - IOPEN) / 2 1179 IOCC = IOPEN + ICL 1180*. Configurations of this type 1181 NNCNF = NCONF_FOR_OPEN(IOPEN+1) 1182 NNCSF = NPCSCNF(IOPEN+1) 1183 DO IC = 1, NNCNF 1184 IF(NTEST.GE.1000) WRITE(6,*) ' IC = ', IC 1185 ICNBS = ICNBS0 + (IC-1)*IOCC 1186 IF(NTEST.GE.1000) WRITE(6,*) ' IC, ICNBS = ', IC, ICNBS 1187*. Is this configuration in minmax? 1188*. Change first the configuration in the order required for the minmax check 1189*. packed to expanded: 1190C REFORM_CONF_OCC2(ICONF_EXP,ICONF_PACK,NORBL,NOCOBL,IWAY) 1191*. Packed in ICONF_OCC => expanded in IOCCL 1192 CALL REFORM_CONF_OCC2(IOCCL,ICONF_OCC(ICNBS),NACOB,IOCC,2) 1193C REO_OB_CONFE(ICONFE_IN, ICONFE_UT,IREO_NO,NOB) 1194*. Expanded in IOCCL => reordered expanded in IOCCL2 1195 CALL REO_OB_CONFE(IOCCL,IOCCL2,MINMAX_ORB,NACOB) 1196*. Reordered expanded in IOCCL2 to reordered packed in IOCCL 1197 CALL REFORM_CONF_OCC2(IOCCL2,IOCCL,NACOB,IOCC,1) 1198*. Reordered packed in IOCCL to reordered accumulated in IOCCL2 1199C REFORM_PACK_TO_ACC_CONF(IP_CONF,IA_CONF,IWAY,NOCAB,NACOB) 1200 CALL REFORM_PACK_TO_ACC_CONF(IOCCL,IOCCL2,1,IOCC,NACOB) 1201 IM_IN = IS_IACC_CONF_IN_MINMAX_SPC 1202 & (IOCCL2,MINAC,MAXAC,NACOB) 1203 IF(IM_IN.EQ.1) THEN 1204 CALL REFORM_PACK_TO_ACC_CONF(ICONF_OCC(ICNBS),IOCCL,1, 1205 & IOCC,NACOB) 1206 IF(NTEST.GE.1000) 1207 & WRITE(6,*) ' Configuration in minmax space' 1208 DO JCSF = 1, NNCSF 1209 ICSF = ICSF + 1 1210 ISEL = ISEL + 1 1211 IADR(ISEL) = ICSF 1212 END DO 1213 IF(INCLUDE_CONFS.EQ.1) THEN 1214 CALL ICOPVE 1215 & (ICONF_OCC(ICNBS),ICONF_OCC_SEL(IBCONF_OCC_SEL),IOCC) 1216 IBCONF_OCC_SEL = IBCONF_OCC_SEL + IOCC 1217 IF(NTEST.GE.1000) WRITE(6,*) ' IOCC, IBCONF_OCC_SEL = ', 1218 & IOCC, IBCONF_OCC_SEL 1219 NCONF_SEL = NCONF_SEL + 1 1220 IF(NTEST.GE.1000) WRITE(6,*) ' NCONF_SEL = ', NCONF_SEL 1221 NOP_CONF_SEL(NCONF_SEL) = IOPEN 1222 END IF 1223 ELSE 1224 ICSF = ICSF + NNCSF 1225 END IF ! IM_IN 1226 END DO !loop over configurations 1227*. Update pointer 1228 ICNBS0 = ICNBS0 + NNCNF*IOCC 1229 END DO ! Loop over IOPEN 1230 END DO ! Loop over occupation classes 1231 NSEL = ISEL 1232* 1233 IF(NTEST.GE.10) THEN 1234 WRITE(6,*) ' Number of selected CSFs and Confs', NSEL, NCONF_SEL 1235 END IF 1236* 1237 IF(NTEST.GE.100) THEN 1238 WRITE(6,*) ' Addresses of CSFs in space ' 1239 CALL IWRTMA(IADR,1,NSEL,1,NSEL) 1240 WRITE(6,*) 1241 WRITE(6,*) ' And the selected configurations:' 1242 IB = 1 1243 DO ICNF = 1, NCONF_SEL 1244 IOPEN = NOP_CONF_SEL(ICNF) 1245 IOCC = IOPEN + (NACTEL-IOPEN)/2 1246 CALL WRT_CONF(ICONF_OCC_SEL(IB),IOCC) 1247 IB = IB + IOCC 1248 END DO 1249 END IF 1250* 1251 IF(NSEL.NE.NELMNT.AND.NELMNT.GT.0) THEN 1252 WRITE(6,*) 1253 & ' Expected and actual number of CSFs differs: ', NELMNT,NSEL 1254 STOP 'Expected and actual number of CSFs differs' 1255 END IF 1256 1257* 1258 CALL MEMMAN(IDUM,IDUM,'FLUSM ',IDUM,'GTMNCS') 1259 CALL LUCIAQEXIT('GTMNCS') 1260 RETURN 1261 END 1262 SUBROUTINE REFORM_PACK_TO_ACC_CONF(IP_CONF,IA_CONF,IWAY, 1263 & NOCOB,NACOB) 1264* 1265* Reform between packed and accumulated form of configurations 1266* 1267* IWAY = 1 PACK => Accumulated 1268* = 2 Accumulated => Packed 1269* 1270*. Jeppe Olsen, July 22, 2013 1271* 1272 INCLUDE 'implicit.inc' 1273*. Input and output 1274 INTEGER IP_CONF(NOCOB),IA_CONF(NACOB) 1275* 1276 NTEST = 000 1277 IF(NTEST.GE.100) THEN 1278 WRITE(6,*) ' Info from REFORM_PACK_TO_ACC_CONF' 1279 WRITE(6,*) ' =================================' 1280 IF(IWAY.EQ.1) THEN 1281 WRITE(6,*) ' Packed to accumulated ' 1282 ELSE IF (IWAY.EQ.2) THEN 1283 WRITE(6,*) ' Accumulated to packed ' 1284 END IF 1285 END IF 1286* 1287 IF(IWAY.LT.1.OR.IWAY.GT.2) THEN 1288 WRITE(6,*) 1289 & ' REFORM_PACK_TO_ACC_CON: Illegal value of IWAY: ', IWAY 1290 STOP 'REFORM_PACK_TO_ACC_CON: Illegal value of IWAY ' 1291 END IF 1292* 1293 IF(IWAY.EQ.1) THEN 1294* 1295*. Packed to accumulated 1296* 1297 IZERO = 0 1298 CALL ISETVC(IA_CONF,IZERO,NACOB) 1299 DO IOC = 1, NOCOB 1300 IOB = ABS(IP_CONF(IOC)) 1301 IF(IP_CONF(IOC).GT.0) THEN 1302 IEL = 1 1303 ELSE 1304 IEL = 2 1305 END IF 1306 DO JOB = IOB, NACOB 1307 IA_CONF(JOB) = IA_CONF(JOB) + IEL 1308 END DO 1309 END DO 1310 ELSE 1311* 1312* Accumulated => packed 1313* 1314 IOC = 0 1315 DO IOB = 1, NACOB 1316 IF(IOB.EQ.1) THEN 1317 IEL = IA_CONF(1) 1318 ELSE 1319 IEL = IA_CONF(IOB)-IA_CONF(IOB-1) 1320 END IF 1321 IF(IEL.EQ.1) THEN 1322 IOC = IOC + 1 1323 IP_CONF(IOC) = IOB 1324 ELSE IF (IEL.EQ.2) THEN 1325 IOC = IOC + 1 1326 IP_CONF(IOC) = -IOB 1327 END IF 1328 END DO 1329 NOCOB = IOC 1330 END IF 1331* 1332 IF(NTEST.GE.100) THEN 1333 WRITE(6,*) ' Packed configuration: ' 1334 CALL IWRTMA(IP_CONF,1,NOCOB,1,NOCOB) 1335 WRITE(6,*) 1336 WRITE(6,*) ' Accumulated configuration ' 1337 CALL IWRTMA(IA_CONF,1,NACOB,1,NACOB) 1338 END IF 1339* 1340 RETURN 1341 END 1342 1343c $Id$ 1344