1!dalton_copyright_start 2! 3! 4!dalton_copyright_end 5 6module lucita_setup 7 8! stefan: interface to lucita setup routines which need to be called for each 9! mcscf/ci runtype 10 11 implicit none 12 13 public setup_lucita_orbital_string_cb 14 public setup_lucita_pointer_strings_work_space 15 public setup_lucita_initialize_work_space 16 public setup_lucita_cb_interface 17 public setup_lucita_check_input 18 public setup_lucita_mcci_wrkspc_dimensions 19 public setup_lucita_par_dist_in_seq 20#ifdef VAR_MPI 21 public setup_lucita_inc_wrkspc_alloc_cw 22#endif 23 24 private 25 26#include "priunit.h" 27 28contains 29 30 subroutine setup_lucita_orbital_string_cb(set_common_blocks, & 31 print_level) 32!******************************************************************************* 33! 34! purpose: interface routine to LUCITA setup routines which 35! will create the mandatory orbital, symmetry and string 36! information for LUCITA ci/mcscf calculations. 37! 38!******************************************************************************* 39 logical, intent(inout) :: set_common_blocks 40 integer, intent(in) :: print_level 41!------------------------------------------------------------------------------- 42!------------------------------------------------------------------------------- 43 44 select case(set_common_blocks) 45 case (.true.) 46! translate shell spaces into orbital spaces + create lucita/dalton reorder and index arrays 47 call orbinf(print_level) 48! calculate the number of string types 49 call strtyp_gas(print_level) 50! divide orbital spaces into inactive/active/secondary 51 call gasspc() 52! setup symmetry information 53 call syminf(print_level) 54! calculate the number of 1e- and 2e-integrals 55 call intdim(print_level) 56 call flshfo(lupri) 57 case (.false.) 58! do nothing... 59 end select 60 61 end subroutine setup_lucita_orbital_string_cb 62!******************************************************************************* 63 64 subroutine setup_lucita_pointer_strings_work_space(ci_space, & 65 current_symmetry, & 66 print_level) 67!******************************************************************************* 68! 69! purpose: interface routine to LUCITA setup routines which 70! will create the mandatory work space pointers, string 71! information for LUCITA ci/mcscf calculations on work space blocks. 72! 73!******************************************************************************* 74 integer, intent(in) :: ci_space 75 integer, intent(in) :: current_symmetry 76 integer, intent(in) :: print_level 77!------------------------------------------------------------------------------- 78!------------------------------------------------------------------------------- 79 80! allocate local and global arrays ==> set work space pointers 81 call lucita_alloc() 82! internal string information 83 call strinf_gas(print_level) 84! internal subspaces 85 call lcispc(ci_space, & 86 current_symmetry, & 87 print_level) 88 89 end subroutine setup_lucita_pointer_strings_work_space 90!******************************************************************************* 91 92 subroutine setup_lucita_initialize_work_space(work_space_in, & 93 work_space_out, & 94 work_space_in_length, & 95 work_space_out_length, & 96 luci_nmproc, & 97 nr_files, & 98 print_unit) 99!******************************************************************************* 100! 101! purpose: interface routine to LUCITA setup routines which 102! will create the mandatory work space pointers, string 103! information for LUCITA ci/mcscf calculations on work space blocks 104! as well as read in integrals (if applicable). 105! 106!******************************************************************************* 107 real(8), intent(inout) :: work_space_in(*) 108 real(8), intent(inout) :: work_space_out(*) 109 integer, intent(in ) :: work_space_in_length 110 integer, intent( out) :: work_space_out_length 111 integer, intent(in) :: luci_nmproc 112 integer, intent(in) :: nr_files 113 integer, intent(in) :: print_unit 114!------------------------------------------------------------------------------- 115 integer, parameter :: max_num_ttss_blocks = 20000 116 integer, parameter :: max_subspace_dim = 300 117 integer :: k1 118 integer :: kbase_lucita 119 integer :: dummy 120 integer(8) :: offset_2_work_space_out 121 integer(8) :: k8base_lucita 122 integer(8) :: work_space_out_length_scratch 123 logical, save :: first_time_print = .true. 124!------------------------------------------------------------------------------- 125 126! compute offset to LUCITA work space 127 call compoff(work_space_in,work_space_out,offset_2_work_space_out) 128 129#ifdef integer_test 130 print *,'K_OFFSET =',offset_2_work_space_out 131 ! integer :: kbase_lucita 132 ! integer*8 :: k8base_lucita 133 KBASE_LUCITA = offset_2_work_space_out 134 ! HJAaJ Aug 2008: 135 ! MEMMAN in LUCITA is using default integer type 136 ! while K_OFFSET is always INTEGER*8. 137 ! Therefore we use implicit conversion to KBASE_LUCITA. 138 ! Now we test if KBASE_LUCITA is OK: 139 K8BASE_LUCITA = KBASE_LUCITA 140 print *,'KBASE_LUCITA =',KBASE_LUCITA 141 print *,'K8BASE_LUCITA =',K8BASE_LUCITA 142 IF(K8BASE_LUCITA /= offset_2_work_space_out)THEN 143 WRITE (print_unit,'(/A/A,2I20//A)') & 144 'FATAL ERROR in LUCITA: offset is too big for i*4', & 145 'K_OFFSET and KBASE_LUCITA:',offset_2_work_space_out, kbase_lucita, & 146 '(See code in lucita/lucita_setup.F90)' 147 call quit('FATAL ERROR in LUCITA: offset is too big for i*4') 148 END IF 149#endif 150! 151! subtract dynamically allocated memory 152! the parameter values are based on an educated guess from my experience - stefan nov 2010 153 work_space_out_length_scratch = work_space_in_length & 154 - 2 * luci_nmproc - nr_files - 8 * max_num_ttss_blocks & 155 - (max_subspace_dim*(max_subspace_dim+1)/2) & 156 - 2 * max_subspace_dim**2 157 158 work_space_out_length = work_space_out_length_scratch 159 160 if(first_time_print)then 161 write(print_unit,'(/A,I18)') ' dimension of LUCITA work space : ', work_space_out_length 162 first_time_print = .false. 163 end if 164 165! initialize LUCITA internal memory 166 call memman(offset_2_work_space_out,work_space_out_length_scratch,'INI ',dummy,'DUMMY') 167 168 end subroutine setup_lucita_initialize_work_space 169!******************************************************************************* 170 171 subroutine setup_lucita_cb_interface() 172! 173! purpose: interface routine for general purpose lucita common blocks 174! the ci_run_id controls the redefinition of some variables 175! according to: 176! - CI calculation in general 177! - sigma-vector run 178! - density-matrix evaluation (1-/2-particle density matrix) 179! - CI vector analysis 180! - calculation of H_diagonal 181! 182! 183!******************************************************************************* 184 use lucita_cfg 185 use lucita_energy_types 186 use lucita_ci_task_interface, only: create_CI_task_list 187#ifdef VAR_MPI 188 use sync_coworkers 189#endif 190!------------------------------------------------------------------------------- 191#include "priunit.h" 192#include "mxpdim.inc" 193#include "lucinp.inc" 194#include "cstate.inc" 195#include "crun.inc" 196#include "cprnt.inc" 197#include "cgas.inc" 198#include "cands.inc" 199#include "comjep.inc" 200#include "oper.inc" 201#include "orbinp.inc" 202#include "intform.inc" 203#include "cc_exc.inc" 204! common block for parallel calculations 205#include "parluci.h" 206! common blocks with orbital/energy information outside the LUCITA world (== within DALTON) 207#include "inforb.h" 208#include "maxorb.h" 209#include "infinp.h" 210!******************************************************************************* 211 integer :: i, j, ntoob_local 212 integer :: mxelr1, mxelr2, nimx, nimn, nemn, nemx, namx, namn 213 integer :: ispin1, ispin2 ! these variables are not active yet... 214!------------------------------------------------------------------------------- 215 216! set internal print units (luwrt on common block in parluci.h) 217 luwrt = lupri 218! initialize point group D2H and its subgroups 219 pntgrp = 1 220! default number of point group irreps in lucita 221 nirrep = lucita_cfg_nr_ptg_irreps 222 nsmob = nirrep 223! orbital environment sync with Dalton 224 naos_env(1:nirrep) = naos_lucita(1:nirrep) 225 nmos_env(1:nirrep) = nmos_lucita(1:nirrep) 226! nuclear repulsion energy 227 ecore_orig = lucita_cfg_core_energy 228! initialize variables used for other point groups 229 maxml = -1 230 maxl = -1 231! internal CI space 232 intspc = 1 !??? 233! # of active e- 234 luci_nactel = lucita_cfg_nr_active_e 235! inactive shells 236 call izero(ninash,nirrep) 237! inactive shells - 2 238 call izero(ninobs,mxpobs) 239! Core shells ( = RAS0 shells) only relevant for extspace > 0 240 call izero(nrs0sh,nirrep) 241! ras 1, 2, 3 and 4 242 mxr4tp = 1 243 mxer4 = 0 244 call izero(nrssh(1,1),nirrep) 245 call izero(nrssh(1,2),nirrep) 246 call izero(nrssh(1,3),nirrep) 247 call izero(nrs4sh(1,mxr4tp),nirrep) 248! ? 249 mnrs10 = -1 250 mxrs30 = -1 251 mnrs1r = mnrs10 252 mxrs3r = mxrs30 253! selection of internal configurations - no 254 intsel = 0 255 mults = lucita_cfg_is_spin_multiplett 256 ms2 = mults - 1 ! MS(MAX) = S set by default 257 ispin1 = lucita_cfg_spin1_2el_op 258 ispin2 = lucita_cfg_spin2_2el_op 259! reference symmetry 260 irefsm_c = lucita_cfg_csym 261 irefsm_hc = lucita_cfg_hcsym 262 irefsm = irefsm_c 263! transfer to common block cands 264 icsm = irefsm_c 265 issm = irefsm_hc 266 icspc = 1 267 isspc = 1 268! initialize variables on comjep.inc 269 mxacj = 0 270 mxacij = 0 271 mxaadst = 0 272! roots to be obtained 273 nroot = lucita_cfg_nr_roots 274 do i = 1, nroot 275 iroot(i) = i 276 END DO 277! state of interest (if particular convergence to a given state is desired) 278 c_state_of_interest = lucita_cfg_icstate 279! standard davidson 280 idiag = 1 281! no perturbative Hamiltonian 282 MXP1 = 0 283 MXP2 = 0 284 MXQ = 0 285 IPERTOP = 0 286! max # of Davidson iterations 287 MAXIT = lucita_cfg_max_nr_dav_ci_iter 288! restart ci 289 irestr = lucita_cfg_restart_ci 290! integrals imported from SIRIUS/DALTON 291 INTIMP = 5 292 ENVIRO(1:6) = 'DALTON' 293! in core option for integrals - default: in core 294 incore = 1 295! no deleted shells 296 call izero(ndelsh,nirrep) 297! no spin/ml combination factors 298 pssign = 0.0D0 299 plsign = 0.0D0 300 if(pssign.eq.0.0d0.and.plsign.eq.0.0d0)then 301 IDC = 1 302 else if(pssign.ne.0.0d0.and.plsign.eq.0.0d0)then 303 IDC = 2 304 else if(pssign.eq.0.0d0.and.plsign.ne.0.0d0)then 305 IDC = 3 306 else if(pssign.ne.0.0d0.and.plsign.ne.0.0d0)then 307 IDC = 4 308 end if 309 plus_combi = lucita_cfg_plus_combi ! plus combination of start vectors 310! default print levels - zero for the time being - should be 311! controlled via input keyword 312 IPRSTR = 0 313 IPRCIX = IPRSTR 314 IPRORB = IPRSTR 315 IPRDIA = IPRSTR 316 IPRXT = IPRSTR 317 IPRRSP = IPRSTR 318 IPRDEN = IPRSTR 319 IPROCC = IPRSTR 320 IPRNCIV = 0 321 if(lucita_cfg_analyze_cvec) iprnciv = 1 322! set timing printouts for parallel calculations 323 timing_par = .false. 324 if(lucita_cfg_timing_par) timing_par = .true. 325! max davidson subspace 326 mxciv = max(6*nroot, lucita_cfg_max_dav_subspace_dim) 327 if(idiag == 2) mxciv = max(2*nroot, lucita_cfg_max_dav_subspace_dim) 328! storage mode for vectors 329! complete vector + block version in core 330! icistr = 1 331! default is three type-type-symmetry blocks 332 icistr = 3 333! no csf - determinants == default 334 NOCSF = 1 335! read in integrals 336 NOINT = 0 337! NOINT = 1 ! for densities/analysis ... 338! do not dum integrals 339 IDMPIN = 0 340! define dimension of resolution matrices 341!SK12 mxinka = 100000 342 mxinka = 1000 343! use CJKAIB matrices as intermediate matrices in alpha-beta-loop 344 icjkaib = 1 345! use minimal operatioon count method for alpha-alpha and beta-beta 346! - default: do not use it 347 MOCAA = 0 348! use minimal operatioon count method for alpha-beta 349! - default: do not use it 350 MOCAB = 0 351! initial CI in reference space 352! - default: no 353 INIREF = 0 354! restart from reference CI expansion 355 IRESTRF = 0 356! initialize core energy 357 ECORE = 0.0D0 358! do not use perturbation theory for zero order space 359 IPERT = 0 360 NPERT = 0 361! no approximate Hamiltonian in reference space 362 IAPRREF = 0 363 MNRS1RE = MNRS1R 364 MXRS3RE = MXRS3R 365! no approximate Hamiltonian in zero order space 366 IAPRZER = 0 367 MNRS1ZE = MNRS10 368 MXRS3ZE = MXRS30 369! default # of orbital space occupations 370 NCISPC = lucita_cfg_nr_calc_sequences 371 NCMBSPC = NCISPC 372! general sequencer : default is just straight sequence of CI with default number of iterations 373! thus no sequence of calculations: ci, pert, cc,... 374 DO i = 1, NCMBSPC 375 LCMBSPC(i) = 1 376 ICMBSPC(1,i) = i 377 NSEQCI(i) = 1 378 CSEQCI(1,i) = 'CI' 379 ISEQCI(1,i) = MAXIT 380 END DO 381! energy convergence of CI 382! THRES_E = 1.0D-10 383 THRES_E = lucita_cfg_convergence_c 384 THRES_E_aux = lucita_cfg_auxiliary_conv_c 385! threshold on energy and wave function corrections in truncation of classes (NOT active) 386 E_THRE = 0.0d0 387 C_THRE = 0.0d0 388 E_CONV = 0.0d0 389 C_CONV = 0.0d0 390! do not call EXTENDED KOOPMANS' THEOREM ROUTINE 391 IEXTKOP = 1 392! do not save first order wave function correction to disc (if icistr == 1) 393 IC1DSC = 0 394! no perturbation in subspaces spaces 395 IH0SPC = 0 396! reference root for Perturbation theory 397 IRFROOT = NROOT 398! default handling of degenrences of initial CI vectors 399! - no action 400 INIDEG = 0 401! do not use modified Hamilton operator in CI optimization 402 XLAMBDA = 1.0D0 403! length of smallest block for batch of C an Sigma vectors 404 LCSBLK = max(100000,lucita_cfg_max_batch_size) 405! final orbitals 406 IFINMO = 1 ! natural orbitals (if at all) 407! default: no class selection unless we do teraci (which is disabled... ) 408 ICLSSEL = 0 409 if(idiag == 2) ICLSSEL = 1 410 411! perturbation expansion of EKT, default is no 412 IPTEKT = 0 413! root used to define zero order Hamiltonian 414 IH0ROOT = NROOT 415! no restart in CI calculation 2 416 IRST2 = 0 417! skip initial evaluation of energy from CI calc 2 418! ISKIPEI = 1 419! symmetry of X, Y and Z - zero because properties + transition properties are disabled 420 ITRAPRP = 0 421 NPROP = 0 422 DO i = 1, 3 423 IXYZSYM(i) = 0 424 END DO 425! no CI response 426 IRESPONS = 0 427 NRESP = 0 428 N_AVE_OP = 0 429! max # of iterations in linear equations (ci response) 430 MXITLE = 20 431! not root homing 432 IROOTHOMING = 0 433! calculation of density matrices 434 idensi = lucita_cfg_density_calc_lvl 435! calculate spin densities 436 ispnden = lucita_cfg_spindensity_calc_lvl 437 !> set level of density calculation equal to spin-density level to avoid any inconsistencies... 438 if(ispnden > idensi)then 439 idensi = ispnden 440 lucita_cfg_density_calc_lvl = ispnden 441 end if 442! no particle-hole simplification in use for compatibility with densities 443! jeppe + stefan: april 2011 444 iuse_ph = 0 445 if(idensi > 0) IUSE_PH = 0 446! allow the sigma routine to take advice 447 IADVICE = 0 448 if(IUSE_PH > 0) IADVICE = 1 449! do not transform CI vectors to alternative orbital representation 450 ITRACI = 0 451 ITRACI_CR = 'COMP ' 452 ITRACI_CN = 'NATURAL ' 453! do no separate strings into active and passive parts 454 IUSE_PA = 0 455! no perturbation expansion of Fock matrix 456 IPTFOCK = 0 457! no restart of CC with CI coefficients 458 I_RESTRT_CC = 0 459! use relaxed densities for properties 460! default: do not use them 461 IRELAX= 0 462 if(IRELAX > 0) IDENSI = 2 463! external space calculation - default: no 464 EXTSPC = 0 465 MXHR0 = 0 466! setting of parallel I/O model 467 IIOMOD = 0 468 IF(LUCI_NMPROC .GT. 1) IIOMOD = 1 469! parallel distribution routine 470 idistroute = lucipar_cfg_ttss_dist_strategy 471! Truncate residual vectors before creating new trial vector? 472! (14-jun-07, hjaaj) 473 trunc_fac = lucita_cfg_accepted_truncation 474! memory reduction multiplier ... 475 ismemfac = lucipar_cfg_mem_reduction_multp 476! LUCITA is used in real calculations: no complex part 477 irc_save = 1 478! normal integral accessed 479 IH1FORM = 1 480 IH2FORM = 1 481 I_RES_AB = 0 482! CI not CC 483 ICC_EXC = 0 484! default: complete operator (1e- + 2e-) 485 i12 = lucita_cfg_el_operator_level 486 487 if(lucita_cfg_initialize_cb)then 488 489! generalized active space concept, define orbital spaces 490! ------------------------------------------------------- 491 ngas = lucita_cfg_nr_gas_spaces 492 493 if(lucita_cfg_ci_type(1:6) == 'RASCI ')then 494 495 ngas = 3 496! check for atypical RAS (no RAS3): 497 i = 0 498 do j = 1, nirrep 499 i = i + ngsh_lucita(3,j) 500 end do 501 if(i <= 0 ) ngas = 2 502 end if 503 504 do i = 1, ngas 505 do j = 1, nirrep 506 NGSSH(j,i) = ngsh_lucita(i,j) 507 end do 508 end do 509 510 511! check for maximum number of orbitals per space and symmetry 512 do i = 1, NGAS 513 do j = 1, NIRREP 514 if(NGSSH(j,i) > MXTSOB)then 515 print *, ' too many orbitals per space and symmetry!' 516 print *, ' my maximum is ',MXTSOB 517 print *, ' please redefine your active spaces or if you are doing RASCI please use the GA setup.' 518 call quit('*** error in setup_lucita_cb_interface: too many orbitals per space and symmetry!') 519 end if 520 end do 521 end do 522 523! set orbital space occupations 524 select case(lucita_cfg_ci_type(1:6)) 525! ras 526 case('RASCI ') 527 528 if(luci_nactel <= 0) call quit('*** # active e- <= 0... ***') 529 530 nimx = lucita_cfg_max_e_ras1 531 nimn = lucita_cfg_min_e_ras1 532 nemn = LUCI_NACTEL 533 nemx = LUCI_NACTEL 534 namx = nemx - lucita_cfg_min_e_ras3 535 namn = namx - lucita_cfg_max_e_ras3 536 igsoccx(1,1,1) = nimn 537 igsoccx(1,2,1) = nimx 538 igsoccx(2,1,1) = namn 539 igsoccx(2,2,1) = namx 540! write(lupri,*) 'nimn, nimx, namn, namx, nemx, nemn', & 541! nimn, nimx, namn, namx, nemx, nemn 542 if(ngas > 2)then 543 igsoccx(3,1,1) = nemn 544 igsoccx(3,2,1) = nemx 545 end if 546 if(namx > luci_nactel ) call quit('*** reconsider your RAS setup - it is wrong... ***') 547! gas 548 case('GASCI ') 549 do i = 1, ngas 550 do j = 1, 2 551 igsoccx(i,j,1) = ngso_lucita(i,j) 552 end do 553 end do 554 end select 555 556 if(LUCI_NACTEL /= igsoccx(ngas,2,1)) then 557 write(lupri,*) 'Number of active electrons does not match total number of electrons in active spaces.' 558 call quit('*** error in setup_lucita_cb_interface: Number of active'// & 559 ' electrons does not match total number of electrons in active spaces.') 560 end if 561 562 ntoob_local = 0 563 do i = 1, ngas 564 do j = 1, nirrep 565 ntoob_local = ntoob_local + NGSSH(j,i) 566 end do 567 end do 568 569 if(LUCI_NACTEL > 2*ntoob_local)then 570 write(lupri,*) 'Number of active electrons exceeds the orbital space:',LUCI_NACTEL,'>',2*NTOOB_local 571 write(lupri,*) 'Consider Pauli´s famous principle and restart!' 572 call quit('*** error in setup_lucita_cb_interface: Number of active electrons exceeds the orbital space.') 573 end if 574 575! set file handles for reading/writing, etc. 576 call set_file_handles(irefsm) 577 578 579 end if ! lucita_cfg_initialize_cb check 580 581! cross-check input and print LUCITA settings 582 call setup_lucita_check_input(lucita_ci_run_id,igsoccx,ngssh,ngas) 583 584! create the ci_task_list based on the CI run-id and input parameters 585 call create_CI_task_list(lucita_ci_run_id, & 586 iprnciv, & 587 idensi, & 588 ci_task_list, & 589 max_ci_tasks) 590 591! we are done :) - return 592 593 end subroutine setup_lucita_cb_interface 594!******************************************************************************* 595 596 subroutine setup_lucita_check_input(ci_run_id,igsoccx,ngssh,ngas) 597!******************************************************************************* 598! 599! purpose: cross-check the mandatory LUCITA input variables to tally with 600! a reasonable setting. 601! 602!******************************************************************************* 603 use lucita_cfg 604#include "priunit.h" 605#include "parluci.h" 606#include "mxpdim.inc" 607!------------------------------------------------------------------------------- 608 character (len=12), intent(in) :: ci_run_id 609 integer , intent(in) :: igsoccx(mxpngas,2,mxpici) 610 integer , intent(in) :: ngssh(mxpirr,mxpngas) 611 integer , intent(in) :: ngas 612!------------------------------------------------------------------------------- 613 integer :: print_lvl 614 615! 616! CI type for LUCIA (no default) 617 if(lucita_cfg_ci_type(1:4).eq.'none')then 618 write(lupri,*) ' Keyword for type of CI calculation missing. ' 619 write(lupri,*) ' This keyword is mandatory. ' 620 call quit(' *** error in setup_lucita_check_input: keyword .CITYPE not specified.') 621 else 622 if(lucita_cfg_ci_type(1:6).ne.'GASCI '.and. lucita_cfg_ci_type(1:6).ne.'RASCI ')then 623 write(lupri,'(//A//2A/A)') & 624 ' Type of CI calculation not properly specified.', & 625 ' You have chosen: ',lucita_cfg_ci_type, & 626 ' Allowed types : GASCI and RASCI' 627 call quit(' *** error in setup_lucita_check_input: wrong input to keyword .CITYPE specified.') 628 end if 629 end if 630 631! # of active e- 632 if(lucita_cfg_nr_active_e < 0)then 633 write(lupri,'(//A/A/)') ' Number of active electrons NACTEL must be', & 634 ' specified for this type of calculation. Quitting.' 635 call quit(' *** error in setup_lucita_check_input: # electrons .NACTEL must be specified.') 636 end if 637 638! spin multiplicity 639 if(lucita_cfg_is_spin_multiplett < 0)then 640 write(lupri,*) 'Spin multiplicity .MULTIP is a MANDATORY keyword.' 641 write(lupri,*) 'Specify and restart.' 642 call quit(' *** error in setup_lucita_check_input: spin multiplicity .MULTIP must be specified in any case.') 643 else 644! check consistency of # of e- and spin multiplicity 645! case a: even - even 646 if(mod(lucita_cfg_nr_active_e,2) == 0 .and. mod(lucita_cfg_is_spin_multiplett,2) == 0) then 647 write(lupri,*) 'Illegal spin multiplicity given: # of e- even, spin mult. even.' 648 call quit(' *** error in setup_lucita_check_input: spin multiplicity is impossible.') 649! case b: odd - odd 650 else if(mod(lucita_cfg_nr_active_e,2) > 0 .and. mod(lucita_cfg_is_spin_multiplett,2) > 0) then 651 write(lupri,*) 'Illegal spin multiplicity given: # of e- odd, spin mult. odd.' 652 call quit(' *** error in setup_lucita_check_input: spin multiplicity is impossible.') 653! case c: odd - even 654 else if(mod(lucita_cfg_nr_active_e,2) > 0 .and. mod(lucita_cfg_is_spin_multiplett,2) == 0) then 655! case c.1: spin mult. < 2 or > (# active e- + 1) 656 if(lucita_cfg_is_spin_multiplett < 2 .or. lucita_cfg_is_spin_multiplett > (lucita_cfg_nr_active_e + 1))then 657 write(lupri,'(//A/A/)') ' Illegal spin multiplicity given.', & 658 ' Compare with number of active electrons.' 659 call quit(' *** error in setup_lucita_check_input: spin multiplicity is impossible.') 660 end if 661! case d: even - odd 662 else if(mod(lucita_cfg_nr_active_e,2) == 0 .and. mod(lucita_cfg_is_spin_multiplett,2) > 0)then 663! case d.1: spin mult. < 1 or > (# active e- + 1) 664 if(lucita_cfg_is_spin_multiplett < 1 .or. lucita_cfg_is_spin_multiplett > (lucita_cfg_nr_active_e+1))then 665 write(lupri,'(//A/A/)') ' Illegal spin multiplicity given.', & 666 ' Compare with number of active electrons.' 667 call quit(' *** error in dalton_lucita: spin multiplicity is impossible.') 668 end if 669 end if 670 end if 671 672! global print parameter 673 if(lucita_cfg_global_print_lvl > 4)then 674 write(lupri,*) 'Invalid print flag. Check .PRINTG.' 675 write(lupri,*) 'lucita_cfg_global_print_lvl = ', lucita_cfg_global_print_lvl 676 call quit(' *** error in setup_lucita_check_input: global print level .PRINTG too high. 0 <= range <= 4') 677 end if 678 679! inactive shells 680 if(.not.lucita_cfg_inactive_shell_set)then 681 write(lupri,*) 'Number of inactive orbitals per sym' 682 write(lupri,*) 'has to be specified. This is mandatory' 683 write(lupri,*) 'in a GASCI/RASCI calculation.' 684 call quit(' *** error in setup_lucita_check_input: inactive orbitals .INACTI not specified for RASCI calculation.') 685 end if 686! 687! Orbital distribution in GAS spaces (no defaults if GASCI) 688 if(lucita_cfg_nr_gas_spaces < 1)then 689 if(lucita_cfg_ci_type(1:6).eq.'GASCI ')then 690 write(lupri,*) 'GASCI type requires .GASSHE to be specified.' 691 write(lupri,*) 'Else, I do not know what to do.' 692 call quit(' *** error in setup_lucita_check_input: GASCI run but .GASSHE not specified.') 693 end if 694 end if 695 696! cumulative min. and max. numbers of electrons in GAS spaces 697 if(lucita_cfg_ci_type(1:6).eq.'GASCI ')then 698 if(.not.lucita_cfg_minmax_occ_gas_set)then 699 write(lupri,*) 'GASCI type requires .GASSPC to be specified.' 700 write(lupri,*) 'Else, I do not know what to do.' 701 call quit(' *** error in setup_lucita_check_input: GASCI run but .GASSPC not specified.') 702 end if 703 end if 704 705! sequence of CI spaces - default: 1 (all other values are not supported for 706! LUCITA in Dalton/Dirac) 707 if(lucita_cfg_nr_calc_sequences > 1)then 708 write(lupri,*) ' # of sequence of CI spaces not supported ==> ', lucita_cfg_nr_calc_sequences 709 write(lupri,*) ' LUCITA in Dalton/Dirac supports only one CI space.' 710 call quit(' *** error in setup_lucita_check_input: # of sequence of CI spaces not supported.') 711 end if 712 713! parallel distribution routine 714 if(luci_nmproc > 1)then 715 if(lucipar_cfg_ttss_dist_strategy > 2 .or. lucipar_cfg_ttss_dist_strategy < 1)then 716 write(lupri,*) 'Value for keyword .DISTRT incorrect ==> ',lucipar_cfg_ttss_dist_strategy 717 write(lupri,*) 'input will be ignored' 718 lucipar_cfg_ttss_dist_strategy = 2 719 end if 720 end if 721 722 print_lvl = 0 723 if(ci_run_id == 'standard ci ' .or. ci_run_id == 'initial ci ') print_lvl = 1 724 725 if(print_lvl > 0)then 726 call print_lucita_run_setup(lucita_cfg_run_title, & 727 lucita_cfg_ci_type, & 728 lucita_cfg_nr_roots, & 729 lucita_cfg_ptg_symmetry, & 730 lucita_cfg_nr_active_e, & 731 lucita_cfg_is_spin_multiplett, & 732 lucita_cfg_global_print_lvl, & 733 lucipar_cfg_ttss_dist_strategy, & 734 lucita_cfg_accepted_truncation, & 735 lucita_cfg_density_calc_lvl, & 736 luci_nmproc, & 737 mxpngas, & 738 mxpici, & 739 mxpirr, & 740 igsoccx, & 741 ngssh, & 742 lucita_cfg_nr_ptg_irreps, & 743 ngas, & 744 lupri) 745 end if 746 747 end subroutine setup_lucita_check_input 748 749!******************************************************************************* 750 subroutine print_lucita_run_setup(lucita_cfg_run_title, & 751 lucita_cfg_ci_type, & 752 lucita_cfg_nr_roots, & 753 lucita_cfg_ptg_symmetry, & 754 lucita_cfg_nr_active_e, & 755 lucita_cfg_is_spin_multiplett, & 756 lucita_cfg_global_print_lvl, & 757 lucipar_cfg_ttss_dist_strategy, & 758 lucita_cfg_accepted_truncation, & 759 lucita_cfg_density_calc_lvl, & 760 luci_nmproc, & 761 mxpngas, & 762 mxpici, & 763 mxpirr, & 764 igsoccx, & 765 ngssh, & 766 lucita_cfg_nr_ptg_irreps, & 767 ngas, & 768 print_unit) 769!******************************************************************************* 770! 771! purpose: print LUCITA input settings. 772! 773!******************************************************************************* 774 character (len=72), intent(in) :: lucita_cfg_run_title 775 character (len=72), intent(in) :: lucita_cfg_ci_type 776 integer, intent(in) :: lucita_cfg_nr_roots 777 integer, intent(in) :: lucita_cfg_ptg_symmetry 778 integer, intent(in) :: lucita_cfg_nr_active_e 779 integer, intent(in) :: lucita_cfg_is_spin_multiplett 780 integer, intent(in) :: lucita_cfg_global_print_lvl 781 integer, intent(in) :: lucipar_cfg_ttss_dist_strategy 782 integer, intent(in) :: lucita_cfg_density_calc_lvl 783 integer, intent(in) :: luci_nmproc 784 integer, intent(in) :: mxpngas 785 integer, intent(in) :: mxpici 786 integer, intent(in) :: mxpirr 787 integer, intent(in) :: igsoccx(mxpngas,2,mxpici) 788 integer, intent(in) :: ngssh(mxpirr,mxpngas) 789 integer, intent(in) :: lucita_cfg_nr_ptg_irreps 790 integer, intent(in) :: ngas 791 integer, intent(in) :: print_unit 792 real(8), intent(in) :: lucita_cfg_accepted_truncation 793!------------------------------------------------------------------------------- 794 integer :: i 795 integer :: j 796 integer :: igas 797!------------------------------------------------------------------------------- 798 799! Title 800 write(print_unit,'(/2X,60A1)') ('-',i=1,60) 801 write(print_unit,'(2A)') ' title : ',lucita_cfg_run_title 802 write(print_unit,'(2X,60A1)') ('-',i=1,60) 803! type of CI calculation 804 write(print_unit,'(a,A6/)') ' Type of calculation .................. ', lucita_cfg_ci_type(1:6) 805! number of roots to be treated 806 write(print_unit,'(a,I3)') ' Number of roots to be obtained ....... ', lucita_cfg_nr_roots 807! state symmetry 808 write(print_unit,'(a,I3)') ' Calculation carried out in irrep ..... ', lucita_cfg_ptg_symmetry 809! number of active electrons 810 write(print_unit,'(a,I3)') ' Number of active electrons ........... ', lucita_cfg_nr_active_e 811! spin multiplicity 812 write(print_unit,'(a,I3)') ' Spin multiplicity .................... ', lucita_cfg_is_spin_multiplett 813! LUCITA global print parameter 814 write(print_unit,'(a,i3)') ' Global print level is ................ ', lucita_cfg_global_print_lvl 815! parallel distribution routine 816 if(LUCI_NMPROC > 1)then 817 write(print_unit,'(a,I3)')' Parallel distribution routine ........ ', lucipar_cfg_ttss_dist_strategy 818 end if 819! truncation factor 820 if(lucita_cfg_accepted_truncation /= 1.0d-10)then 821 write(print_unit,'(/a,1P,D10.2)') ' Truncation Factor .................... ',lucita_cfg_accepted_truncation 822 end if 823! density matrix level 824 if(lucita_cfg_density_calc_lvl >= 1)then 825 write(print_unit,'(a,I3)') ' Density matrices level ............... ',lucita_cfg_density_calc_lvl 826 end if 827 828! GAS spaces and occupation constraints 829 write(print_unit,'(/A/A/A/)') & 830 ' ******************************************************************', & 831 ' Generalized active space: shell spaces and occupation constraints ', & 832 ' ******************************************************************' 833 834 select case(lucita_cfg_nr_ptg_irreps) 835 case(1) 836 write(print_unit,'(a,1i4,a)') & 837 ' Irrep:',(i,i = 1,lucita_cfg_nr_ptg_irreps), ' Min. occ Max. occ ' 838 write(print_unit,'(10a)') & 839 ' ========',('====',i = 1,lucita_cfg_nr_ptg_irreps), ' ======== ======== ' 840 do igas = 1, ngas 841 write(print_unit,'(a,i2,a,1i4,i13,i12)') & 842 ' GAS',igas,' ', & 843 (ngssh(i,igas),i = 1, lucita_cfg_nr_ptg_irreps),igsoccx(igas,1,1),igsoccx(igas,2,1) 844 end do 845 case(2) 846 write(print_unit,'(/a,2i4,a)') & 847 ' Irrep:',(i,i = 1,lucita_cfg_nr_ptg_irreps), ' Min. occ Max. occ ' 848 write(print_unit,'(10a)') & 849 ' ========',('====',i = 1,lucita_cfg_nr_ptg_irreps), ' ======== ======== ' 850 do igas = 1, ngas 851 write(print_unit,'(a,i2,a,2i4,i13,i12)') & 852 ' GAS',igas,' ', & 853 (ngssh(i,igas),i = 1, lucita_cfg_nr_ptg_irreps),igsoccx(igas,1,1),igsoccx(igas,2,1) 854 end do 855 case(4) 856 write(print_unit,'(/a,4i4,a)') & 857 ' Irrep:',(i,i = 1,lucita_cfg_nr_ptg_irreps), ' Min. occ Max. occ ' 858 write(print_unit,'(10a)') & 859 ' ========',('====',i = 1,lucita_cfg_nr_ptg_irreps), ' ======== ======== ' 860 do igas = 1, ngas 861 write(print_unit,'(a,i2,a,4i4,i13,i12)') & 862 ' GAS',igas,' ', & 863 (ngssh(i,igas),i = 1, lucita_cfg_nr_ptg_irreps),igsoccx(igas,1,1),igsoccx(igas,2,1) 864 end do 865 case(8) 866 write(print_unit,'(/a,8i4,a)') & 867 ' Irrep:',(i,i = 1,lucita_cfg_nr_ptg_irreps), ' Min. occ Max. occ ' 868 write(print_unit,'(10a)') & 869 ' ========',('====',i = 1,lucita_cfg_nr_ptg_irreps), ' ======== ======== ' 870 do igas = 1, ngas 871 write(print_unit,'(a,i2,a,8i4,i13,i12)') & 872 ' GAS',igas,' ', & 873 (ngssh(i,igas),i = 1, lucita_cfg_nr_ptg_irreps),igsoccx(igas,1,1),igsoccx(igas,2,1) 874 end do 875 end select 876 877 878 end subroutine print_lucita_run_setup 879!******************************************************************************* 880 881 subroutine setup_lucita_par_dist_in_seq(par_dist_block_list, & 882 block_list, & 883 nblock) 884!******************************************************************************* 885! 886! purpose: set parallel distribution list to master-only list. 887! this can be useful in sequential calculations. 888! 889!******************************************************************************* 890 integer, intent(in) :: nblock 891 integer, intent(in) :: block_list(nblock) 892 integer, intent(out) :: par_dist_block_list(nblock) 893!------------------------------------------------------------------------------- 894 integer :: i 895!------------------------------------------------------------------------------- 896 897 i = 1 898 899 do while (i <= nblock) 900 if(block_list(i) > 0) par_dist_block_list(i) = 0 901 i = i + 1 902 end do 903 904 end subroutine setup_lucita_par_dist_in_seq 905!******************************************************************************* 906 907 subroutine setup_lucita_mcci_wrkspc_dimensions(ci_run_id,print_lvl) 908!******************************************************************************* 909! 910! purpose: set dimensions of incoming matrices to LUCITA 911! from the MCSCF environment. 912! note that the allocation is CI-run dependent. 913! 914!******************************************************************************* 915 use lucita_mcscf_ci_cfg 916 use lucita_cfg 917#include "priunit.h" 918#include "mxpdim.inc" 919#include "crun.inc" 920#include "orbinp.inc" 921#include "parluci.h" 922 character(len=12), intent(in) :: ci_run_id 923 integer, intent(in) :: print_lvl 924!------------------------------------------------------------------------------- 925 integer :: tmp_length_p1 926 integer :: tmp_length_p2 927!------------------------------------------------------------------------------- 928 929! initialize internal length of matrices 930 len_cref_mc2lu = 0 931 len_hc_mc2lu = 0 932 len_resolution_mat_mc2lu = 0 933 len_int1_or_rho1_mc2lu = 0 934 len_int2_or_rho2_mc2lu = 0 935 tmp_length_p1 = 0 936 tmp_length_p2 = 0 937 938 if(integrals_from_mcscf_env)then 939! 1-p density matrix / 1-e integrals 940 tmp_length_p1 = nacob**2 941! 2-p density matrix / 2-e integrals 942 if(lucita_cfg_el_operator_level > 1) tmp_length_p2 = (nacob*(nacob+1)/2)**2 943 end if 944 945 select case(ci_run_id) 946 case('return CIdim', 'ijkl resort ', 'fci dump ') ! calculate # of determinants per symmetry irrep / resort integrals to lucita format 947! nothing needs to be allocated 948 case('xc vector ') ! exchange CI/MCSCF vector 949 len_cref_mc2lu = l_combi 950 case('return CIdia', 'analyze Cvec') ! calculate the diagonal part of the CI Hamiltonian matrix , analyze CI vector 951 len_cref_mc2lu = lblock 952 case('sigma vec ', 'Xp-density m', 'rotate Cvec', 'standard ci ', 'initial ci ', 'srdft ci ') 953! calculate sigma vector; 1-/2-particle density matrix; rotate CI vector; perform Davidson CI run 954 len_cref_mc2lu = lblock 955 len_hc_mc2lu = lblock 956 len_resolution_mat_mc2lu = max(lblock,2*lsingle_resolution_block) 957 len_int1_or_rho1_mc2lu = tmp_length_p1 958 len_int2_or_rho2_mc2lu = tmp_length_p2 959 case default 960 print *, ' unknown CI run id: ',ci_run_id,' no memory allocated for the coworkers.' 961 end select 962 963 if(print_lvl > +1)then 964 write(lupri,'(/a )') ' dimensions of CI matrix / integral arrays:' 965 write(lupri,'( a )') ' -----------------------------------------' 966 write(lupri,'( a,i15 )') ' ci matrix #1 ==> ',len_cref_mc2lu 967 write(lupri,'( a,i15 )') ' ci matrix #2 ==> ',len_hc_mc2lu 968 write(lupri,'( a,i15 )') ' resolution block ==> ',len_resolution_mat_mc2lu 969 write(lupri,'( a,i15 )') ' 1-el ij ==> ',len_int1_or_rho1_mc2lu 970 write(lupri,'( a,i15/)') ' 2-el ijkl ==> ',len_int2_or_rho2_mc2lu 971 call flshfo(lupri) 972 end if 973 974 end subroutine setup_lucita_mcci_wrkspc_dimensions 975!******************************************************************************* 976 977#ifdef VAR_MPI 978 979 subroutine setup_lucita_inc_wrkspc_alloc_cw(lucita_ci_run_id, & 980 work_dalton, & 981 kfree_pointer, & 982 lfree, & 983 kcref_pointer, & 984 khc_pointer, & 985 kresolution_mat_pointer, & 986 kint1_or_rho1_pointer, & 987 kint2_or_rho2_pointer, & 988 len_cref, & 989 len_hc, & 990 len_resolution_mat, & 991 len_int1_or_rho1, & 992 len_int2_or_rho2, & 993 print_lvl) 994!******************************************************************************* 995! 996! purpose: allocate matrices for co-workers which are incoming to LUCITA 997! from the Dalton sirius environment. 998! note that the allocation is CI-run dependent. 999! 1000!******************************************************************************* 1001 character(len=12), intent(in) :: lucita_ci_run_id 1002 real(8), intent(inout) :: work_dalton(*) 1003 integer, intent(inout) :: kfree_pointer 1004 integer, intent(inout) :: kcref_pointer 1005 integer, intent(inout) :: khc_pointer 1006 integer, intent(inout) :: kresolution_mat_pointer 1007 integer, intent(inout) :: kint1_or_rho1_pointer 1008 integer, intent(inout) :: kint2_or_rho2_pointer 1009 integer, intent(inout) :: lfree 1010 integer, intent(in) :: len_cref 1011 integer, intent(in) :: len_hc 1012 integer, intent(in) :: len_resolution_mat 1013 integer, intent(in) :: len_int1_or_rho1 1014 integer, intent(in) :: len_int2_or_rho2 1015 integer, intent(in) :: print_lvl 1016!------------------------------------------------------------------------------- 1017 integer :: len_cref_internal 1018 integer :: len_hc_internal 1019 integer :: len_resolution_mat_internal 1020 integer :: len_int1_or_rho1_internal 1021 integer :: len_int2_or_rho2_internal 1022!------------------------------------------------------------------------------- 1023 1024! initialize internal length of matrices 1025 len_cref_internal = 0 1026 len_hc_internal = 0 1027 len_resolution_mat_internal = 0 1028 len_int1_or_rho1_internal = 0 1029 len_int2_or_rho2_internal = 0 1030 1031! initialize pointers 1032 kcref_pointer = -1 1033 khc_pointer = -1 1034 kresolution_mat_pointer = -1 1035 kint1_or_rho1_pointer = -1 1036 kint1_or_rho1_pointer = -1 1037 1038 select case(lucita_ci_run_id) 1039 case('return CIdim', 'ijkl resort ', 'fci dump ') ! calculate # of determinants per symmetry irrep / resort integrals to lucita format 1040! nothing needs to be allocated 1041 case('return CIdia') ! calculate the diagonal part of the CI Hamiltonian matrix 1042 len_cref_internal = len_cref 1043 len_int1_or_rho1_internal = len_int1_or_rho1 1044 len_int2_or_rho2_internal = len_int2_or_rho2 1045 case('sigma vec ', 'Xp-density m', 'rotate Cvec', 'standard ci ', 'initial ci ') 1046! calculate sigma vector; 1-/2-particle density matrix; rotate CI vector; perform Davidson CI run 1047 len_cref_internal = len_cref 1048 len_hc_internal = len_hc 1049 len_resolution_mat_internal = len_resolution_mat 1050 len_int1_or_rho1_internal = len_int1_or_rho1 1051 len_int2_or_rho2_internal = len_int2_or_rho2 1052! analyze CI vector; exchange CI/MCSCF vector 1053 case('analyze Cvec', 'xc vector ') 1054 len_cref_internal = len_cref 1055 case default 1056 print *, ' unknown CI run id: ',lucita_ci_run_id,' no memory allocated for the coworkers.' 1057 end select 1058 1059 call memget('REAL',kcref_pointer, len_cref_internal, work_dalton,kfree_pointer,lfree) 1060 call memget('REAL',khc_pointer, len_hc_internal, work_dalton,kfree_pointer,lfree) 1061 call memget('REAL',kresolution_mat_pointer,len_resolution_mat_internal,work_dalton,kfree_pointer,lfree) 1062 call memget('REAL',kint1_or_rho1_pointer, len_int1_or_rho1_internal, work_dalton,kfree_pointer,lfree) 1063 call memget('REAL',kint2_or_rho2_pointer, len_int2_or_rho2_internal, work_dalton,kfree_pointer,lfree) 1064 1065 if(print_lvl > 2)then 1066 print *, ' memory allocated for the coworkers; pointer values are:' 1067 print *, ' -------------------------------------------------------' 1068 print *, ' kcref_pointer ==> ',kcref_pointer 1069 print *, ' khc_pointer ==> ',khc_pointer 1070 print *, ' kresolution_mat_pointer ==> ',kresolution_mat_pointer 1071 print *, ' kint1_or_rho1_pointer ==> ',kint1_or_rho1_pointer 1072 print *, ' kint2_or_rho2_pointer ==> ',kint2_or_rho2_pointer 1073 print *, ' -------------------------------------------------------' 1074 1075 print *, ' memory allocated for the coworkers; length values are:' 1076 print *, ' -------------------------------------------------------' 1077 print *, ' kcref_pointer ==> ',len_cref_internal 1078 print *, ' khc_pointer ==> ',len_hc_internal 1079 print *, ' kresolution_mat_pointer ==> ',len_resolution_mat_internal 1080 print *, ' kint1_or_rho1_pointer ==> ',len_int1_or_rho1_internal 1081 print *, ' kint2_or_rho2_pointer ==> ',len_int2_or_rho2_internal 1082 end if 1083 1084 end subroutine setup_lucita_inc_wrkspc_alloc_cw 1085!******************************************************************************* 1086#endif /* VAR_MPI */ 1087 1088end module 1089